      PROGRAM PLATON
C ********************************************************************
C * THIS PROGRAM MAY BE USED FREE OF CHARGE ONLY FOR USE WITHIN THE  *
C * ACADEMIC COMMUNITY AND NOT FOR PROFIT WITHOUT EXPLICIT PERMISSION*
C * IT IS TO BE UNDERSTOOD THAT THE AUTHOR OR HIS UNIVERSITY CANNOT  *
C * BE HELD RESPONSIBLE FOR ANY PROBLEMS CAUSED BY ERRORS IN THE CODE*
C ********************************************************************
C *                                                                  *
C *                   *******************************                *
C *                   *    P L A T O N - 2 0 0 6    *                *
C *                   *******************************                *
C *                                                                  *
C *                     (C) 1980-2006  A.L.SPEK                      *
C *                                                                  *
C *                         UTRECHT UNIVERSITY                       *
C *              BIJVOET CENTER FOR BIOMOLECULAR RESEARCH            *
C *                 SECTIE KRISTAL- EN STRUCTUURCHEMIE               *
C *                    PADUALAAN 8, 3584 CH UTRECHT,                 *
C *                          THE NETHERLANDS                         *
C *                                                                  *
C *   PRELIMINARY VERSION (CDC)  .............         1980          *
C *   MICROVAX-II IMPLEMENTATION .............         1986          *
C *   CONVEX/UNIX       ,,       .............         1989          *
C *   SILICON-GRAPHICS  ,,       .............         1990          *
C *   DEC/ULTRIX        ,,       .............         1991          *
C *   LINUX             ,,       .............         1993          *
C *   DEC/OSF/1         ,,       .............         1993          *
C *   SUN-SOLARIS       ,,       .............         1998          *
C *                                                                  *
C ********************************************************************
C * THE PROGRAM -PLATON- HAS BEEN DESIGNED FOR AUTOMATED GENERATION  *
C * AND ANALYSIS OF STEREO-CHEMICAL AND MOLECULAR GEOMETRY DATA,     *
C * STARTING FROM A LIST OF ATOMIC COORDINATES.  IN THE CASE OF      *
C * FRACTIONAL COORDINATES, CELL DIMENSIONS AND SYMMETRY SHOULD BE   *
C * SPECIFIED AS WELL. IN GENERAL ONLY GLOBAL INSTRUCTIONS WILL BE   *
C * NECESSARY TO OBTAIN THE REQUIRED DATA OF THE MOLECULAR GEOMETRY  *
C * FROM A STANDARD (FREE FORMATTED) INPUTFILE.                      *
C * IN  THE -INTRA- MODE  THE PROGRAM GENERATES, ON THE BASIS OF AN  *
C * INTERNAL COVALENT-RADII LIST, ALL BOND DISTANCES, BOND ANGLES,   *
C * TORSION ANGLES, LEAST-SQUARES PLANES, RINGS+ PUCKERING ANALYSIS. *
C * IN  THE -INTER- MODE  A LIST IS GENERATED OF ALL SHORT VAN DER   *
C * WAALS CONTACTS. HYDROGEN BONDS ARE EXPLICITLY LISTED AND ANALYZED*
C * IN  THE -COORDN- MODE  A  LIST  IS  GENERATED OF THE BONDS AND   *
C * ANGLES WITHIN A SPECIFIED RADIUS FROM A GIVEN ATOM.              *
C * IN ADDITION, THE THERMAL MOTION IS ANALYSED WHEN ANISOTROPIC     *
C * THERMAL PARAMETERS HAVE BEEN PROVIDED.                           *
C * ALL CALCULATED  VALUES ARE ACCOMPAGNIED BY STANDARD DEVIATIONS   *
C * CALCULATED  FROM  THE  STANDARD  DEVIATIONS IN THE PARAMETERS,   *
C * WHEN SUPPLIED.                                                   *
C * IN  ADDITION THE PROGRAM GENERATES ON UNIT LU2 A LIST OF DATA    *
C * THAT MAY BE LISTED IN A NEAT FORM WITH THE PROGRAM OMEGA OR USED *
C * OTHERWISE (AS AN ALTERNATIVE FOR THE BUILD-IN TABLE FEATURE).    *
C * OPTIONALLY GRAPHICS FILES SHOWING THE STRUCTURE AS PROJECTIONS   *
C * ON THE VARIOUS LEAST-SQUARES PLANES, NEWMAN PROJECTIONS ETC.     *
C * AN EASY TO USE THERMAL MOTION ELLIPSOID PLOT OPTION IS AVAILABLE.*
C *                                                                  *
C * P O T E N T I A L  M A C H I N E  D E P E N D E N C I E S        *
C * - - - - - - - - -  - - - - - - -  - - - - - - - - - - - -        *
C *                                                                  *
C * - 32 BIT-WORDS MINIMUM ASSUMED (IN VIEW OF PACKING)              *
C *                                                                  *
C ********************************************************************
C *                                                                  *
C *                L I M I T A T I O N S  (LOWER BOUND)              *
C *                ---------------------                        (MIN)*
C *                                                                  *
C * THE MAXIMUM NUMBER OF ATOMS IN THE UNIQUE MOLECULE = NP1     250 *
C * MAXIMUM NUMBER OF LEAST SQUARES PLANES             = NP2      50 *
C * MAXIMUM NUMBER OF CONNECTIONS IN ARRAY CON         = NP4       8 *
C * MAXIMUM BOND OVERFLOW                              = NP6      50 *
C * MAXIMUM NUMBER OF ATOMS IN LEAST SQUARES PLANE     = NP7      50 *
C * MAXIMUM NUMBER OF RESIDUES                         =  63         *
C * MAXIMUM NUMBER OF MOLECULES IN MOLECULE LIST       = NP11-1   64 *
C * MAXIMUM NUMBER WITHIN AN ATOM LABEL                = 999         *
C * DEFAULT NUMBER OF DIFFERENT ATOM KINDS             = NP10     16 *
C * MAXIMUM ARRAY SIZE FOR SCRATCH AND VOID CALCULATION= NPVD 200000 *
C *                                                                  *
C * * WARNING * ONLY NP1 MAY BE MODIFIED SAFELY IN RANGE 250 - 5000  *
C * NPVD SHOULD BE AS LARGE AS POSSIBLE                              *
C ********************************************************************
C *                                                                  *
C *              U N I X  - I M P L E M E N T A T I O N              *
C *              **************************************              *
C *                                                                  *
C * Compile/Link:  f77 -o platon platon.f xdrvr.c -lX11              *
C * Run:           platon sucrose                                    *
C *                                                                  *
C ********************************************************************
C *  S U M M A R Y   O F   P L A T O N   I N S T R U C T I O N S     *
C *---------------------------------------------------------------   *
C *  KEYWORD  I  SUB-KEYWORD(S) I           COMMENT                  *
C *-----------I-----------------I---------------------------------   *
C *ENTRY      I (nr)/(refcode)  |DIR AND POSITION FDAT-FILE (ENTRY)  *
C *-----------I-----------------I---------------------------------   *
C *NOMOVE     I (OFF)           INO MOVE-AROUND OF INPUT ATOMS       *
C *INORG      I                 IINORGANIC MODE                      *
C *ORGA       I                 IORGANIC   MODE                      *
C *ROUND      I ON/OFF/(range)  IROUND OPTION ON/OFF (DEF = ON, 1)   *
C *PARENTHESESI ON/OFF          ILABEL PARENTHESES ON/OFF (DEF = ON) *
C *ORMA       I                 ICAD4-ORIENTATION MATRIX(11,12,..,33)*
C *INCLUDE    I EL1 EL2  (Me)   IINCLUDE SPECIFIED ELEMENTS ONLY     *
C *EXCLUDE    I EL1 EL2  (Me)   IEXCLUDE SPECIFIED ELEMENTS          *
C *SET VDWR   I EL1 rad EL2 rad ISET NON-DEFAULT VDWAALS RADII       *
C *COLOR TYPE I EL1 col1 etc.   ICHANGE DEFAULT COLORS               *
C *-----------I-----------------I------------------------------------*
C *DOAC       IEL1 EL2 ....     IDON./ACCEPT. ATOMS(DEF:N,O,CL,S,F,BR*
C *-----------I-----------------I------------------------------------*
C *HBOND      I(NORM) P1 P2 P3  IH-BOND PARAMETERS (DEF 0.5,-.12,100)*
C *-----------I-----------------I------------------------------------*
C *LINE       IAT1 AT2          IEXPLICIT LINE SPECIFICATION         *
C *-----------I-----------------I------------------------------------*
C *LSPL       IAT1 AT2..DIST AT3IEXPLICIT L.S.-PLANE SPECIFICATION   *
C *-----------I-----------------I------------------------------------*
C *RING       IAT1 AT2 ....     IEXPLICIT RING SPECIFICATION (MAX 30)*
C *-----------I-----------------I------------------------------------*
C *FIT        IA11 A21 A1N A2N..IFIT MOL1 (A11,A12,....,A1N) TO      *
C *           I                 I    MOL2 (A21,A22,....,A2N)         *
C *FIT        IA1A  A1B         ISIMILARLY NUMBERED RESIDUE FIT      *
C *-----------I-----------------I------------------------------------*
C *SAVE       I                 IUSED IN CONJ. WITH ENDS ON TAPE1    *
C *-----------I-----------------I------------------------------------*
C *ASYM       I(AVF)(ZONEX)     IASYM                                *
C *           I(LIST 0/1/2/3)   I                                    *
C *           I(THM thm)(VIEW)  I                                    *
C *           I(EXPECT) (EXPAND)I                                    *
C *           I(VIEW/VALID)     I                                    *
C *-----------I-----------------I------------------------------------*
C *LEPAGE     I(MANG) (MaxDot)  IDO LEPAGE ANALYSIS (METRIC ANGLE)   *
C *           |    (TwoAxCrit)  I                                    *
C *-----------I-----------------I------------------------------------*
C *EXPT       I                 IGIVE # OF EXPECTED REFL FOR RESOLN  *
C *-----------I-----------------I------------------------------------*
C *CALC ADDSYMI (EL/EQUAL/SAVE) ICHECK FOR HIGHER SYMMETRY           *
C *           I (ang d1 d2)     ICHANGE DEFAULT CRITERIA             *
C *           I (SHELX) (NOSF)  IPREPARE NEW FILE FOR SUSPECT ENTRY  *
C *           I (PLOT)          IPLOT NEW AVERAGED STRUCTURE         *
C *-----------I-----------------I------------------------------------*
C *CALC NONSYMI (symmol-tol)    ILOOK FOR NON-CRYST. SYMMETRY        *
C *-----------I-----------------I------------------------------------*
C *CALC NEWSYMI (ang-metric)    ICHECK FOR (HIGHER) SPACE GROUP SYMM *
C *-----------I-----------------I------------------------------------*
C *CALC INTRA I        -        ICALCULATE INTRA MOLECULAR GEO-      *
C *           I                 I METRY USING STANDARD ATOM RADII    *
C *           I                 I D(A-B).LE.R(A)+R(B)+TOLA( =0.4)    *
C *           IEL1 P1 EL2 P2 .. IUSE SPECIFIED ELEMENTAL RADII       *
C *           ITOLA P1          IUSE SPECIFIED TOLERANCE VALUE       *
C *           ITOLEA P1         IADDITIONAL EARTH-ALK. TOLERANCE     *
C *           ITOLM P1          IADDITIONAL TOLERANCE FOR METAL-METAL*
C *           IEWLSPL           IESD-WEIGHT LS-PLANES                *
C *           IUWLSPL           IUNIT-WEIGHT LS-PLANES               *
C *           IAWLSPL           IATOMIC-WEIGHT WEIGHTED LS-PLANES    *
C *           INOTMA            IDO NOT ANALYSE THERMAL MOTION       *
C *           INOBOND           IDO NOT PRINT BOND DISTANCES         *
C *           INOANG            IDO NOT PRINT BOND ANGLES            *
C *           INOTOR            IDO NOT PRINT TORSION ANGLES         *
C *           INOLSP            IDO NOT PRINT L.S-PLANES             *
C *           INORING           IDO NOT SEARCH FOR RINGS             *
C *           INOSTD            IDO NOT CALCULATE ST.DEV. IN PAR.    *
C *           INOMOVE           IDO NOT MOVE PRIMARY ATOMS           *
C *           INOSYMM           IDO NOT APPLY ANY SYMMETRY           *
C *           INOBPA            INO CALCULATION OF BOND/PLANE ANGLES *
C *           ITOLP P1          IMAX OUT OF PLANE DEV. FOR LSP(.1)   *
C *           IMAXDEV           IMAX LIST DIST FROM PLANE (Def 1.5)  *
C *           IMAXRING P1       IMAXIMUM RING-SIZE (default 24)      *
C *-----------I-----------------I------------------------------------*
C *CALC GEOM  I(OMEGA/          IBONDS,ANGLE AND TORSION ANGLES (DEF)*
C *           I MOGLI/EUCLID/   I(AND GENERATE SPECIFIED FILE)       *
C *           I SHELXL/CSD/     I                                    *
C *           I PDB)            I                                    *
C *           I (NOMOVE)        I DO NOT MOVE INPUT ATOMS            *
C *           I (EXPAND)        I OUTPUT SYMMETRY EXPANDED MOLECULES *
C *           I (BOND) (ANGLE)  I                                    *
C *           I (TORSION)       I                                    *
C *-----------I-----------------I------------------------------------*
C *CALC TMA   I (RMAX)          ITHERMAL MOTION ANALYSIS             *
C *           I (HINCL)         I   INCLUDE ANISOTROPIC H-ATOMS      *
C *           I                 I         (def Rmax=0.25)            *
C *           I (Atmin)         I         (def Min numb at=6)        *
C *           I (Cartesian)     ILIST CARTESIAN UIJ AS WELL          *
C *-----------I-----------------I------------------------------------*
C *CALC INTER I        -        ICALCULATE INTERMOLECULAR GEOMETRY   *
C *           I(NOMOVE)         I WITH VAN DER WAALS RADII + TOLR=0.2*
C *           ITOLR P1          IUSE SPECIFIED TOLERANCE VALUE       *
C *           IEL1 P1 EL2 P2 .. I MODIFY LISTED CONTACT RADII        *
C *-----------I-----------------I------------------------------------*
C *CALC HBONDSI P1 P2 P3        IHBOND - ANALYSIS                    *
C *           I (NONA)          I No Network Analysis                *
C *           I (DISORDER)      I INCLUDE MINOR DISORDER             *
C *-----------I-----------------I------------------------------------*
C *CALC COORDNI (P1)            ICOORDN RADII NON C,H-ATOMS(DEF=3.6) *
C *           IEL1 P1 EL2 P2 .. ICALCULATE COORDN SPHERE GEOMETRY    *
C *           I                 I FOR THE SPECIFIED ELEMENTS ONLY.   *
C *           I (NOANG)         I SUPPRESS ANGLE CALCULATION         *
C *           I (FIVE (TBA))    I ANALYSE FIVE COORDINATION          *
C *           I (EUCLID)        I(OUTPUT ON SPECIFIED FILE TYPE)     *
C *-----------I-----------------I------------------------------------*
C *CALC COORDNI atom-name p1    I COORDINATION SPHERE FOR SPEC. ATOM *
C *           I (NOANG)         I                                    *
C *-----------I-----------------I------------------------------------*
C *CALC METAL I (p1)            IMETAL..METAL DISTANCES (DEF. 10 A ) *
C *-----------I-----------------I------------------------------------*
C *CALC RDF   I (p1)            I CALC RADIAL DISTRIBUTION FUNCTION  *
C *-----------I-----------------I------------------------------------*
C *CALC DIST  I EL (p1)         I EL-EL DISTANCE SCAN                *
C *-----------I-----------------I------------------------------------*
C *CALC SOLV  I (PROBE rad)     I DETERMINE SOLVENT ACCESSIBLE AREAS *
C *           I (PSTEP n/GRID x)I GRID = rad / n or as given         *
C *           I (LIST/LISTxyz)  I LIST MAP ON LISTING FILE           *
C *           I (SAR)           I WRITE FILE WITH SOLVENT GRID POINTS*
C *CALC VOID  I (PROBE rad)     I SEARCH FOR VOIDS IN THE STRUCTURE  *
C *           I (PSTEP n)       I GRID = rad / n                     *
C *           I (LIST/LISTxyz)  I LIST MAP ON DISPLAY                *
C *-----------I-----------------I------------------------------------*
C *CALC SQUEEZE (NCYC) (FCAL)   I (HANDLE DISORDERED SOLVENT REGION) *
C *-----------I-----------------I------------------------------------*
C *CALC FCF   I (GENERATE)      I CALCULATE STRUCTURE FACTORS        *
C *CALC DELABSI(NOTHCO)(NOCHECK)I EMPIRICAL ABSORPTION CORRECTION    *
C *           I                 I NOTHCORRECTION;DIRECTION COS CHECK *
C *-----------I-----------------I------------------------------------*
C *ABSG       I mu,(ng1,ng2,ng3)I GAUSSIAN INTEGRATION ABS CORRECTION*
C *           I (NOCHECK)(LIST) I                                    *
C *ABST       I mu              I MEULENAAR & TOMPA ABS. CORR.       *
C *           I (NOCHECK)(LIST) I                                    *
C *ABSP       I                 I PSI-SCAN ABS CORRECTION            *
C *           I (NOCHECK)(LIST) I                                    *
C *ABSS       I mu*r            I SPHERICAL ABSORPTION CORRECTION    *
C *           I (NOCHECK)(LIST) I                                    *
C *-----------I-----------------I------------------------------------*
C *MULABS     I mu radius       I MULTISCAN ABSORPTION CORRECTION    *
C *           I (NOCHECK)(LIST) I                                    *
C *-----------I-----------------I------------------------------------*
C *CALC       I (ALL)           IDEFAULT CALCULATION OF ALL GEOMETRY *
C *-----------I-----------------I------------------------------------*
C *LIST/INFO  I CELL            I LIST CELL DIMENSIONS ON DISPLAY    *
C *LIST/INFO  I SYMM            I LIST CURRENT SYMMETRY              *
C *LIST/INFO  I ATOM (type)(res)I LIST CURRENT ATOM-TABLE (SELECT)   *
C *LIST/INFO  I BOND (type)(res)I LIST CURRENT BOND-TABLE (SELECT)   *
C *LIST/INFO  I UIJ             I LIST UIJ                           *
C *LIST/INFO  I RADII           I LIST COVALENT & V.D.WAALS RADII    *
C *LIST/INFO  I IPR (IVL1(IVL2))I LIST INTEGER PARAMETER VALUE       *
C *LIST/INFO  I PAR (IVL1(IVL2))I LIST REAL PARAMETER VALUE          *
C *LIST/INFO  I FLAG            I LIST INTERNAL FLAG VALUES          *
C *-----------I-----------------I------------------------------------*
C *DIST       I AT1 AT2         IINTERACTIVE DISTANCE CALCULATION    *
C *ANGL       I AT1 AT2 AT3(AT4)I    ,,      ANGLE       ,,          *
C *TORS       I AT1 AT2 AT3 AT4 I    ,,      TORSION     ,,          *
C *LSPL       I AT1 AT2 .....   I    ,,      LEAST-SQUARES PL ,,     *
C *LSPL       I AT1 AT2 .. WITH IINTERACTIVE ANGLE BETWEEN PLANES    *
C *           I AT11 AT12 ..    I                                    *
C *           I (DIST AT3 ..)   I            (TO PLANE DISTANCE)     *
C *FIT        IA11 A21 A1N A2N..IFIT MOL1 (A11,A12,....,A1N) TO      *
C *           I                 I    MOL2 (A21,A22,....,A2N)         *
C *GEOM       I AT1             I    ,,      BONDS,ANGLES FOR AT1    *
C *-----------I-----------------I------------------------------------*
C *PLOT       I LSPL            IPLOT SPECIFIED PLANE(S)             *
C *           I PLAN            I     AUTOM.    PLANE(S)             *
C *           I RING            I                RING(S)             *
C *           I RESD            I             RESIDUE(S)             *
C *           I ALONG           IPLOT WITH PLANE NORMAL UPWARDS(Y)   *
C *           I PERP            IPLOT DOWN PLANE NORMAL              *
C *           I (DISPLAY/META)  IPLOT MEDIUM (DEFAULT DISPLAY)       *
C *-----------I-----------------I------------------------------------*
C *PLOT       I NEWMAN (AT1 AT2)INEWMAN PLOT(S) (FOR SPECIFIED BOND) *
C *           I (DISPLAY/META)  IPLOT MEDIUM (DEFAULT DISPLAY)       *
C *           I (COLOR)         I                                    *
C *-----------I-----------------I------------------------------------*
C *PLOT       I ADP             IPLOT ANISOTR. DISPLACEMENT ELLIPSOID*
C *           I (DISPLAY/META)  I     PLOT MEDIUM (DEFAULT DISPLAY)  *
C *           I (COLOR)         ICOLOR O,N AND HALOGENS              *
C *           I (OCTANT/HETERO/ IELLIPSOID TYPE                      *
C *           I  ENVELOPE)      I                                    *
C *           I (LABELS/NOLABEL)ILABEL PLOT                          *
C *           I (HATOM/NOHATOM) IH-ATOM (IN/EX)CLUDE                 *
C *           I (PARENT/NOPAREN)ILabels with or without parentheses  *
C *           I (MARGIN marg)   IOVERLAP MARGIN                      *
C *           I (RESIDUE resnr) IResidue number to be plotted (0=all)*
C *-----------I-----------------I------------------------------------*
C *PLOT       I POLY            IPOLYEDER PLOT (IMPLEM IN PROGRESS)  *
C *-----------I-----------------I------------------------------------*
C *RADII BONDSI (LIST/TO MET/   IRESET (LIST)DEFAULT BOND PARAMETERS *
C *           I TO H/NORMAL/ALL)IFOR ADP PLOT                        *
C *           I(bond-type (rad))I -5 <= bondtype <= 5 and radius(Ang)*
C *-----------I-----------------I------------------------------------*
C *ELLIPSOID  |(C/H/Other)      IPLOT TYPES OF ELLIPSOID SHAPES      *
C *           I type (lines)    Itype 0/1                            *
C *-----------I-----------------I------------------------------------*
C *JOIN       I At1 At2 ((L)DASH) ADD (DASHED) BOND FOR PLOTTING     *
C *DETACH     I At1 At2         IDELETE BOND FROM PLOT LIST          *
C *DEFINE     I At1 TO At2 ..ATnIADD BOND TO CG                      *
C *           I (DASH)          I (Optionally dashed)                *
C *-----------I-----------------I------------------------------------*
C *BOX        I (ON/OFF)        IOUTLINE BOX WITH TEXT ON/OFF        *
C *           I (RATIO ratio)   I HOR/VERT RATIO ADP PLOT            *
C *-----------I-----------------I------------------------------------*
C *VIEW       I                 IDEFAULT 0,0,0                       *
C *VIEW       I (UNIT) (XR P1)  IROTATE ABOUT X,Y,Z BY P1,P2,P3 ETC. *
C *VIEW       I MIN             ICALCULATE MINIMUM OVERLAP ORTEP     *
C *VIEW       I INVERT          IINVERT VIEW-MATRIX                  *
C *-----------I-----------------I------------------------------------*
C *HELP       IMANUAL  (PRINT)  IGIVES (ON LINE/PRINTED) MANUAL      *
C *           ISPGR             ILISTS KNOWN SPACE GROUPS            *
C *-----------I-----------------I------------------------------------*
C *END        I                 INORMAL END OF PROGRAM               *
C *STOP/QUIT  I                 IFORCED END OF PROGRAM               *
C *EXIT       I                 IFORCED END OF PROGRAM               *
C *-----------I-----------------I------------------------------------*
C *MENU       I(ON/OFF)         IMOUSE/MENU ON/OFF                   *
C *-----------I-----------------I------------------------------------*
C *SET        IPAR/IPR nr val   ISET PARAMETERS                      *
C *SET        IPROB (10<-->90)  ISET PROBABILITY LEVEL (DEF=50)      *
C *SET        IPRINTER LEVEL levISET PRINT LEVEL                     *
C *SET        ILABEL SIZE (size)ISET SIZE OF LABELS                  *
C *SET        IWINDOW fraction  IMANIPULATE X-WINDOW-size            *
C *-----------I-----------------I------------------------------------*
C *TABLE      I(SU/AC/JA/IC)    IGENERATE PUBLICATION/SUPPL.MAT.TABL.*
C *           I(NOHATOM)        I                                    *
C *           I(NORESIDUE)      I DO-NOT SPLIT IN RESIDUES           *
C *TABLE      I(CIF/CSD) (LOCAL)I GENERATE CIF-FILE FOR ACC-PUBL.    *
C *-----------I-----------------I------------------------------------*
C *CONTOUR    I                 ICONTOUR PLOTS (IMPL. IN PROGRESS)   *
C *           I(FO/DIFF/SQUEEZE)ITYPE OF MAP (DEFAULT FO)            *
C ********************************************************************
C *                                                                  *
C *    S T A N D A R D  I N P U T  O N  F I L E  <U N I T 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                                 *
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 *                                                                  *
C ********************************************************************
C *                                                                  *
C *                        R E M A R K S                             *
C *                        - - - - - - -                             *
C * # 1  -  A FILE THAT STARTS WITH THE KEYWORD FVAR IS INTERPRETED  *
C *         FOLLOWING THE CONVENTIONS OF SHELX                       *
C * # 2  -  SYMMETRY MAY BE SPECIFIED ALSO WITH LATT AND SYMM CARDS  *
C *         FOLLOWING THE CONVENTIONS OF SHELX                       *
C * # 3  -  CARDS THAT START WITH AN ATOM LABEL, FOLLOWED BY THREE   *
C *         NUMBERS ARE INTERPRETED AS ATOM CARDS                    *
C * # 4  -  AN ATOMLABEL MAY CONTAIN THE SYMBOLS ' AND "             *
C * # 5  -  AN ATOMLABEL (EXCLUDING PARENTHESES CANNOT TAKE MORE THAN*
C *         FOUR 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 *                                                                  *
C *                    F  I  L  E  S                                 *
C *                   ---------------                                *
C *                                                                  *
C * UNIT LU1 - INPUT OF PARAMETER DATA (CIF/RES/SPF etc)             *
C * UNIT LU2 - OUTPUT OF PLATON DATA FOR SHELX(L) ETC.               *
C * UNIT LU3 - SAVE(D) INSTRUCTION FILE (FOR INTERNAL USE ONLY)      *
C * UNIT LU4 - SCRATCH FILE (BINARY) ATOMIC PARAMETERS               *
C * UNIT LU5 - INTERACTIVE INPUT OF CONTROL RECORD(S) FOR CALCN(S)   *
C * UNIT LU6 - INTERACTIVE OUTPUT TO DISPLAY                         *
C * UNIT LU7 - LINEPRINTER OUTPUT                                    *
C * UNIT LU8 - SCRATCH-BINARY FILE  (PLANES ETC)                     *
C * UNIT LU9 - REFLECTION SCRATCH (BINARY)                           *
C * UNIT LU10- VALIDATION-LIST-OUTPUT                                *
C * UNIT LU11- (GRAPHICS)                                            *
C * UNIT LU12- PUB-FILE (TABLE)                                      *
C * UNIT LU13- SUP-FILE (TABLE)                                      *
C * UNIT LU14- SCRATCH (ASYM) OR CHECK.SUM                           *
C * UNIT LU15- SAR-FILE                                              *
C * UNIT LU16- REFLECTION DATA IN                                    *
C * UNIT LU17- REFLECTION DATA OUT (HKP)                             *
C * UNIT LU18- REFLECTION DATA OUT (HKS)                             *
C * UNIT LU19- IUCR-CHECK-DEF(VALIDATION)                            *
C * UNIT LU20- CHECK-SCRATCH (FORMATTED)                             *
C * UNIT LU21- BIN                                                   *
C * INIT LU22- FCK-FILE                                              *
C * UNIT LU23-                                                       *
C * UNIT LU24-                                                       *
C * UNIT LU25- PLUTON - DGE                                          *
C * UNIT LU26- MODIFIED SHELXL.RES FILE                              *
C * UNIT LU27- PLUTON.PJN                                            *
C * UNIT LU28- POVRAY.POV                                            *
C * UNIT LU29- DIRECT-SCRATCH                                        *
C * UNIT LU30- DIRECT-SCRATCH                                        *
C *                                                                  *
C ********************************************************************
C ********************************************************************
      PARAMETER (NP12=600,NP13=500,NP17=99,NP38=125,NP39=30)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
C * GLOBAL INIT (IGBL & GL)
C * GET COMMAND-LINE ARGUMENTS
C * CHECK FOR ESCAPE MODES TO (S, HELENA, SHX86, STIDY)
      CALL PLA000 (-1)
C * MAJOR PLATON LOOP (MANAGED BY THE VALUE OF IGBL(1) = [-1,0,1,2,3,4])
C * IGBL(1) = -1 - INIT & FILE OPEN
C * IGBL(1) =  0 - MANAGE DATA FILE LU1
C * IGBL(1) =  1 - RESTART FOR NEW DATA-SET
C * IGBL(1) =  2 - NEW INSTRUCTION & EXECUTE FOR CURRENT ENTRY
C * IGBL(1) =  3 - ERROR HANDLING
C * IGBL(1) =  4 - TERMINATE JOB
   10 IF (IGBL(1) .LT. 4) THEN
C * INIT & FILE OPEN (IGBL(1) = -1 ==> 0)
        IF (IGBL(1) .EQ. -1) THEN
          CALL PLA000 (0)
C * MANAGE DATA FILE LU1
        ELSE IF (IGBL(1) .EQ. 0) THEN
          CALL PLA000 (1)
C * RESTART FOR NEW DATASET
        ELSE IF (IGBL(1) .EQ. 1) THEN
          CALL PLA001
C * READ DATA AND INSTRUCTIONS
        ELSE IF (IGBL(1) .EQ. 2) THEN
          CALL PLA002
C * ERROR HANDLING (AND SUMMARY)
        ELSE IF (IGBL(1) .EQ. 3) THEN
          CALL PLA003
        ENDIF
        GOTO 10
      ENDIF
C * CLOSE & TERMINATE PLATON RUN
      CALL PLA004 (0)
      END
      SUBROUTINE PLA000 (MODE)
      PARAMETER (NP4=9,NP10=16,NP12=600,NP13=500,NP17=99,NPVD=40000000,
     1 NP22=256,NP38=125,NP39=30,NP45=2048)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /Q/ ICL, IFL(NP17)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 DID*9, TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /TIMER/ TIMT, TIMEZ, TIMEA, ISAVEMOD
      COMMON /FNAME/ KNM(8), KXT, KNM16
      COMMON /NAMES/ NAME(8), EXTENS, PROGNM, FNLU1, FNLU16, RDTYPE
      CHARACTER NAME*80, EXTENS*9, PROGNM*28, FNLU1*80, FNLU16*80,
     1          RDTYPE*7
      COMMON /CGGT/ IGGT
      CHARACTER FNLU12*80, FNLU13*80, FNLU14*80, FNLU17*80,
     1 FNLU21*80, IGGT*80
      LOGICAL EXST12, EXST13, EXST21
      COMMON /PATHS/ PLAPATH, BROWSER, CGETENV
      CHARACTER PLAPATH*255, BROWSER*255, CGETENV*255
      COMMON /TODAY/ DATIJD
      CHARACTER DATIJD*25
      COMMON /VALDOC/ NDOC(999)
      COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0
      INTEGER FINDEXE
      LOGICAL OPEND, EXST
C * MODE = -1 - GLOBAL INIT & ESCAPE
C * MODE =  0 - INIT & FILE-OPEN
C * MODE =  1 - MANAGE DATA FILE ON LU1
C * GLOBAL INIT & ESCAPES FOR (S, HELENA, SHX86, STIDY)
      IF (MODE .LT. 0) THEN
        CALL GEN097 (IGBL, 1, NP38, 0)
C * SET VERSION DATE
        IGBL(9) = 270106
C * CHECK For PLATON
        IGBL(80) = FINDEXE ('PLAEXE', PLAPATH, 'platon')
C * CHECK FOR POVRAY
        IGBL(79) = FINDEXE ('POVEXE', CGETENV, 'povray')
C * CHECK FOR RASMOL
        IGBL(78) = FINDEXE ('RASEXE', CGETENV, 'rasmol')
C * CHECK FOR RASTER
        IGBL(77) = FINDEXE ('R3DEXE', CGETENV, 'render')
C * CHECK FOR CONQUEST
        IGBL(76) = FINDEXE ('QUESTEXE', CGETENV, 'cqbatch')
C * CHECK FOR FIREFOX/MOZILLA/NETSCAPE HELP
        IGBL(47) = FINDEXE ('NETEXE', BROWSER, 'firefox')
        IF (IGBL(47) .EQ. 0) THEN
          IGBL(47) = FINDEXE ('NETEXE', BROWSER, 'mozilla')
          IF (IGBL(47) .EQ. 0) THEN
            IGBL(47) = FINDEXE ('NETEXE', BROWSER, 'netscape')
          ENDIF
        ENDIF
C * CHECK FOR check.def (CIF-Validation)
        CALL GETENV ('CHECKDEF', CGETENV)
        IF (CGETENV(1:1) .EQ. ' ') CGETENV = 'check.def'
        INQUIRE (FILE = CGETENV, EXIST = EXST)
        IF (EXST) THEN
          OPEN (UNIT = LU19, FILE = CGETENV, FORM = 'FORMATTED',
     1        STATUS = 'OLD')
          READ (LU19, 99998, END = 10) IDM
          IF (IDM(1:10) .EQ. '#*********') IGBL(19) = 1
   10     CALL GEN108 (LU19, 0)
        ENDIF
        OPEN (UNIT = LU20, STATUS = 'SCRATCH', FORM = 'FORMATTED',
     1         ERR = 150)
C * MACHINE SPECIFIC ROUTINE TO GET DATA AND TIME
        CALL FDATE (DATIJD)
        PROGNM = 'PLATON-'//DATIJD(5:24)
C * MACHINE DEPENDENT ROUTINE TO GET CPUTIME
        TIMEZ = CPUTIM()
C * INITIALIZE GLOBAL PARAMETERS
        CALL GEN097 (NDOC, 1, 999, 0)
        ISAVEMOD = 0
        XSH0  = 0.0
        YSH0  = 0.0
        GL(1) = 19.5
        VERT  = GL(1)
        GL(2) = 4.0 / 3.0
        HORS  = VERT * GL(2)
        IWIN  = 0
        GL(6) = 8 * ATAN2 (1.0, 1.0)
        GL(5) = 360.0 / GL(6)
        GL(7) = GL(6)**2 / 2.0
        GL(8) = 4.0 * GL(7)
        GL(25) = 1.0
        GL(26) = 0.4
        GL(27) = 0.5
        GL(28) = 0.0
        GL(29) = 0.0
        GL(30) = 0.0
        IGBL(25) = 1
        IGBL(33) = 1
        IGBL(35) = 1
        IGBL(56) = 1
        IGBL(70) = 1
        IGBL(62) = 4
        IGBL(64) = 4
        IGBL(63) = 4
        IGBL(82) = 1
        IGBL(83) = 1
        IGBL(89) = 5
        IGBL(86) = NPVD - 6
        IGBL(102) = 56
        IGBL(103) = 1
        CALL GEN038 (DID,  1, 9)
        CALL GEN038 (LINE, 1, 80)
        CALL GEN038 (IDM,  1, 80)
        CALL GEN038 (ICL,  1, 80)
        LRT = 0
C * RUN OVER SWITCHES AND ARGUMENTS
        CALL PLA005 (-1, LINE, ICL, LRT)
        CALL PLA261 (LINE)
        IGBL(1) = 4
C * ESCAPE TO SYSTEM-S  '-s'
        IF (IGBL(3) .EQ. 14) THEN
          CALL PLA017
          CALL S
C * ESCAPE TO HELENA '-k'
        ELSE IF (IGBL(3) .EQ. 15) THEN
          CALL PLA017
          CALL PLA240
C * ESCAPE TO EXPLICIT SHX86-MODE '-X'
        ELSE IF (IGBL(3) .EQ. 32) THEN
          TREF = 100
          CALL PLA155 (TREF)
C * ESCAPE TO 'NATIVE' STIDY MODE (-Y)
        ELSE IF (IGBL(3) .EQ. 39) THEN
          CALL GEN038 (JID,  1, 80)
          CALL PLA301
        ELSE
          IGBL(1) = -1
        ENDIF
      ELSE IF (MODE .EQ. 0) THEN
C * INIT & FILE OPEN
C * EXTRACT FILENAME ARGUMENT FROM COMMAND LINE
        CALL PLA261 (LINE)
        CALL PLA017
        IGBL(1) = 0
        CALL GEN038 (IGGT, 1, 80)
        OPEN (UNIT = LU3, STATUS = 'SCRATCH', FORM = 'FORMATTED')
        OPEN (UNIT = LU23, FILE = NAME(1)(1:KNM(1))//'.def',
     1                                       STATUS = 'UNKNOWN')
        READ (LU23, 99998, END = 60) ICL(1:80)
        IGBL(21) = 1
   60   CALL GEN108 (LU23, 0)
        OPEN (UNIT = LU24, STATUS = 'SCRATCH')
        IF (EXTENS(1:3) .NE. 'dge') THEN
          OPEN (UNIT = LU25, FILE = NAME(2)(1:KNM(2))//'.dge',
     1                                      STATUS = 'UNKNOWN')
        ELSE
          IGBL(4) = -1
        ENDIF
        OPEN (UNIT = LU26,  FILE = NAME(1)(1:KNM(1))//'.new',
     1                                     STATUS = 'UNKNOWN')
        OPEN (UNIT = LU27,  FILE = NAME(1)(1:KNM(1))//'.pjn',
     1                                     STATUS = 'UNKNOWN')
        IF (IGBL(3) .EQ.  8 .OR.
     1      IGBL(3) .EQ. 12 .OR.
     2      IGBL(3) .EQ. 13 .OR.
     3      IGBL(3) .EQ. 26) THEN
          CALL PLUTON (-1)
          IGBL(1) = 4
        ELSE
          OPEN (UNIT = LU11, STATUS = 'SCRATCH', FORM = 'UNFORMATTED',
     1          ERR = 150)
C * REDIRECT CONSOLE-OUTPUT for -u & -V (-W) validation modes
          IF (IGBL(3) .EQ. 1 .OR. IGBL(3) .EQ. 33 .OR.
     1        IGBL(3) .EQ. 34) LU6 = LU20
          OPEN (UNIT = LU4, STATUS = 'SCRATCH', FORM = 'UNFORMATTED',
     1          ERR = 150)
          OPEN (UNIT = LU8, STATUS = 'SCRATCH', FORM = 'UNFORMATTED',
     1          ERR = 150)
          OPEN (UNIT = LU9, STATUS = 'SCRATCH', FORM = 'UNFORMATTED',
     1          ERR = 150)
C * CHECK FOR RECORD LENGTH (I.E. WORD OR BYTE-COUNT)
          NSIZE = 1
          DO 80 I = 1, 2
            NRZ = 14 * NSIZE
            OPEN (UNIT = LU29, STATUS = 'SCRATCH',
     1        FORM = 'UNFORMATTED', ACCESS = 'DIRECT', RECL = NRZ)
            WRITE (LU29, REC = 1, ERR = 70) (FN(II), II = 1, 14)
            GOTO 90
   70       NSIZE = 4
            CLOSE (UNIT = LU29, STATUS = 'DELETE')
   80     CONTINUE
          STOP 'CANNOT FIGURE OUT DIRECT ACCESS RECORD LENGTH'
   90     NRZ = 11 * NSIZE
          OPEN (UNIT = LU30, STATUS = 'SCRATCH', FORM = 'UNFORMATTED',
     1        ACCESS = 'DIRECT', RECL = NRZ)
          FNLU12 = NAME(1)(1:KNM(1)) //'.pub'
          FNLU13 = NAME(1)(1:KNM(1)) //'.sup'
          FNLU14 = NAME(1)(1:KNM(1)) //'.sum'
          FNLU21 = NAME(1)(1:KNM(1)) //'.bin'
          FNLU17 = NAME(4)(1:KNM(4)) //'.hkp'
          OPEN (UNIT = LU14, FILE = FNLU14, STATUS = 'UNKNOWN')
          IF (IGBL(7) .EQ. 0) THEN
            OPEN (UNIT = LU7,  FILE = NAME(1)(1:KNM(1)) //'.lis',
     1            STATUS = 'UNKNOWN')
            IGBL(7) = 1
          ENDIF
          INQUIRE (FILE = FNLU12, EXIST = EXST12)
          OPEN (UNIT = LU12, FILE = FNLU12, STATUS = 'UNKNOWN')
          CALL GEN108 (LU12, 0)
          IF (EXST12) THEN
            READ (LU12, 99998, END = 100) ICL(1:80)
            IGBL(12) = 1
          ENDIF
  100     INQUIRE (FILE = FNLU13, EXIST = EXST13)
          OPEN (UNIT = LU13, FILE = FNLU13, STATUS = 'UNKNOWN')
          IF (EXST13) THEN
            READ (LU13, 99998, END = 110) ICL(1:80)
            IGBL(13) = 1
          ENDIF
  110     IF (IGBL(12) .NE. 0 .OR. IGBL(13) .NE. 0) WRITE (LU6, 99999)
          OPEN (UNIT = LU15, FILE = NAME(1)(1:KNM(1)) //'.sar',
     1        STATUS = 'UNKNOWN', FORM = 'UNFORMATTED')
          OPEN (UNIT = LU17, FILE = FNLU17, STATUS = 'UNKNOWN')
          CALL GEN108 (LU17, 0)
          INQUIRE (FILE = FNLU21, EXIST = EXST21)
          OPEN (UNIT = LU21, FILE = FNLU21, STATUS = 'UNKNOWN',
     1          FORM = 'UNFORMATTED')
          IF (EXST21) THEN
            READ (LU21, END = 120)
            IGBL(16) = 1
          ENDIF
  120     IPR(437) = 0
C * FIND REFLECTIONS (fcf or hkl STYLE)
          CALL PLA286
        ENDIF
      ELSE IF (MODE .GT. 0) THEN
C * TARGET DEPENDENCY
        KNMXT = KNM(3) + KXT + 1
        FNLU1 = NAME(3)(1:KNM(3))//'.'//EXTENS(1:KXT)
        INQUIRE (FILE = FNLU1, OPENED = OPEND)
        IF (OPEND) THEN
          INQUIRE (FILE = FNLU1, NUMBER = IUNIT)
            LU1 = IUNIT
        ELSE
          INQUIRE (UNIT = LU1, OPENED = OPEND)
          IF (OPEND) CLOSE (LU1)
          OPEN (UNIT = LU1, FILE = FNLU1, FORM = 'FORMATTED',
     1                 STATUS = 'OLD', ERR = 130)
        ENDIF
        WRITE (LU6, 99997) FNLU1(1:KNMXT)
        IGBL(39) = 1
        GOTO 140
  130   WRITE (LU6, 99996) FNLU1(1:KNMXT)
        IF (IGBL(3) .EQ. 30) GOTO 150
        IGBL(8)  = 1
        IGBL(39) = 0
        LU1      = LU3
  140   CALL GEN108 (LU3,  0)
        CALL GEN108 (LU4,  0)
        CALL GEN108 (LU8,  0)
        CALL GEN108 (LU12, 0)
        CALL GEN108 (LU13, 0)
        CALL GEN108 (LU14, 0)
        CALL GEN108 (LU15, 0)
        CALL GEN108 (LU17, 0)
        IF (IGBL(90) .EQ. 2) THEN
          ICL      = 'ENTRY '//JID(1:9)
          IPR(220) = 2
          IPR(221) = 0
          IGBL(8)  = -4
          CALL PLA011
        ELSE IF (IGBL(90) .EQ. 1) THEN
          IGBL(8)  = 3
          IPR(220) = 1
          IPR(221) = 0
          FN(1)    = 1
          CALL PLA011
        ENDIF
        IGBL(1) = 1
      ENDIF
      RETURN
  150 STOP ' STOP OPEN ERROR'
99999 FORMAT (/, '!! ''.sup'' and/or ''.pub'' files EXIST and may be',
     1        ' DESTROYED in the', /, '!! following calculations. ',
     2        'QUIT and RENAME files NOW to avoid this to happen.', /)
99998 FORMAT (A)
99997 FORMAT (':: Data from: ', A)
99996 FORMAT ('!! File ', A, ' NOT Available, Interactive Input ',
     1          'Assumed', /)
      END
      SUBROUTINE PLA001
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118,
     1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP22=256,
     2 NP25=99,NP29=63,NP31=30,NP35=110,NP36=1000,NP38=125,NP39=30,
     3 NP41=200,NP47=9,NCS=50)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9),
     1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10),
     2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10),
     3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770)
      COMMON /CFSPGR/ EXT, ILAT0, ILAT1, LAUE
      CHARACTER EXT(NCS)*1, ILAT0*1, ILAT1*1, LAUE*5
      COMMON /CGGT/ IGGT
      CHARACTER IGGT*80
      COMMON /PAGEIN/ INDEXP(25), INDP
      COMMON /PAGENM/ PAGET, PAGEIND(25)
      CHARACTER PAGET*8, PAGEIND*8
      COMMON /MEN/ MENA(25, NP31), MENS(25, NP31), MENU(50, NP31),
     1        MNH(NP35)
      COMMON /ALIASES/ ALAB(NP36), BLAB(NP36)
      CHARACTER ALAB*7, BLAB*7
      COMMON /BONDTYPE/ BNDTP(11)
      CHARACTER BNDTP*5
      COMMON /LITREF/ LREF
      CHARACTER LREF(25)*80
      CALL GEN097 (MNH, 1, NP35, 0)
      MNH(6)   = 2
      MNH(7)   = 2
      IGBL(23) = 1
      IGBL(71) = 0
      ILAT0    = ' '
      ILAT1    = 'P'
      LAUE     = ' '
      KRAD     = '??'
      INDP     = 0
      PAGET    = 'GENERAL'
      RP(1)    = 1.0
      CALL GEN097 (MLTI, 1, 64, 1)
      IGBL(8) = IABS(IGBL(8))
      IF (IGBL(53) .EQ. 0) THEN
        DO 10 I = 1, 11
          CALL GEN038 (BNDTP(I), 1, 5)
   10   CONTINUE
      ENDIF
      CALL GEN038 (JID,  1, 80)
      CALL GEN038 (IGGT, 1, 80)
      DO 15 I = 1, 25
        CALL GEN038 (LREF(I), 1, 80)
   15 CONTINUE
      DO 20 I = 1, 5
        RLWS(I) = ' ?'
   20 CONTINUE
      DO 30 I = 1, 4
        CALL GEN038 (SPGRNM(I), 1, 26)
   30 CONTINUE
      CALL GEN038 (ZSPG     , 1, 7)
      DO 40 I = 1, NP36
        CALL GEN038 (ALAB(I), 1, 7)
        CALL GEN038 (BLAB(I), 1, 7)
   40 CONTINUE
      CALL GEN048 (0, I, 0, I)
      CALL GEN097 (IPPR, 1, 129 * 3, 0)
      IPPR(1, 1) = 1000
      IPPR(1, 2) = 0
      IPPR(1, 3) = 1
      DO 80 I = 1, NP10
        IENLB(I) = 0
        DO 60 J = 1, 4
          RADR(I, J) = -1
   60   CONTINUE
        IACL(I)  = 1
        DO 70 J = 1, 2
          LMT(I, J) = '  '
          IENS(I)   = I
   70   CONTINUE
   80 CONTINUE
      CALL GEN074 (XJX, 0.0, 1, 12)
      CALL GEN021 (TM1, 1)
      CALL GEN021 (TM2, 1)
      CALL GEN021 (RMAT, 1)
      CALL GEN074 (PAR, 0.0, 1, NP13)
      CALL GEN097 (IPR, 1, NP12, 0)
      CALL GEN074 (PAR,  1.0, 101, 103)
      CALL GEN074 (PAR, 90.0, 104, 106)
      CALL GEN074 (SHFT, 0.0,   1,   3)
      PAR(98) = 1.0
      DO 100 I = 1, 20
        CCIF(I) = ' ?'
        NCIF(I) = 2
  100 CONTINUE
      NEWLAT(1) = 1
      CALL SGSM (IDM, 0, XJX, 0, 1, IERR)
      IPR(48)  = 1
      IPR(146) = 10
      IAN      = 0
      ICLR     = 4
      IPR(34) = 1
      IPR(35) = 2
      IPR(36) = 3
      IPR(28)  = 5
      IPR(40)  = 1
      IPR(41)  = 0
      IPR(45)  = 5
      IGBL(5)  = LU1
      IPR(65)  = 1
      IPR(66)  = 7
      IPR(82)  = 5
      IPR(68)  = 2
      IPR(95)  = 0
      IPR(96)  = NP6
      IPR(110) = 1
      IPR(119) = 1
      IPR(125) = 1
      IPR(129) = NP29
      IPR(142) = 25
      IPR(143) = 2
      IPR(144) = 3
      IPR(154) = 0
      IPR(159) = 6
      IGBL(75) = 1
      IPR(458) = 1
      IPR(163) = 4
      IPR(21)  = 7
      IPR(175) = 1
      IPR(176) = 1
      IPR(177) = 0
      IPR(178) = 0
      IPR(179) = 1
      IPR(180) = 4
      IPR(181) = 1
      IPR(183) = 6
      IPR(212) = 1
      IPR(214) = 6
      IPR(216) = 6
      IPR(217) = 6
      IPR(218) = 18
      IPR(219) = 24
      IPR(579) = IPR(219)
      IPR(211) = 0
      IPR(324) = 1
C * SET BEL SIGNAL (CTRL-G = ASCII 7)
      IPR(223) = 7
      IPR(331) = 1
      IPR(346) = 1
      IPR(366) = 25
      IPR(460) = 3
      IPR(551) = 3
      IPR(507) = 3
      IPR(467) = 3
      IPR(484) = -1
      IPR(222) = 100
      IPR(243) = 60
      IPR(260) = 1
      IPR(274) = 2
      IPR(300) = 1
      IPR(302) = 25
      IPR(350) = 0
      IPR(353) = 1
      IPR(354) = -1
      IPR(356) = -1
      IPR(355) = 0
      IPR(357) = 1
      IPR(358) = 1
      IPR(363) = 1
      IPR(368) = 0
      IPR(392) = 3
      IPR(394) = 3
      IPR(398) = 1
      IPR(419) = 5
      IPR(480) = 11
      IPR(482) = 4
      IPR(487) =  10
      IPR(492) = 6
      IPR(505) = 1
      IPR(514) = 9
      IPR(523) = 6
      IPR(524) = 3
      IPR(550) = 50
      IPR(567) = 25
      IPR(569) = 1
      IPR(577) = 5
      IPR(578) = 5
      IPR(582) = 250
      IF (IGBL(47) .GT. 0) THEN
        IPR(590) = 1
      ELSE
        IPR(590) = 0
      ENDIF
      PAR(2)   = 0.4
      PAR(3)   = 0.2
      PAR(5)   = 0.35
      PAR(6)   = 0.40
      PAR(7)   = 3.6
      PAR(8)   = 0.5
      PAR(9)   = -0.12
      PAR(10)  = 100.0
      PAR(11)  = 1.0
      PAR(12)  = 0.0001
      PAR(15)  = 160.0
      PAR(76)  = 1.5
      PAR(18)  = 0.01
      PAR(24)  = 1.0
      PAR(25)  = 0.4
      PAR(26)  = 0.70
      PAR(27)  = - PAR(2)
      PAR(28)  = 0.25
      PAR(31)  = 150.0
      PAR(33)  = 100.0
      PAR(30)  = 0.05
      PAR(32)  = 1.0
      PAR(34)  = 0.25
      PAR(36)  = 6.0
      PAR(37)  = GL(1)
      PAR(38)  = GL(1)
      PAR(39)  = 1.0
      PAR(40)  = 0.25
      PAR(41)  = 0.75
      PAR(42)  = 100.0
      PAR(43)  = 1.0
      PAR(44)  = 0.075
      PAR(48)  = 0.375
      PAR(49)  = 0.1
      PAR(50)  = (4.0 - IGBL(46)) / 3.0
      PAR(51)  = 1.25
      PAR(52)  = 0.5
      PAR(53)  = 0.2
      PAR(54)  = 1.E-5
      PAR(62)  = 60.0
      PAR(63)  = 0.002
      PAR(22)  = 0.3
      PAR(29)  = 1.0
      PAR(69)  = 4.0
      PAR(70)  = 0.3
      PAR(71)  = 0.05
      PAR(72)  = 0.25
      PAR(73)  = 0.1
      PAR(74)  = 1.0
      PAR(75)  = 0.8
      PAR(80)  = 0.2
C * ADDSYM ORGANIC PARAMETERS
      PAR(401) = 0.25
      PAR(402) = 0.45
      PAR(403) = 0.45
C * ADDSYM INORGANIC DEFAULTS
      PAR(404) = 0.25
      PAR(405) = 0.25
      PAR(406) = 0.25
      PAR(410) = 0.00000001
C * BEAM-STOP THETA-MIN
      PAR(419) = 2.5
C * NEWSYM/LAUE R_MAX
      PAR(429) = 5.0
C * SPGR/LAUE RMAX
      PAR(430) = 10.0
C * DELABS DIRECTION COSINE TEST PARAMETERS
      PAR(77)  = 0.03
      PAR(78)  = 0.5
      PAR(84)  = 1.20
      PAR(85)  = 4
      PAR(86)  = 0.03
      PAR(87)  = 2
      PAR(88)  = 0.02
      PAR(89)  = 5
      PAR(90)  = 0.05
      PAR(91)  = 2
      PAR(92)  = 0.02
      PAR(93)  = 0.001
      PAR(95)  = 5.0
      PAR(96)  = 10.0
      PAR(94)  = 10.0
      PAR(97)  = 25.0
      PAR(141) = 5.0
      PAR(165) = 90.0
      PAR(249) = 20.0
      PAR(250) = 0.2
      PAR(199) = -1.0
      PAR(251) = -0.25
      PAR(253) = -0.25
      PAR(213) = 0.5
      PAR(214) = 109.0
      PAR(215) = 20.0
      PAR(216) = 1.62
      PAR(217) = 0.2
      PAR(218) = 90.0
      PAR(219) = 20.0
      PAR(220) = 1.97
      PAR(221) = 0.4
      PAR(231) = 1.0
      PAR(235) = 1.0
      PAR(239) = 1.0
      PAR(240) = 1.0
      PAR(247) = 0.05
      PAR(248) = 0.6
      PAR(383) = 0.2
      PAR(263) = 3.0
      PAR(264) = 30.0
      PAR(265) = 0.1
      PAR(266) = 0.2
      PAR(286) = 0.15
      PAR(287) = 1.0 / 1.54184
      PAR(288) = 2.0
      PAR(268) = 0.5
      PAR(269) = 0.5
      PAR(270) = 0.2
      PAR(271) = 0.3
      PAR(273) = 10.0
      PAR(272) = PAR(273) * 4.0 / 3.0
      PAR(279) = 1.5
      PAR(280) = 0.1
      PAR(281) = 0.2
      PAR(282) = 1.0
      PAR(283) = 0.05
      PAR(284) = 1.E5
      PAR(285) = 0.0
      PAR(290) = 0.2
      PAR(292) = 500.0
      PAR(294) = 1.19
      PAR(295) = 1.50
      PAR(296) = 1.083
      PAR(297) = 1.009
      PAR(298) = 0.983
      PAR(325) = 1.0
      PAR(326) = 0.5E-15
      PAR(328) = 25.0
      PAR(331) = 0.015
      PAR(349)  = 0.25
      PAR(350) = 0.55
      PAR(371) = 0.1
      PAR(372) = 1.0
      PAR(381) = 1.0
      PAR(382) = 0.5
      PAR(384) = 1.45
      PAR(411) = 0.02
      PAR(412) = 100.0
      PAR(413) = 8.0
      PAR(414) = 0.10
      PAR(415) = 0.3
      PAR(416) = 0.01
      PAR(417) = 5.0
      PAR(418) = 0.0
      PAR(420) = 0.10
      PAR(422) = 3.5
      PAR(423) = 2.0
      PAR(424) = 1.5
      PAR(427) = 1.0
      PAR(431) = 5.0
      PAR(439) = 0.4
      PAR(440) = 1000.0
      PAR(441) = 0.4
      PAR(447) = 4.0
      PAR(448) = 30.0
      PAR(449) = 0.4
      PAR(450) = 5.0
      PAR(451) = 5.0
      PAR(452) = 0.25
      PAR(454) = 0.04
      DO 110 I = 262, 272
        IPR(I) = -999999
  110 CONTINUE
      IPR(267) = - IPR(267)
      IPR(269) = - IPR(269)
      IPR(271) = - IPR(271)
      IPR(310) = -999999
      PAR(17)  = -999999.0
      PAR(158) =  999999.0
      PAR(167) = -999999.0
      PAR(168) = -999999.0
      PAR(170) = -999999.0
      PAR(173) = -999999.0
      PAR(174) = -999999.0
      PAR(175) = -999999.0
      PAR(176) =  999999.0
      PAR(177) = -999999.0
      PAR(178) = -999999.0
      PAR(179) = -999999.0
      PAR(197) = -999999.0
      PAR(198) = -999999.0
      PAR(299) = -999999.0
      PAR(300) = -999999.0
      PAR(302) = -999999.0
      PAR(303) = -999999.0
      PAR(304) = -999999.0
      PAR(305) = -999999.0
      PAR(306) =  999999.0
      PAR(307) =  999999.0
      PAR(309) = -999999.0
      PAR(310) = -999999.0
      PAR(229) =  999999.0
      PAR(312) = -999999.0
      PAR(313) = -999999.0
      PAR(314) = -999999.0
      PAR(433) =  999999.0
      PAR(434) =  999999.0
      IGBL(1)  = 2
      RETURN
      END
      SUBROUTINE PLA002
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118,
     1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NPVD=40000000,
     2 NP22=256,NP23=18000,NP24=176,NP25=99,NP29=63,NP31=30,NP35=110,
     3 NP37=175,NP38=125,NP39=30,NP41=200,NP45=2048,NP47=9,NXT1=100,
     4 NXT2=200,NXT3=100,NXT4=200,NCS=50)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /Q/ ICL, IFL(NP17)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9),
     1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10),
     2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10),
     3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770)
      COMMON /GGT/  MEDIUM
      COMMON /P190/ NVRR, PMILL(NXT1, 5), XTLV(7, NXT2), IDG(NXT4, 4),
     1 XYZPL(3, NXT2), CFACE(5, NXT2), IEDGE(NXT3), NFACES, NEDGE, NVER
      COMMON /NAMES/ NAME(8), EXTENS, PROGNM, FNLU1, FNLU16, RDTYPE
      CHARACTER NAME*80, EXTENS*9, PROGNM*28, FNLU1*80, FNLU16*80,
     1          RDTYPE*7
      COMMON /DSPGR/ TYPE, NLAUE
      CHARACTER TYPE(NCS)*16, NLAUE(13)*5
      COMMON /CFSPGR/ EXT, ILAT0, ILAT1, LAUE
      CHARACTER EXT(NCS)*1, ILAT0*1, ILAT1*1, LAUE*5
      COMMON // JNSC(2, NP23), VOID(NPVD)
      CHARACTER N213*3, NI13*3, NI14*4
      COMMON /TIMER/ TIMT, TIMEZ, TIMEA, ISAVEMOD
      COMMON /FNAME/ KNM(8), KXT, KNM16
      COMMON /CGGT/ IGGT
      CHARACTER IGGT*80
      COMMON /CGG11/ BCD, SBCD
      CHARACTER BCD*132, SBCD*132
      CHARACTER ICH*1, EXTENS1*9
      COMMON /CHDAT/ CRD(NP37), LABP(16), COLR(NP10 + 1), BWCT(NP10 + 1)
      CHARACTER CRD*4, LABP*2, COLR*10, BWCT*10
      COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0
      COMMON /PAGENM/ PAGET, PAGEIND(25)
      CHARACTER PAGET*8, PAGEIND*8
      COMMON /LABMOD/ LMOD
      COMMON /STID/ ISETS(73, 230)
      COMMON /MEN/ MENA(25, NP31), MENS(25, NP31), MENU(50, NP31),
     1        MNH(NP35)
      DIMENSION SAV(16)
      J0 = 0
      J1 = 0
   10 IPR(205) = 0
      IF (IGBL(90) .NE. 0) THEN
        FN(1)    = IGBL(54)
        IGBL(90) = 0
        IPR(220) = 1
        IPR(221) = 1
        CALL PLA011
        IF (ICL(1:4) .EQ. 'END ') THEN
          GOTO 1090
        ELSE
          GOTO 10
        ENDIF
      ENDIF
      IF (IPR(121) .GT. 0) GOTO 820
      IPR(473) = 2
C * GET NEXT INPUT-LINE AND CARD TYPE (IN IS)
      CALL PLA006 (0, IS)
      IF (IPR(2) .NE. 0) GOTO 1250
C * IS = -1: E_O_F
   20 IF (IS .LT. 0) THEN
        GOTO 1080
C * IS = 0: FORMAT/READ - ERROR
      ELSE IF (IS .EQ. 0) THEN
        IPR(2) = 61
        GOTO 1120
C * IS = 1: POTENTIAL ATOM LINE
      ELSE IF (IS .EQ. 1) THEN
        IF (IGBL(5) .EQ. 5) GOTO 10
        IPR(473) = 1
        IF (IPR(30) .EQ. 0) GOTO 620
C * UNKNOWN CARD ERROR
        IPR(2) = 7
        GOTO 1120
C * IS = 2: TITL CARD
      ELSE IF (IS .EQ. 2) THEN
        I0  = 1
        I1  = 0
        CALL GEN039 (0, ICL, 5, 80, I0, I1)
        IF (I1 .GE. I0) THEN
          JID = ICL(I0:I1)
          IF (I1 - I0 + 1 .GT. 32) I1 = I0 + 31
          I2 = INDEX (ICL(I0:I1), ' ')
          IF (I2 .NE. 0) I1 = I0 + I2 - 2
          DATANM = ICL(I0:I1)
        ELSE
          DATANM = 'X'
        ENDIF
        CALL GEN020 (-1, DATANM, 1, 32)
        IF (IGBL(8) .EQ. 3) WRITE (LU20, 99957) DATANM
        WRITE (LU6, 99995) JID(1:39)
        IF (IGBL(100) .EQ. 0 .AND. IABS(IGBL(8)) .EQ. 3) THEN
          IPR(220) = 1
          IPR(221) = 0
          CALL PLA011
        ENDIF
        IF (IGBL(100) .GT. 0) THEN
          IGBL(54) = IGBL(54) + 1
        ELSE
          IGBL(54) = 1
        ENDIF
C * IS = 3: MESSAGE (ECHO)
      ELSE IF (IS .EQ. 3) THEN
        WRITE (LU6, 99988) ICL(5:80)
C * IS = 4: REMARK (SKIP)
      ELSE IF (IS .EQ. 4) THEN
C * IS = 5: ANGSTROM COORDINATE SCALE
      ELSE IF (IS .EQ. 5) THEN
        IF (IPR(221) .EQ. 1) THEN
          CALL PLA080
          PAR(11) = FN(1)
        ENDIF
C * IS = 6: ROUND ON/OFF OPTION
      ELSE IF (IS .EQ. 6) THEN
        IF (IPR(221) .EQ. 1) THEN
          IPR(68) = MAX (MIN (NINT(FN(1)), 10), 0)
        ELSE
          IPR(68) = 1
        ENDIF
        IF (IPR(220) .GT. 1) THEN
          IF (IFL(2)(1:3) .EQ. 'OFF') THEN
            IPR(68) = 0
          ENDIF
        ENDIF
        IF (IPR(68) .GT. 0) THEN
          CALL GEN040 (IPR(68), NQ1, IP)
          WRITE (LU6, 99990) IPR(68) * 10 - 1
        ENDIF
        GOTO 1070
C * IS = 7: FIT MOL1 ON MOL2 (OR INVERTED MOL2)
      ELSE IF (IS .EQ. 7) THEN
        IF (IGBL(45) .GT. 0 .AND. IGBL(5) .EQ. LU5) THEN
          IGBL(45) = IGBL(45) + 1
          WRITE (LU3, 99984) ICL(1:80)
          WRITE (LU6, 99973) ICL(1:70)
        ENDIF
        IF (IPR(220) .EQ. 1 .AND. IPR(221) .EQ. 0) THEN
          IPR(1)  = 7
          IPR(81) = -1
          GOTO 1190
        ELSE
          IF (IPR(30) .EQ. 0) THEN
            IF (IPR(221) .EQ. 2) THEN
              FN1      = FN(1)
              FN2      = FN(2)
              IPR(221) = 0
              CALL PLA069
              CALL PLA073 (-1)
              FN(1)    = FN1
              FN(2)    = FN2
              IPR(221) = 2
              IPR(220) = - IPR(220)
              GOTO 570
            ELSE IF (IPR(220) .EQ. 3) THEN
              IPR220   = IPR(220)
              IPR(220) = 1
              CALL PLA069
              CALL PLA073 (-1)
              IPR(220) = - IPR220
              GOTO 570
            ENDIF
            NTYP = 0
            GOTO 530
          ELSE
            IPR(220) = - IPR(220)
            GOTO 570
          ENDIF
        ENDIF
C * IS = 8: EXPLICIT PLANE SPECIFICATION
      ELSE IF (IS .EQ. 8) THEN
        NTYP = 4
        GOTO 530
C * IS = 9: EXPLICIT RING SPECIFICATION
      ELSE IF (IS .EQ. 9) THEN
        NTYP = 2
        GOTO 530
C * IS = 10: NOMOVE (OFF)
      ELSE IF (IS .EQ. 10) THEN
        IF (IPR(30) .EQ. 0) THEN
          IF (IPR(220) .GT. 1 .AND. IFL(2)(1:3) .EQ. 'OFF') THEN
            IGBL(30) = 0
          ELSE
            IGBL(30) = 1
          ENDIF
        ENDIF
C * IS = 11: PSIDIR
      ELSE IF (IS .EQ. 11) THEN
        IPR(78) = 5
        CALL PLA190
        IF (IPR(2) .EQ. 0) IPR(2) = -9
        GOTO 1250
C * IS = 12: DONOR/ACCEPTOR TYPES
      ELSE IF (IS .EQ. 12) THEN
        IPR(480) = 0
        DO 30 I = 1, IPR(220)
          CALL PLA037 (I, N, 2)
          IF (N .GT. 0) THEN
            IF (IPR(480) .LE. NP10) THEN
              IPR(480) = IPR(480) + 1
              IDOAC(IPR(480)) = IEN(N)
            ELSE
              WRITE (LU6, 99979) NP10
            ENDIF
          ENDIF
   30   CONTINUE
        GOTO 1070
C * IS = 13: SPECIAL LINE MANAGEMENT
      ELSE IF (IS .EQ. 13) THEN
        IF (IPR(30) .EQ. 0) THEN
          IF (IPR(220) .EQ. 3 .AND. IPR(407) .LT. 10) THEN
            DO 40 I = 2, 3
              CALL PLA046 (1, IFL(I), IENM, LBB, LBC, LBD,
     1                     XNQNR, YNQNR, NIEN)
              IF (NIEN .LT. 0) GOTO 10
              SLN(IPR(407) + 1, I - 1) = XNQNR
   40       CONTINUE
            IPR(407) = IPR(407) + 1
            WRITE (LU6, 99987)
          ENDIF
        ELSE
        ENDIF
C * IS = 14: ENDS
      ELSE IF (IS .EQ. 14) THEN
        IPR(3)  = 1
        IGBL(8) = - IABS(IGBL(8))
        IGBL(5) = LU3
        CALL GEN108 (LU3, 0)
C * IS = 15: PLOT
      ELSE IF (IS .EQ. 15) THEN
        GOTO 780
C * IS = 16: YES
      ELSE IF (IS .EQ. 16) THEN
        GOTO 1130
C * IS = 18: CALC
      ELSE IF (IS .EQ. 18) THEN
        GOTO 800
C * IS = 19: END
      ELSE IF (IS .EQ. 19) THEN
        GOTO 1090
C * IS = 20: INCLUDE NAMED ELEMENTS IN CALCULATIONS
      ELSE IF (IS .EQ. 20) THEN
        IPR(70) = 1
        GOTO 580
C * IS = 21: EXCLUDE NAMED ELEMENTS FROM CALCULATIONS
      ELSE IF (IS .EQ. 21) THEN
        IPR(70) = 0
        GOTO 580
C * IS = 22: STOP
      ELSE IF (IS .EQ. 22) THEN
        GOTO 1100
C * IS = 23: HELP (SPGR)
      ELSE IF (IS .EQ. 23) THEN
        IF (IPR(220) .GT. 1) THEN
          N213 = IFL(2)(1:3)
C * LIST KNOWN SPACE GROUP NAMES
          IF (N213 .EQ. 'SPG') THEN
            CALL SGSM (ICL, 0, XJX, LU6, 14, IERR)
            GOTO 10
          ENDIF
        ENDIF
        CALL PLA109 (1)
        GOTO 1240
C * IS = 24: SAVE INSTRUCTION OPTION ON
      ELSE IF (IS .EQ. 24) THEN
        IGBL(45) = 1
        ISAVEMOD = 1
        CALL GEN108 (LU3, 0)
C * IS = 25: UIJ
      ELSE IF (IS .EQ. 25) THEN
        GOTO 650
C * IS = 26: SUIJ
      ELSE IF (IS .EQ. 26) THEN
        GOTO 650
C * IS = 27: U
      ELSE IF (IS .EQ. 27) THEN
        GOTO 700
C * IS = 28: ATOM
      ELSE IF (IS .EQ. 28) THEN
        GOTO 620
C * IS = 29: LIST/INFO
      ELSE IF (IS .EQ. 29) THEN
C * LIST OPTION(S) ON DISPLAY (ATOMS/BONDS/SYMM/PAR/IPR/IGBL/RADII/CELL)
        IF (IGBL(8) .EQ. 2 .AND. IGBL(5) .NE. LU5) GOTO 10
        IPR(84) = 3
        IPR(1)  = 4
        IWIN    = IGBL(25) * IGBL(32)
        IF (IPR(220) .GT. 1) THEN
          N213 = IFL(2)(1:3)
C * LIST IPR/PAR/IGBL/GL
          IF (IPR(220) .GE. 2) THEN
            IF (N213 .EQ. 'IPR' .OR. N213 .EQ. 'PAR' .OR.
     1          N213 .EQ. 'IGB' .OR. N213 .EQ. 'GL ') THEN
              CALL PLA206 (-1, N213)
C * LIST FLAGS
            ELSE IF (N213 .EQ. 'FLA') THEN
              NAT = IPR(39) + IPR(64)
              WRITE (PRBUF, 99965)
              IF (IWIN .EQ. 1) THEN
                CALL GGIP (HORS, VERT, 0.0, 1)
                VRT = VERT - 0.6
                CALL GGIP20 (0.0, PRBUF, 80, 0.35, 5 + IGBL(68), 2,
     1                       1.0, VRT)
                VRT = VRT - 0.2
              ELSE
                WRITE (LU6, '(/, A, /)') PRBUF(1:80)
              ENDIF
              DO 50 I = 1, NAT
                CALL PLA047 (XLAB(I), NQ1, IDUM, JDUM, IPR(119),
     1                       IGBL(55), 0, 1 - IGBL(55))
                CALL GEN048 (-3,  IFG(I), 1,  IF1)
                CALL GEN048 (-1,  IFG(I), 4,  IF2)
                CALL GEN048 (-1,  IFG(I), 5,  IF3)
                CALL GEN048 (-1,  IFG(I), 6,  IF4)
                CALL GEN048 (-1,  IFG(I), 7,  IF5)
                CALL GEN048 (-1,  IFG(I), 8,  IF6)
                CALL GEN048 (-6,  IFG(I), 9,  IF7)
                CALL GEN048 (-4,  IFG(I), 15, IF8)
                CALL GEN048 (-1,  IFG(I), 19, IF9)
                CALL GEN048 (-1,  IFG(I), 20, IF10)
                CALL GEN048 (-1,  IFG(I), 21, IF11)
                CALL GEN048 (-1,  IFG(I), 22, IF12)
                CALL GEN048 (-1,  IFG(I), 23, IF13)
                CALL GEN048 (-4,  IFG(I), 24, IF14)
                CALL GEN048 (-1,  IFG(I), 30, IF15)
                CALL GEN048 (-7,  JFG(I),  1, IF16)
                CALL GEN048 (-1 , JFG(I), 10, IF17)
                CALL GEN048 (-1 , JFG(I), 11, IF18)
                CALL GEN048 (-1 , JFG(I), 12, IF19)
                CALL GEN048 (-10, JFG(I), 14, IF20)
                CALL GEN048 (-3,  JFG(I), 24, IF21)
                WRITE (PRBUF, 99966) I, NQ1, IF1, IF2, IF3, IF4, IF5,
     1            IF6, IF7, IF8, IF9, IF10, IF11, IF12, IF13, IF14,
     2            IF15, IF16, IF17, IF18, IF19, IF20, IF21
                IF (IWIN .EQ. 1) THEN
                  IF (VRT - 0.4 .LT. 0) THEN
                    CALL PLA013 (1, 1)
                    ICH = IGGT(1:1)
                    CALL GGIP (HORS, VERT, 0.0, 1)
                    IF (ICH .NE. 'Y' .AND. ICH .NE. '!') GOTO 10
                    VRT = VERT
                  ENDIF
                  VRT = VRT - 0.4
                  CALL GGIP20 (0.0, PRBUF, 80, 0.35, 1, 2, 1.0, VRT)
                ELSE
                  WRITE (LU6, '(A)') PRBUF(1:80)
                ENDIF
   50         CONTINUE
              IF (IWIN .EQ. 1) CALL PLA297 (1)
C * LIST/INFO SYMM
            ELSE IF (N213 .EQ. 'SYM') THEN
              CALL PLA299
C * LIST/INFO CELL
            ELSE IF (N213 .EQ. 'CEL') THEN
              WRITE (BCD, 99991) (PAR(J), J = 101, 106), CHAR(0)
              IF (IWIN .EQ. 1) THEN
                IF (ABS(IGBL(23)) .GE. 10 .AND. ABS(IGBL(23)) .LE. 12)
     1            IGBL(23) = - IABS(IGBL(23))
                CALL GGIP (-999.0, 5.0 + FLOAT(IGBL(68)), 66.0, 111)
              ELSE
                WRITE (LU6, 99946) BCD(1:65)
              ENDIF
C * LIST/INFO RADII
            ELSE IF (N213 .EQ. 'RAD') THEN
              WRITE (PRBUF, 99955)
              IF (IWIN .EQ. 1) THEN
                CALL GGIP (HORS, VERT, 0.0, 1)
                VRT = VERT - 2.0
                CALL GGIP20 (0.0, PRBUF, 75, 0.35, 1, 2, 1.0, VRT)
              ELSE
                WRITE (LU6, 99945) PRBUF(1:75)
              ENDIF
              WRITE (PRBUF, 99954)
              IF (IWIN .EQ. 1) THEN
                VRT = VRT - 0.6
                CALL GGIP20 (0.0, PRBUF, 75, 0.35, 1, 2, 1.0, VRT)
              ELSE
                WRITE (LU6, 99945) PRBUF(1:75)
              ENDIF
              WRITE (PRBUF, 99953) PAR(2)
              IF (IWIN .EQ. 1) THEN
                VRT = VRT - 0.9
                CALL GGIP20 (0.0, PRBUF, 75, 0.35, 1, 2, 1.0, VRT)
              ELSE
                WRITE (LU6, 99946) PRBUF(1:75)
              ENDIF
              WRITE (PRBUF, 99952) PAR(5)
              IF (IWIN .EQ. 1) THEN
                VRT = VRT - 0.6
                CALL GGIP20 (0.0, PRBUF, 75, 0.35, 1, 2, 1.0, VRT)
              ELSE
                WRITE (LU6, 99945) PRBUF(1:75)
              ENDIF
              WRITE (PRBUF, 99951) IGBL(97) * PAR(26)
              IF (IWIN .EQ. 1) THEN
                VRT = VRT - 0.6
                CALL GGIP20 (0.0, PRBUF, 75, 0.35, 1, 2, 1.0, VRT)
              ELSE
                WRITE (LU6, 99945) PRBUF(1:75)
              ENDIF
              WRITE (PRBUF, 99950) PAR(3)
              IF (IWIN .EQ. 1) THEN
                VRT = VRT - 0.6
                CALL GGIP20 (0.0, PRBUF, 75, 0.35, 1, 2, 1.0, VRT)
              ELSE
                WRITE (LU6, 99945) PRBUF(1:75)
              ENDIF
              WRITE (PRBUF, 99949)
              IF (IWIN .EQ. 1) THEN
                VRT = VRT - 0.9
                CALL GGIP20 (0.0, PRBUF, 75, 0.35, 5 + IGBL(68), 2,
     1                       1.0, VRT)
              ELSE
                WRITE (LU6, 99946) PRBUF(1:75)
              ENDIF
              DO 60 I = 1, IAN
                WRITE (PRBUF, 99996) LMT(I, 1), RADR(I, 3), RADR(I, 4),
     1                               RADR(I, 2)
                IF (IWIN .EQ. 1) THEN
                  VRT = VRT - 0.6
                  CALL GGIP20 (0.0, PRBUF, 75, 0.35, 1, 2, 1.0, VRT)
                ELSE
                  WRITE (LU6, 99945) PRBUF(1:75)
                ENDIF
   60         CONTINUE
              IF (IWIN .EQ. 1) CALL PLA297 (1)
C * LIST/INFO U1, U2, U3, U(eq) and U3/U1 VALUES
            ELSE IF (N213 .EQ. 'UIJ') THEN
              IF (IPR(30) .NE. 0) THEN
                WRITE (PRBUF, 99980)
                IF (IWIN .EQ. 1) THEN
                  CALL GGIP (HORS, VERT, 0.0, 1)
                  VRT = VERT - 0.6
                  CALL GGIP20 (0.0, PRBUF, 75, 0.35, 5 + IGBL(68), 2,
     1                         1.0, VRT)
                  VRT = VRT - 0.2
                ELSE
                  WRITE (LU6, 99984) PRBUF(1:75)
                ENDIF
                NAT = IPR(39)
                DO 90 I = 1, NAT
                  DO 70 J = 1, 12
                    FN(J) = VOID(IPR(297) + (I - 1) * 21 + J)
   70             CONTINUE
                  CALL PLA047 (XLAB(I), NQ1, IDUM, JDUM, IPR(119),
     1                         IGBL(55), 0, 0)
                  CALL GEN048 (-1, IFG(I), 4, IVAL)
                  IF (IVAL .EQ. 1) THEN
                    JMAX  = 5
                    FN(4) = 0.0
                    DO 80 J = 1, 3
                      FN(J) = FN(J + 9)**2
                      FN(4) = FN(4) + FN(J) / 3.0
   80               CONTINUE
                    FN(5) = FN(3) / FN(1)
                  ELSE
                    CALL GEN048 (-1, IFG(I), 7, IVAL)
                    IF (IVAL .EQ. 1) GOTO 90
                    JMAX  = 1
                    FN(1) = FN(10)**2
                  ENDIF
                  WRITE (PRBUF, 99981) NQ1, (FN(J), J = 1, JMAX)
                  IF (IWIN .EQ. 1) THEN
                    IF (VRT - 0.4 .LT. 0.0) THEN
                      CALL PLA013 (1, 1)
                      ICH = IGGT(1:1)
                      CALL GGIP (HORS, VERT, 0.0, 1)
                      IF (ICH .NE. 'Y' .AND. ICH .NE. '!') GOTO 10
                      VRT = VERT
                    ENDIF
                    VRT = VRT - 0.4
                    CALL GGIP20 (0.0, PRBUF, 80, 0.35, 1, 2, 1.0, VRT)
                  ELSE
                    WRITE (LU6, 99984) PRBUF(1:80)
                  ENDIF
   90           CONTINUE
                IF (IWIN .EQ. 1) CALL PLA297 (1)
              ENDIF
C * LIST ARU
            ELSE IF (N213 .EQ. 'ARU') THEN
              CALL PLA043 (0, -2, LU6, 1)
              IF (IWIN .EQ. 1) CALL PLA297 (1)
C * LIST/INFO ATOMS AND BONDS
            ELSE IF (IPR(39) .GT. 0) THEN
              IF (N213 .EQ. 'ATO') IPR(84) = 1
              IF (N213 .EQ. 'BON') IPR(84) = 2
              GOTO 760
            ELSE
              WRITE (LU6, 99992)
            ENDIF
            GOTO 10
          ENDIF
        ENDIF
        GOTO 760
C * IS = 30: CELL CONSTANTS
      ELSE IF (IS .EQ. 30) THEN
        IF (IPR(221) .EQ. 1) THEN
          FN(2)    = FN(1)
          FN(3)    = FN(1)
          IPR(221) = 3
        ENDIF
        IF (IPR(221) .EQ. 3) THEN
          CALL GEN074 (FN, 90.0, 4, 6)
          IPR(221) = 6
        ENDIF
        IF (IPR(221) .LT. 6 .OR.
     1    (IPR(221) .GT. 7 .AND. IPR(221) .NE. 12)) GOTO 1060
        IF (IPR(221) .EQ. 7) THEN
          PAR(16) = FN(1)
          PAR(17) = FN(1)
          K = 1
        ELSE
          K = 0
        ENDIF
        DO 100 I = 1, 12
          IF (I .LE. 3 .AND. ABS(FN(K + I)) .LT. 2.0) THEN
            IF (IGBL(5) .EQ. LU1) THEN
              IPR(470) = 1
            ENDIF
            GOTO 1060
          ENDIF
          PAR(100 + I) = FN(K + I)
  100   CONTINUE
        IF (K .EQ. 0) GOTO 10
        CALL PLA293 (FN(1), 0)
C * IS = 31: CELL STANDARD DEVIATION
      ELSE IF (IS .EQ. 31) THEN
        DO 110 I = 1, 6
          PAR(106 + I) = FN(I)
  110   CONTINUE
C * IS = 32: SYMM (LATT/SPGR/HALL etc.)
      ELSE IF (IS .EQ. 32) THEN
        IF (IPR(220) .EQ. 1 .AND.
     1     (IPR(221) .EQ. 9 .OR. IPR(221) .EQ. 12)) THEN
C * SYMM MATRIX R11,R12,..,R33, (T1,T2,T3) INPUT
          IF (IPR(93) .EQ. 0) THEN
            ITRS = 15
            CALL SGSM (ICL, 0,  FN, LU6, ITRS, IERR)
            CALL SGSM (ICL, 0, XJS, LU6,   18, IERR)
            IPR(48) = NINT(XJS(9))
            IF (IGBL(8) .EQ. 3) THEN
              IF (CCIF(7)(1:1) .EQ. ' ' .AND. CCIF(16)(1:1) .EQ. '?')
     1           THEN
                WRITE (LU20, 99947) '_121', 1.0, 1.0, ICL(1:7)
                ICL = 'SPGR P1'
                WRITE (LU6, 99958)
                IS = 32
                GOTO 20
              ENDIF
            ENDIF
          ELSE
C * NO TRANS ALLOWED WITH SYMM MATRIX INPUT
            IPR(2) = 27
            GOTO 1120
          ENDIF
        ELSE
          IF (IGBL(8) .EQ. 2) THEN
            IF (IPR(141) .EQ. 0 .AND. IFL(1)(1:4) .EQ. 'SYMM') THEN
              IDM = 'LATT 1'
              CALL SGSM (IDM, 0, XJX, 0, 0, IERR)
              IPR(141) = 1
            ENDIF
          ENDIF
          IF (IPR(93) .EQ. 1 .OR. IPR(139) .EQ. 1) THEN
            ITRS = 16
          ELSE
            ITRS = 0
          ENDIF
          CALL SGSM (ICL, 0, XJX, LU6, ITRS, IERR)
          IF (IERR .NE. 0) THEN
            IF (IERR .EQ. 7) THEN
              WRITE (LU20, 99947) '_126', 1.0, 1.0,
     1                       ICL(6:12), ICL(13:19)
              GOTO 10
            ELSE IF (IERR .EQ. 5) THEN
              CALL GEN047 (ICL, 6, 16)
              WRITE (LU20, 99947) '_129', 1.0, 1.0, ICL(6:12)
              GOTO 10
            ELSE IF (IERR .EQ. 12) THEN
              GOTO 10
            ELSE
              IPR(470) = 1
              GOTO 1060
            ENDIF
          ENDIF
          CALL SGSM (ICL, 0, XJS, LU6,   18, IERR)
          IPR(48) = NINT(XJS(9))
          IF (IPR(48) .EQ. 0) THEN
            IF (IGBL(8) .EQ. 3)
     1        WRITE (LU20, 99947) '_121', 1.0, 1.0, ICL(1:7)
          ENDIF
        ENDIF
        IPR(141) = 1
        IF (IPR(48) .EQ. 0 .AND. IGBL(8) .NE. 4) THEN
          IF (IGBL(5) .EQ. LU1) THEN
            IPR(470) = 1
          ENDIF
          GOTO 1060
        ENDIF
        IF (IPR(39) .EQ. 0) THEN
          CALL SGSM (ICL, 0, XJS, LU6, 18, IERR)
          SPGRNM(1) = ICL(1:26)
          SPGRNM(3) = ICL(44:60)
          SPGRNM(4) = ICL(15:26)
          IF (ICL(73:73) .NE. ' ') ZSPG = ICL(73:79)
          KRSYST    = ICL(27:38)
          LAUEGR    = ICL(39:43)
          CHSG      = ICL(72:72)
          CALL GEN020 (-1, SPGRNM(1), 16, 24)
          IPR(202) = NINT(XJS(1))
          IPR(241) = NINT(XJS(7))
          IPR(242) = NINT(XJS(8))
          IPR(255) = NINT(XJS(4))
          IPR(256) = NINT(XJS(6))
          IPR(257) = NINT(XJS(5))
          IPR(258) = NINT(XJS(3))
          IPR(259) = NINT(XJS(2))
          IF (IGBL(8) .EQ. 3) THEN
            IF (CCIF(7)(1:1) .EQ. ' ') THEN
              CCIF(7) = SPGRNM(4)(1:11)
            ELSE
              CCIF(8) = SPGRNM(4)(1:11)
            ENDIF
          ENDIF
        ENDIF
C * IS = 33: SPGR
      ELSE IF (IS .EQ. 33) THEN
        IF (IPR(220) .EQ. 1 .AND. IPR(221) .LE. 2) THEN
          IF (IGBL(15) .GE. 0) THEN
            IF (IPR(221) .GT. 0) IPR(365) = NINT(FN(1))
            IF (IPR(221) .GT. 1) PAR(141) = FN(2)
            CALL PLA080
            IGBL(31) = 5
            CALL PLA021
            CALL PLA042 (0)
            CALL PLA160 (1, TM1)
            GOTO 1250
          ELSE
            IPR(2) = 55
            GOTO 1120
          ENDIF
        ENDIF
        IS = 32
        GOTO 20
C * IS = 34: LATT
      ELSE IF (IS .EQ. 34) THEN
        IS = 32
        GOTO 20
C * IS = 35: DIST
      ELSE IF (IS .EQ. 35) THEN
        GOTO 570
C * IS = 36: ANGLE
      ELSE IF (IS .EQ. 36) THEN
        GOTO 570
C * IS = 37: TORSION
      ELSE IF (IS .EQ. 37) THEN
        GOTO 570
C * IS = 38: CHANGE H-BOND PARAMETERS FROM DEFAULTS
      ELSE IF (IS .EQ. 38) THEN
        IF (IPR(220) .GT. 1 .AND. IFL(2)(1:4) .EQ. 'NORM') IPR(87) = 1
        DO 120 K = 1, IPR(221)
          PAR(7 + K) = FN(K)
  120   CONTINUE
        GOTO 1070
C * IS = 39: BIJ
      ELSE IF (IS .EQ. 39) THEN
        GOTO 630
C * IS = 40: SBIJ
      ELSE IF (IS .EQ. 40) THEN
        GOTO 630
C * IS = 41: B
      ELSE IF (IS .EQ. 41) THEN
        GOTO 690
C * IS = 42: TRNS/TRMX
      ELSE IF (IS .EQ. 42) THEN
        CALL GEN074 (SHFT, 0.0, 1, 3)
        IF (IPR(221) .EQ. 1) THEN
          IF (ABS(FN(1)) .GT. 1000.0) THEN
            ITRNS = INT (FN(1))
          ELSE
            ITRNS = NINT(FN(1) * 1000.0)
          ENDIF
          IF (IABS(ITRNS) / 1000 .GT. IPR(48)) THEN
            IPR(2) = 15
            GOTO 1120
          ENDIF
          IF (ITRNS .LE. 0) THEN
            IPR(95)  = ITRNS
          ELSE IF (ITRNS .GT. 0) THEN
            IPR(165) = ITRNS
          ENDIF
          GOTO 10
        ELSE IF (IPR(221) .EQ. 3) THEN
          CALL GEN074 (FN, 0.0, 1, 9)
          FN(1)    = 1.0
          FN(5)    = 1.0
          FN(9)    = 1.0
          IPR(139) = 1
          DO 130 I = 1, 3
            SHFT(I) = - FN(I)
  130     CONTINUE
        ELSE IF (IPR(221) .EQ. 9) THEN
        ELSE IF (IPR(221) .EQ. 10 .AND. IPR(220) .EQ. 2) THEN
          ILAT0 = IFL(2)(1:1)
          IF (IFL(2)(2:2) .NE. ' ') ILAT1 = IFL(2)(2:2)
          CALL GEN020 (-1, ILAT0, 1, 1)
          IFN10 = NINT(FN(10))
          IF (IFN10 .GT. 0 .AND. IFN10 .LT. 14) THEN
            LAUE = NLAUE(NINT(FN(10)))
          ELSE
            LAUE = ' '
          ENDIF
        ELSE IF (IPR(221) .EQ. 12) THEN
          IPR(139) = 1
          DO 140 I = 1, 3
            SHFT(I) = - FN(9 + I)
  140     CONTINUE
        ELSE
          IPR(2) = 63
          GOTO 1120
        ENDIF
        IF (IPR(39) .GT. 0) THEN
C * INSTRUCTION NOT ALLOWED
          IPR(2) = 11
          GOTO 1120
        ENDIF
        K = 0
        DO 160 I = 1, 3
          XJX(9 + I) = - SHFT(I)
          DO 150 J = 1, 3
            K = K + 1
            TM1(I, J) = FN(K)
            XJX(K)    = FN(K)
            PAR(230 + K) = FN(K)
  150     CONTINUE
  160   CONTINUE
        CALL GEN003 (TM1, DUMV, DET, 0)
        IF (ABS(ABS(DET) - 1.0) .GT. 0.001) THEN
          WRITE (LU6, 99985) DET
          PAR(32) = DET
        ENDIF
        CALL GEN005 (DUMV, TM2)
        IPR(93) = 1
        WRITE (LU6, 99972)
     1    ((TM2(I, J), J = 1, 3), -SHFT(I), I = 1, 3)
C * IS = 43: FVAR CARD (SHELX)
      ELSE IF (IS .EQ. 43) THEN
        IGBL(8) = 2
        IF (IPR(109) + IPR(221) .GT. NP25) THEN
          IPR(2) = 30
          GOTO 1120
        ENDIF
        DO 170 I = 1, IPR(221)
          IF (IPR(109) + I .EQ. 1) THEN
            RP(1) = FN(1)
          ELSE
            RP(IPR(109) + I) = MOD(FN(I) + 5.0, 10.0) - 5.0
          ENDIF
  170   CONTINUE
        IF (IPR(109) .EQ. 0) THEN
          PAR(74) = RP(1)
          RP(1)   = 1.0
        ENDIF
        IPR(109) = IPR(109) + IPR(221)
C * IS = 44: PARENTHESES ON/OFF OPTION
      ELSE IF (IS .EQ. 44) THEN
        IPR(119) = 1
        IF (IPR(220) .GT. 1) THEN
          IF (IFL(2)(2:2) .EQ. 'F') IPR(119) = 0
        ENDIF
        GOTO 1070
C * IS = 45: QUIT
      ELSE IF (IS .EQ. 45) THEN
        GOTO 1100
C * IS = 46: SET OPTION(S)
      ELSE IF (IS .EQ. 46) THEN
C * SET - OPTION(S)
        N213 = IFL(2)(1:3)
C * (RE)SET VAN DER WAALS RADII
        IF (N213 .EQ. 'VDW') THEN
          IF (IPR(220) .GT. 2 .AND. IPR(221) .EQ. IPR(220) - 2) THEN
            DO 180 I = 3, IPR(220)
              CALL PLA037 (I, NID, 2)
              IF (NID .GT. 0) RADR(NID, 4) = FN(I - 2)
  180       CONTINUE
          ENDIF
          IF (IGBL(5) .EQ. LU5) CALL PLA280 ('LIST RADII')
C * SET RANGE (FOR POLY)
        ELSE IF (N213 .EQ. 'RAN') THEN
          IF (IPR(221) .EQ. 6) THEN
            IPR(354) = 0
            DO 190 I = 1, 6
              PAR(200 + I) = FN(I)
  190       CONTINUE
C * SET OMIT RANGE (POLY)
        ELSE IF (N213 .EQ. 'OMI') THEN
          ELSE IF (IPR(221) .EQ. 6) THEN
            IPR(356) = 0
            DO 195 I = 1, 6
              PAR(206 + I) = FN(I)
  195       CONTINUE
          ENDIF
C * SET TETR (POLY)
        ELSE IF (N213 .EQ. 'TET') THEN
          DO 200 I = 1, 4
            IF (FN(I) .NE. 0.0) PAR(213 + I) = FN(I)
  200     CONTINUE
C * SET OCTA (POLY)
        ELSE IF (N213 .EQ. 'OCT') THEN
          DO 210 I = 1, 4
            IF (FN(I) .NE. 0.0) PAR(217 + I) = FN(I)
  210     CONTINUE
C * SET LABEL SIZE
        ELSE IF (N213 .EQ. 'LAB') THEN
          IF (IPR(220) .EQ. 3 .AND. IFL(3)(1:1) .EQ. 'S') THEN
            WRITE (LU6, 99994) PAR(349)
            IF (IPR(221) .EQ. 1) THEN
              PAR(349) = FN(1)
              WRITE (LU6, 99993) PAR(349)
            ENDIF
          ENDIF
C * SET PRINTER LEVEL (0,1,2,3,4)
        ELSE IF (N213 .EQ. 'PRI') THEN
          IF (IPR(220) .EQ. 3) THEN
            IF (IFL(3)(1 : 1) .EQ. 'L') THEN
              IF (IPR(221) .GT. 0) THEN
                IGBL(64) = NINT(FN(1))
                IGBL(63) = IGBL(64)
              ENDIF
            ENDIF
          ENDIF
C * SET REVERSE
        ELSE IF (N213 .EQ. 'REV') THEN
          IGBL(68) = MOD (IGBL(68) + 1, 2)
          CALL GGIP (-999.0, FLOAT(IGBL(68)), IGBL(62) * 0.25, 9)
C * SET IPR/PAR/IGBL/GL
        ELSE IF (IPR(221) .EQ. 2 .AND. IPR(220) .EQ. 2) THEN
          CALL PLA206 (1, N213)
C * SET PROBABILITY (10 <--> 90 PERCENT)
        ELSE IF (IPR(221) .EQ. 1 .AND. IPR(220) .EQ. 2) THEN
          IF (N213 .EQ. 'PRO') THEN
            IPR(45)  = MAX (1, MIN (9, NINT(FN(1) / 10)))
            IPR(201) = 0
C * SET WINDOW FRACTION
          ELSE IF (N213 .EQ. 'WIN') THEN
            CALL GGIP (-999.0, FLOAT(IGBL(68)), FN(1) * 1000.0, 9)
            IGBL(62) = MIN (MAX (1, NINT(FN(1) / 0.25)), 4)
          ENDIF
        ELSE IF (IPR(220) .EQ. 3) THEN
C * SET BEEP ON/OFF
          IF (N213 .EQ. 'BEE') THEN
            MEDIUM = 0
C * SET DISPLAY TYPE
          ELSE IF (N213 .EQ. 'DIS') THEN
            MEDIUM = 1
C * SET META TYPE
          ELSE IF (N213 .EQ. 'MET') THEN
            MEDIUM = 2
          ENDIF
          IF (IPR(220) .GT. 2) CALL GGIP (-999.0, 0.0, 0.0, 6)
        ENDIF
        GOTO 1070
C * IS = 47: AFIX CARD (SHELX)
      ELSE IF (IS .EQ. 47) THEN
        IGBL(8) = 2
C * IS = 48: SFAC CARD (SHELX) OR IS = 172: SCAT
      ELSE IF (IS .EQ. 48 .OR. IS .EQ. 172) THEN
        IF (IS .EQ. 48) IGBL(8) = 2
        IF (IPR(141) .EQ. 0 .AND. IGBL(8) .EQ. 2) THEN
          IDM = 'LATT 1'
          CALL SGSM (IDM, 0, XJX, 0, 0, IERR)
          IPR(141) = 1
        ENDIF
        N = IPR(220)
        M = IPR(221)
        IF (N .GT. 1) THEN
          DO 240 I = 2, N
            N12 = 0
            CALL GEN105 (1, IFL(I)(1:1), N)
            IF (N .GT. 0) N12 = (N - ICHAR('A') + 1) * 100
            CALL GEN105 (1, IFL(I)(2:2), N)
            IF (N .GT. 0) N12 = N12 + N - ICHAR('A') + 1
            IF (N12 .EQ. 815) IPR(435) = 1
            DO 220 J = 1, NP9
              IF (IEL(J) .EQ. N12) GOTO 230
  220       CONTINUE
            IPR(2) = 41
            GOTO 1120
  230       IAN          = IAN + 1
            IEN(IAN)     = J
            RADR(IAN, 3) = REL(J)
            RADR(IAN, 4) = ABS(VDWR(J))
            IF (IFL(I)(2:2) .EQ. ' ') THEN
              LMT(IAN, 1) = ' '//IFL(I)(1:1)
            ELSE
              LMT(IAN, 1) = IFL(I)(1:2)
              CALL GEN020 (-1, LMT(IAN, 1), 2, 2)
            ENDIF
            LMT(IAN, 2) = JTP(IABS(IATPR(J)))
            IF (J .EQ. 3) THEN
              IACL(IAN) = 2
            ELSE IF (J .EQ. 4) THEN
              IACL(IAN) = 4
            ELSE IF (IATPR(J) .EQ. -7) THEN
              IACL(IAN) = 3
            ELSE IF (J .GT. 2) THEN
              IF (ICLR .LT. 8) ICLR = ICLR + 1
              IACL(IAN) = ICLR
            ENDIF
  240     CONTINUE
          IF (N .EQ. 2 .AND. M .GT. 0 .AND. FN(1) .EQ. 0.0)
     1        IPR(493) = 5
        ENDIF
C * IS = 49: UNIT CARD (SHELX)
      ELSE IF (IS .EQ. 49) THEN
        IGBL(8) = 2
        DO 250 I = 1, IPR(221)
          CONT(I, 3) = FN(I) * PAR(32)
  250   CONTINUE
C * IS = 50: WGHT CARD (SHELX)
      ELSE IF (IS .EQ. 50) THEN
        IGBL(8)  = 2
        PAR(227) = FN(1)
        PAR(228) = FN(2)
C * IS = 51: VIEW CARD(S)
      ELSE IF (IS .EQ. 51) THEN
C * VIEW MIN
        IF (IFL(2)(1:3) .EQ. 'MIN') THEN
          IPR(201) = 0
          IGBL(67) = 0
        ELSE
C * VIEW (XR xr YR yr ZR zr)
          N = 1
          IF (IPR(220) .EQ. 1) THEN
            CALL PLA226 (0, 0.0)
          ELSE
            CALL GEN021 (RMAT, IGBL(87))
            DO 260 L = 1, 3
              CALL GEN051 (0, RMAT, - GL(27 + L) / GL(5), L)
  260       CONTINUE
            DO 270 I = 2, IPR(220)
              NI13 = IFL(I)(1:3)
              IF (NI13 .EQ. 'UNI') THEN
                CALL PLA226 (0, 0.0)
              ELSE IF (NI13 .EQ. 'INV') THEN
                CALL PLA226 (-4, 0.0)
              ELSE IF (NI13(1:2) .EQ. 'XR') THEN
                CALL PLA226 (-1, - FN(N) / GL(5))
                N = N + 1
              ELSE IF (NI13(1:2) .EQ. 'YR') THEN
                CALL PLA226 (-2, - FN(N) / GL(5))
                N = N + 1
              ELSE IF (NI13(1:2) .EQ. 'ZR') THEN
                CALL PLA226 (-3, - FN(N) / GL(5))
                N = N + 1
              ENDIF
  270       CONTINUE
          ENDIF
        ENDIF
        GOTO 1070
C * IS = 52: BOX ON/OFF (1/0)
      ELSE IF (IS .EQ. 52) THEN
        IF (IPR(220) .GT. 1) THEN
          DO 280 I = 2, IPR(220)
            N213 = IFL(I)(1:3)
C * BOX OFF
            IF (N213 .EQ. 'OFF') THEN
              IGBL(103) = 0
C * BOX ON
            ELSE IF (N213 .EQ. 'ON ') THEN
              IGBL(103) = 1
C * BOX RATIO
            ELSE IF (N213 .EQ. 'RAT') THEN
              PAR(50) = FN(1)
            ENDIF
  280     CONTINUE
        ENDIF
        GOTO 1070
C * IS = 53: EXIT
      ELSE IF (IS .EQ. 53) THEN
        GOTO 1100
C * IS = 54: BOND CARD (SHELX)
      ELSE IF (IS .EQ. 54) THEN
        IGBL(8) = 2
C * IS = 55: ZERR (SHELXTL/SHELXL)
      ELSE IF (IS .EQ. 55) THEN
        DO 290 I = 2, 7
          PAR(105 + I) = FN(I)
  290   CONTINUE
        IGBL(8) = 2
C * IS = 56: GEOM
      ELSE IF (IS .EQ. 56) THEN
        GOTO 570
C * IS = 57: L.S. CARD (SHELX)
      ELSE IF (IS .EQ. 57) THEN
        IGBL(8) = 2
C * IS = 58: FMAP CARD (SHELX)
      ELSE IF (IS .EQ. 58) THEN
        IGBL(8) = 2
C * IS = 59: INFO
      ELSE IF (IS .EQ. 59) THEN
        IS = 29
        GOTO 20
C * IS = 60: TABLE OPTION
      ELSE IF (IS .EQ. 60) THEN
        IF (IPR(30) .NE. 0) THEN
          IPR(2) = 31
          GOTO 1120
        ENDIF
        IPR(430) = 1
        IF (IPR(72) .EQ. 0) WRITE (LU6, 99962)
        IPR(454) = 1
        IPR(240) = 1
        IPR(119) = 0
        IF (IPR(220) .GT. 1) THEN
          DO 300 I = 2, IPR(220)
            NI13 = IFL(I)(1:3)
C * NO-HATOM
            IF (NI13 .EQ. 'NHA') THEN
              IPR(454) = 0
C * RESIDUE SORT/LISTING (NORES)
            ELSE IF (NI13 .EQ. 'NOR') THEN
              IPR(240) = 0
            ELSE IF (NI13 .EQ. 'SU ') THEN
C * SU  (FULL SUPPLEMENTARY MATERIAL)
              IPR(431) = 0
            ELSE IF (NI13 .EQ. 'AC ') THEN
C * AC  (ACTA CRYST)
              IPR(430) = 2
              IPR(431) = 1
            ELSE IF (NI13 .EQ. 'ACC' .OR. NI13 .EQ. 'CIF'
     1                               .OR. NI13 .EQ. 'CSD') THEN
C * ACC (ACTA CRYST C - CIF) - NOPARENTHESES
              IF (EXTENS(1:3) .EQ. 'acc') THEN
                WRITE (LU6, 99997)
                GOTO 10
              ENDIF
              IPR(430) =  1
              IF (NI13 .EQ. 'CSD') THEN
                IPR(431) = -2
                IGBL(31) = 9
                CALL PLA021
              ELSE
                IPR(431) = -1
                IGBL(31) = 8
                CALL PLA021
              ENDIF
            ELSE IF (NI13 .EQ. 'JA ') THEN
C * JA  (JACS)
              IPR(430) = 2
              IPR(431) = 2
            ELSE IF (NI13 .EQ. 'IC ') THEN
C * IC  (INORG CHEM)
              IPR(430) = 2
              IPR(431) = 3
C * LOCAL
            ELSE IF (NI13 .EQ. 'LOC') THEN
              IPR(399) = 1
            ENDIF
  300     CONTINUE
        ENDIF
        IF (IPR(30) .EQ. 0) THEN
          IPR(220)  = 2
          IFL(2)    = 'OMEGA'
          GOTO 800
        ELSE
C * EXECUTE TABLE OPTIONS
          IF (IPR(430) .GT. 0) THEN
            IGBL(92) = MAX (IGBL(92), IPR(430))
            IGBL(93) = MAX (IGBL(93), IPR(431))
            IPR(31)  = -1
            IPR(17)  = -1
            IPR(90)  =  1
            IGBL(63) =  0
            CALL PLA069
            CALL PLA172
            IPR(1)  = 1
            IF (IPR(2) .EQ. 0) IPR(2) = -1
            GOTO 1250
          ENDIF
          GOTO 1200
        ENDIF
C * IS = 61: RADII BONDS ((LIST/NORMAL/TO H/TO MET/ALL) (#lines (radius))
      ELSE IF (IS .EQ. 61) THEN
        DO 310 I = 2, IPR(220)
          J1   = 0
          NI13 = IFL(I)(1:3)
C * RADII BONDS TO H
          IF (NI13 .EQ. 'H  ') THEN
            J0 = 3
            J1 = 3
C * RADII BONDS TO METAL
          ELSE IF (NI13 .EQ. 'MET') THEN
            J0 = 5
            J1 = 5
C * NORMAL
          ELSE IF (NI13 .EQ. 'NOR') THEN
            J0 = 1
            J1 = 1
          ELSE IF (NI13 .EQ. 'ALL') THEN
            J0 = 1
            J1 = 5
          ELSE
            GOTO 310
          ENDIF
          GOTO 320
  310   CONTINUE
  320   IF (J1 .GT. 0) THEN
          DO 330 J = J0, J1, 2
            IF (IPR(221) .GT. 0) THEN
              IF (ABS(FN(1)) .GT. 5.0) FN(1) = SIGN(5.0, FN(1))
              PAR(84 + J) = FN(1)
            ENDIF
            IF (IPR(221) .GT. 1) PAR(85 + J) = FN(2)
  330     CONTINUE
        ENDIF
        WRITE (PRBUF, 99977)
        IF (IWIN .EQ. 1) THEN
          CALL GGIP (HORS, VERT, 0.0, 1)
          VRT = VERT - 3.0
          CALL GGIP20 (0.0, PRBUF, 75, 0.35, 5 + IGBL(68), 2, 1.0, VRT)
        ELSE
          WRITE (LU6, '(/, '':: '', A, /)') PRBUF(1:75)
        ENDIF
        WRITE (PRBUF, 99976)
     1    NINT(PAR(85)), 2**NINT(ABS(PAR(85)) - 1) + 1, PAR(86)
        IF (IWIN .EQ. 1) THEN
          VRT = VRT - 1.5
          CALL GGIP20 (0.0, PRBUF, 75, 0.35, 1, 2, 1.0, VRT)
        ELSE
          WRITE (LU6, '(/, '':: '', A, /)') PRBUF(1:75)
        ENDIF
        WRITE (PRBUF, 99975)
     1    NINT(PAR(87)), 2**NINT(ABS(PAR(87)) - 1) + 1, PAR(88)
        IF (IWIN .EQ. 1) THEN
          VRT = VRT - 1.5
          CALL GGIP20 (0.0, PRBUF, 75, 0.35, 1, 2, 1.0, VRT)
        ELSE
          WRITE (LU6, 99945) PRBUF(1:75)
        ENDIF
        IF (IPR(155) .GT. 0) THEN
          WRITE (PRBUF, 99974)
     1      NINT(PAR(89)), 2**NINT(ABS(PAR(89)) - 1) + 1, PAR(90)
          IF (IWIN .EQ. 1) THEN
            VRT = VRT - 1.5
            CALL GGIP20 (0.0, PRBUF, 75, 0.35, 1, 2, 1.0, VRT)
          ELSE
            WRITE (LU6, 99945) PRBUF(1:75)
          ENDIF
        ENDIF
        IF (IWIN .EQ. 1) CALL PLA297 (1)
        GOTO 1070
C * IS = 62: BLOC CARD (SHELX)
      ELSE IF (IS .EQ. 62) THEN
        IGBL(8) = 2
C * IS = 63: MENU (ON/OFF)
      ELSE IF (IS .EQ. 63) THEN
        IF (IPR(220) .EQ. 2 .AND. IFL(2)(1:3) .EQ. 'OFF') THEN
          IGBL(25)    = 0
        ELSE
          IGBL(25) = 1
          IF (IGBL(23) .LT. 10 .OR. IGBL(23) .GT. 12)
     1      CALL PLA280 ('PLOT')
        ENDIF
C * IS = 64: OMIT CARD
      ELSE IF (IS .EQ. 64) THEN
        N = IPR(220)
        IF (N .GT. 1) THEN
          IF (IPR(30) .EQ. 0) THEN
            IF (IPR(37) .EQ. 0) THEN
              IPR(2) = 42
              GOTO 1120
            ENDIF
            IGBL(52) = MAX (IGBL(52), IPR(23))
            CALL PLA287 (0, 1, 0)
          ENDIF
          DO 340 I = 2, N
            CALL PLA046 (2, IFL(I), IENM, LBB, LBC, LBD,
     1                      XNQNR, YNQNR, NR)
            IF (NR .GT. 0) THEN
              CALL GEN048 (1, IFG(NR), 30, 1)
            ELSE
              CALL PLA015 (0, 28)
            ENDIF
  340     CONTINUE
        ELSE
          IF (IPR(221) .EQ. 2) THEN
            PAR(165) = FN(2) / 2.0
            IGBL(8)  = 2
          ENDIF
        ENDIF
C * IS = 65: GRID CARD (SHELX)
      ELSE IF (IS .EQ. 65) THEN
        IGBL(8) = 2
C * IS = 66: DFIX CARD (SHELX)
      ELSE IF (IS .EQ. 66) THEN
        IGBL(8) = 2
C * IS = 67: JOIN ATOMS
      ELSE IF (IS .EQ. 67) THEN
        MODE = 2
        GOTO 1050
C * IS = 68: DETACH ATOMS
      ELSE IF (IS .EQ. 68) THEN
        MODE = -2
        GOTO 1050
C * IS = 69: DEFINE SUBSTITUTE BOND
      ELSE IF (IS .EQ. 69) THEN
        MODE = -2
        GOTO 1050
C * IS = 70: HKLF - LINE
      ELSE IF (IS .EQ. 70) THEN
        CALL PLA080
        IF (IPR(221) .GE. 11) THEN
          DO 350 K = 1, 9
            I = ((K - 1) / 3)  + 1
            J = MOD (K - 1, 3) + 1
            DUMV(I, J) = FN(K + 2)
  350     CONTINUE
        ELSE
          CALL GEN021 (DUMV, 1)
        ENDIF
        CALL GEN004 (TM1, DUMV, DUMV)
        K = 0
        DO 370 I = 1, 3
          DO 360 J = 1, 3
            K = K + 1
            PAR(230 + K) = DUMV(I, J)
  360     CONTINUE
  370   CONTINUE
        WRITE (LU6, 99960) (PAR(230 + I), I = 1, 9)
        CALL GEN003 (DUMV, QQ, DET, 0)
        PAR(240) = DET
        IF (ABS(ABS(DET) - 1.0) .GT. 0.001) WRITE (LU6, 99944) DET
        IF (DET .LT. 0.0) THEN
          IPR(2) = 40
          GOTO 1120
        ENDIF
        CALL GEN001 (1, QQ, AA, RAA)
        CALL GEN026 (-1, RAA, PAR(241), GL(5))
        CALL GEN003 (RAA, RBB, DET, 0)
        IF (DET .LE. 0.0) STOP 'CANNOT INVERT METRICAL MATRIX'
        CALL GEN026 (-1, RBB, PAR(135), GL(5))
        WRITE (LU6, 99959) (PAR(100 + I), I = 1, 6),
     1                     (PAR(240 + I), I = 1, 6)
        CALL GEN025 (RBB, PAR(391), 1)
C * IS = 71: RADN LINE
      ELSE IF (IS .EQ. 71) THEN
        CALL PLA293 (FN(1), 0)
C * IS = 72: TRMX
      ELSE IF (IS .EQ. 72) THEN
        IS = 42
        GOTO 20
C * IS = 73: PART - SHELXL STYLE
      ELSE IF (IS .EQ. 73) THEN
C * IS = 74: INORG (FORCE INORGANIC MODE)
      ELSE IF (IS .EQ. 74) THEN
        IGBL(97) = 0
C * IS = 75: ORGA (FORCE ORGANIC MODE)
      ELSE IF (IS .EQ. 75) THEN
        IGBL(97) = 1
C * IS = 78: ENTRY (CSD-FDAT-FILE ENTRY)
      ELSE IF (IS .EQ. 78) THEN
        CALL PLA011
        IF (ICL(1:4) .EQ. 'END ') GOTO 1090
C * IS = 79: ELLIPSOID PARAMETERS
      ELSE IF (IS .EQ. 79) THEN
        IF (IPR(220) .GT. 1) THEN
          N213 = IFL(2)(1:3)
          IF (N213 .EQ. 'C  ') THEN
            N = 175
          ELSE IF (N213 .EQ. 'H  ') THEN
            N = 177
          ELSE IF (N213 .EQ. 'OTH') THEN
            N = 179
          ENDIF
          IF (IPR(221) .GT. 1) THEN
            IPR(N)     = MAX (0, MIN (1, NINT(ABS(FN(1)))))
            IPR(N + 1) = NINT(ABS(FN(2)))
          ENDIF
        ENDIF
        WRITE (LU6, 99964) (IPR(174 + I), I = 1, 6)
C * IS = 80: ORMA - CAD4 ORIENTATION MATRIX (Reciprocal Axes)
      ELSE IF (IS .EQ. 80) THEN
        IF (IPR(221) .EQ. 9) THEN
          DO 380 I = 1, 9
            PAR(180 + I) = FN(I)
            J = MOD (I - 1, 3) + 1
            K = ((I - 1) / 3)  + 1
            DAM(J, K)    = FN(I)
  380     CONTINUE
          CALL GEN003 (DAM, DUMV, DET, 0)
          IF (DET .LE. 0.0) STOP 'CANNOT INVERT ORMA'
          WRITE (LU6, 99963) 1.0 / DET
          IPR(16) = 1
        ELSE
         GOTO 1060
        ENDIF
C * IS = 81: EXTI CARD (SHELXL)
      ELSE IF (IS .EQ. 81) THEN
        PAR(229) = FN(1)
C * IS = 82: SETUP (EXOR.BIN)
      ELSE IF (IS .EQ. 82) THEN
        CALL PLA150 (0)
        GOTO 1130
C * IS = 83: EXOR
      ELSE IF (IS .EQ. 83) THEN
        CALL PLA150 (1)
        GOTO 1130
C * IS = 84: ABSG(AUSS)
      ELSE IF (IS .EQ. 84) THEN
        PAR(162) = FN(1)
        IF (IPR(221) .EQ. 4) THEN
          IPR(421) = NINT(FN(2))
          IPR(422) = NINT(FN(3))
          IPR(423) = NINT(FN(4))
        ENDIF
        IF (IGBL(37) .EQ. 0) THEN
          IPR(2)  = 56
          GOTO 1250
        ENDIF
        PAGET   = 'ABSGAUSS'
        IPR(78) = 2
        GOTO 730
C * IS = 85: FACE CARD
      ELSE IF (IS .EQ. 85) THEN
        IF (FN(4) .LE. 0) THEN
          IPR(2) = 34
          GOTO 1130
        ENDIF
        IF (IPR(367) .GT. 0) THEN
          DO 400 I = 1, IPR(367)
            DO 390 J = 1, 3
              IF (ABS(PMILL(I, J) - FN(J)) .GT. 0.001) GOTO 400
  390       CONTINUE
            GOTO 410
  400     CONTINUE
        ENDIF
        IPR(367) = IPR(367) + 1
        NFACES   = IPR(367)
  410   DO 420 J = 1, 4
          PMILL(IPR(367), J) = FN(J)
  420   CONTINUE
        PMILL(IPR(367), 5) = FN(4)
C * IS = 86: ABST (de MEULENAER-TOMPA)
      ELSE IF (IS .EQ. 86) THEN
        PAR(162) = FN(1)
        IF (IGBL(37) .EQ. 0) THEN
          IPR(2)  = 56
          GOTO 1250
        ENDIF
        PAGET   = 'ABSTOMPA'
        IPR(78) = 3
        GOTO 730
C * IS = 87: ABSXTAL
      ELSE IF (IS .EQ. 87) THEN
        PAR(162) = FN(1)
        IPR(78)  = 1
        GOTO 730
C * IS = 88: LEPAGE METRICAL SYMMETRY ANALYSIS
      ELSE IF (IS .EQ. 88) THEN
        IGBL(23) = 20
        IPR(2)   = -1
        IPR(94)  = 2
        IF (FN(1) .NE. 0.0) PAR(441) = FN(1)
        IF (FN(2) .NE. 0.0) IPR(94)  = MAX (2, MIN (10, NINT(FN(2))))
        IF (FN(3) .NE. 0.0) PAR(439) = FN(3)
        CALL PLA080
        CALL SGSM (ICL, 0, XJX, LU7, 18, IERR)
        CALL PLA164 (0, 0, ICL(13:13), TM1, PAR(439))
        CALL GEN038 (ICL, 1, 80)
        GOTO 1240
C * IS = 89: ASYM
      ELSE IF (IS .EQ. 89) THEN
        CALL PLA140
        IF (IPR(2) .EQ. 0) IPR(2) = -14
        GOTO 1250
C * IS = 90: ABSPSI
      ELSE IF (IS .EQ. 90) THEN
        IF (IGBL(37) .EQ. 0) THEN
          IPR(2)  = 56
          GOTO 1250
        ENDIF
        PAGET   = 'ABSPSI'
        IPR(78) = 4
        GOTO 730
C * IS = 91: ABSSPHERE
      ELSE IF (IS .EQ. 91) THEN
        IPR(78) = -1
        GOTO 730
C * IS = 92: CONTOUR-PLOTS
      ELSE IF (IS .EQ. 92) THEN
        CALL PLA250
        IF (IPR(2) .NE. 0) GOTO 1250
        IF (IGGT(1:4) .EQ. 'EXIT') GOTO 1250
        IF (IGBL(3) .GE. 19 .AND. IGBL(3) .LE. 22) THEN
          GOTO 1250
        ELSE
          CALL PLA280 ('RESTART')
        ENDIF
C * IS = 93: RESTART
      ELSE IF (IS .EQ. 93) THEN
        CALL GEN108 (LU1, 0)
        CALL GEN108 (LU2, 0)
        CALL GEN108 (LU20, 0)
        IF (IABS(IGBL(8)) .EQ. 3) IGBL(8) = 3
        WRITE (LU6, 99961)
        GOTO 1230
C * IS = 94: VALIDATION CHECK MODE (FOR ACTA CRYST ETC)
      ELSE IF (IS .EQ. 94) THEN
        IF (IGBL(30) .EQ. 1) THEN
          IPR(119) = 0
          IGBL(36) = 1
          LINE = NAME(1)(1:KNM(1))//'.chk'
          IF (IGBL(10) .EQ. 0) THEN
            OPEN (UNIT = LU10, FILE = LINE, STATUS = 'UNKNOWN')
            IGBL(10) = 1
          ENDIF
          WRITE (LU6,
     1     '(/, '' >> CIF-Validation-Check Result on '', A)') LINE
          IGBL(64) = 0
          IGBL(63) = IGBL(64)
          GOTO 800
        ELSE
          CALL PLA015 (0, 47)
          IGBL(3) = 0
          GOTO 10
        ENDIF
C * IS = 95: EXPT - CALCULATE EXPECTED NUMBER OF REFLECTIONS
      ELSE IF (IS .EQ. 95) THEN
        CALL PLA086 (LU6)
        CALL PLA086 (LU7)
        GOTO 1250
C * IS = 96: PLUTON
      ELSE IF (IS .EQ. 96) THEN
        GOTO 770
C * IS = 99: TWIN
      ELSE IF (IS .EQ. 99) THEN
        DO 430 I = 1, 9
          PAR(331 + I) = FN(I)
  430   CONTINUE
        IF (IPR(221) .EQ. 0) THEN
          PAR(332) = -1.0
          PAR(336) = -1.0
          PAR(340) = -1.0
        ENDIF
        IPR(193) = IPR(193) + 1
C * IS = 103: RESI
      ELSE IF (IS .EQ. 103) THEN
        IPR(538) = NINT(FN(1))
C * IS = 112: CRYSTAL SIZE
      ELSE IF (IS .EQ. 112) THEN
        IF (IPR(221) .EQ. 3) THEN
          CALL GEN034 (FN, 1, 3)
          DO 440 I = 1, 3
            PAR(301 + I) = FN(I)
  440     CONTINUE
        ENDIF
C * IS = 132: TEMP (SHELX ==> DEG. C) ([C]/K)
      ELSE IF (IS .EQ. 132) THEN
        IF (IFL(2)(1:1) .EQ. 'K') THEN
          IPR(261) = NINT(FN(1))
        ELSE
          IPR(261) = NINT(FN(1)) + 273
        ENDIF
        IPR(310) = IPR(261)
C * IS = 142: BASF
      ELSE IF (IS .EQ. 142) THEN
        IF (IPR(221) .GT. 0) THEN
          DO 450 I = 1, IPR(221)
            BASF(I) = FN(I)
  450     CONTINUE
          IPR(513) = IPR(221)
          PAR(341) = FN(1)
          IPR(193) = IPR(193) + 1
        ENDIF
C * IS = 146: HALL
      ELSE IF (IS .EQ. 146) THEN
        IS = 32
        GOTO 20
C * IS = 148: MULABS
      ELSE IF (IS .EQ. 148) THEN
        IF (IPR(220) .GT. 1) THEN
          DO 460 I = 2, IPR(220)
            IF (IFL(I)(1:5) .EQ. 'LIST')    IGBL(57) = 1
            IF (IFL(I)(1:7) .EQ. 'NOCHECK') IPR(363) = 0
  460     CONTINUE
        ENDIF
        IF (IGBL(37) .EQ. 0) THEN
          IPR(2)  = 56
          GOTO 1250
        ENDIF
        IPR(78) = -2
        CALL PLA080
        CALL PLA042 (1)
        PAGET = 'MULABS'
        CALL PLA187
        IF (IPR(2) .EQ. 0) IPR(2) = -4
        GOTO 1250
C * IS = 149: HKLF-TRANS
      ELSE IF (IS .EQ. 149) THEN
        CALL PLA042 (1)
        CALL PLA201
        IF (IPR(2) .EQ. 0) IPR(2) = -15
        GOTO 1250
C * IS = 150: XTAL-HABIT PLOT
      ELSE IF (IS .EQ. 150) THEN
        IPR(78) = 0
        CALL PLA190
        GOTO 1260
C * IS = 151: HINCLUDE (ORTEP)
      ELSE IF (IS .EQ. 151) THEN
        DO 470 I = 2, IPR(220)
          CALL PLA046 (3, IFL(I), IENM, LBB, LBC, LBD,
     1                    XNQNR, YNQNR, N1)
          CALL GEN048 (1, JFG(N1), 12, 1)
  470   CONTINUE
        GOTO 1070
C * IS = 152: HEXCLUDE (ORTEP)
      ELSE IF (IS .EQ. 152) THEN
        DO 480 I = 2, IPR(220)
          CALL PLA046 (3, IFL(I), IENM, LBB, LBC, LBD,
     1                    XNQNR, YNQNR, N1)
          CALL GEN048 (1, JFG(N1), 12, 0)
  480   CONTINUE
        GOTO 1070
C * IS = 153: FILE
      ELSE IF (IS .EQ. 153) THEN
        CALL PLA004 (1)
        GOTO 1210
C * IS = 154: RENAME (RES)
      ELSE IF (IS .EQ. 154) THEN
        IF (IABS(IGBL(8)) .EQ. 2) THEN
          IGBL(3)   = 12
          IGBL(105) = 1
          GOTO 770
        ENDIF
C * IS = 155: SYSTEM S
      ELSE IF (IS .EQ. 155) THEN
        IGBL(3) = 14
        CLOSE (LU1)
        CLOSE (LU2)
        CLOSE (LU3)
        CLOSE (LU4)
        CLOSE (LU8)
        CLOSE (LU9)
        CLOSE (LU16)
        CALL S
        GOTO 1260
C * IS = 156: DELAUNEY REDUCTION
      ELSE IF (IS .EQ. 156) THEN
        IF (IPR(221) .GT. 0) THEN
          PAR(382) = FN(1)
          IF (IPR(221) .EQ. 2) PAR(381) = FN(2)
        ENDIF
        CALL PLA080
        CALL SGSM (ICL, 0, XJX, LU7, 18, IERR)
        CALL PLA178 (ICL(13:13), LU7)
        GOTO 1240
C * IS = 157: EXPAND TO P1
      ELSE IF (IS .EQ. 157) THEN
        CALL PLA208
        GOTO 1250
C * IS = 158: ARU
      ELSE IF (IS .EQ. 158) THEN
        CALL PLA295
C * IS = 159: ANALYSIS OF VARIANCE
      ELSE IF (IS .EQ. 159) THEN
        CALL PLA119 (0)
        GOTO 1250
C * IS = 160: FCF2HKL
      ELSE IF (IS .EQ. 160) THEN
        CALL PLA292 (LU6, LU16, LU17, IGBL(29), IPR(384))
        IF (IPR(2) .EQ. 0) IPR(2) = -16
        GOTO 1260
C * IS = 161: PORTRAIT
      ELSE IF (IS .EQ. 161) THEN
        IGBL(46) = MOD(IGBL(46) + 1, 2)
        PAR(50) = (4.0 - IGBL(46)) / 3.0
        NN = 4 - IGBL(46) * 8
        CALL GGIP (-999.0, 0.0, 0.0, NN)
C * IS = 162: SIMULATED POWDER-PATTERN
      ELSE IF (IS .EQ. 162) THEN
        CALL PLA144
        GOTO 1240
C * IS = 163: FSUM
      ELSE IF (IS .EQ. 163) THEN
C * IS = 164: SCAL
      ELSE IF (IS .EQ. 164) THEN
        IS = 1
        GOTO 20
C * IS = 165
      ELSE IF (IS .EQ. 165) THEN
        IS = 1
        GOTO 20
C * IS = 166: ROTMAT
      ELSE IF (IS .EQ. 166) THEN
        CALL PLA119 (1)
        GOTO 1250
C * IS = 167: CAVITY
      ELSE IF (IS .EQ. 167) THEN
        CALL PLA207
        CALL PLA280 ('RESTART')
C * IS = 168: SHXABS
      ELSE IF (IS .EQ. 168) THEN
        CALL PLA183
        GOTO 1250
C * IS = 169: DELETE ATOM (ORTEP/SOLV)
      ELSE IF (IS .EQ. 169) THEN
        N = IPR(220)
        IF (N .GT. 1) THEN
          DO 490 I = 2, N
            CALL PLA046 (2, IFL(I), IENM, LBB, LBC, LBD,
     1                     XNQNR, YNQNR, NR)
            IF (NR .GT. 0) THEN
              CALL GEN048 (1, JFG(NR), 27, 1)
            ELSE
              CALL PLA015 (0, 28)
            ENDIF
  490     CONTINUE
        ENDIF
C * IS = 170: COLOR TYPE INSTRUCTION
      ELSE IF (IS .EQ. 170) THEN
        N = IPR(220)
        IF (MOD (N, 2) .EQ. 0 .AND. N .GE. 4) THEN
          DO 520 I = 3, N, 2
            NQ1 = IFL(I)(1:2)
            NQ2 = IFL(I + 1)(1:3)
            IF (NQ1(2:2) .EQ. ' ') THEN
              NQ1 = ' '//IFL(I)(1:1)
            ELSE
              CALL GEN020 (-1, NQ1, 2, 2)
            ENDIF
            DO 510 J = 1, IAN
              IF (NQ1(1:2) .EQ. LMT(J, 1)) THEN
                DO 500 K = 1, NP10 + 1
                  IF (NQ2(1:3) .EQ. COLR(K)(1:3)) THEN
                    IACL(J) = K
                    GOTO 520
                  ENDIF
  500           CONTINUE
              ENDIF
  510       CONTINUE
  520     CONTINUE
        ENDIF
C * IS = 171: RESET
      ELSE IF (IS .EQ. 171) THEN
        CALL PLA281 (0)
        GOTO 1090
C * IS = 173: STIDY (Structure Tidy - Parthe & Gelato)
      ELSE IF (IS .EQ. 173) THEN
        IGBL(30) = 1
        NAT      = IPR(37)
        EXTENS1  = EXTENS
        EXTENS   = 'sty'
        KXT      = 3
        CALL PLA069
        OPEN (UNIT = LU64, FILE = NAME(1)(1:KNM(1))//'.'//EXTENS(1:KXT),
     1        STATUS = 'UNKNOWN')
        WRITE (LU64, 99971) SPGRNM(4)(1:16), JID(1:40)
        WRITE (LU64, 99970) (PAR(I), I = 101, 106)
        IF (IPR(202) .NE. 0) THEN
          IW = ISETS (1, IPR(202))
          IF (IW .LT. 0 .OR. IW .EQ. 15) WRITE (LU64, 99941)
        ENDIF
        DO 525 I = 1, NAT
          CALL GEN048 (-7, JFG(I), 1, IPOP)
          IDIS = IPPR (IPOP + 1, 1)
          CALL PLA047 (XLAB(I), NQ1, IDUM, JDUM, 0, 0, 0, 0)
          IF (IDIS .LT. 1000) THEN
            WRITE (LU64, 99969) NQ1, (XXO(I, J), J = 1, 3),
     1                          IDIS / 1000.0
          ELSE
            WRITE (LU64, 99969) NQ1, (XXO(I, J), J = 1, 3)
          ENDIF
  525   CONTINUE
        WRITE (LU64, 99968)
        CLOSE (LU64)
        CALL PLA301
        WRITE (LU6, 99967) NAME(1)(1:KNM(1))//'.'//EXTENS(1:KXT)
        EXTENS = EXTENS1
        IF (IPR(2) .EQ. 0) IPR(2) = -1
        GOTO 1250
C * BIJVOET PAIR ANALYSIS
      ELSE IF (IS .EQ. 174) THEN
        CALL PLA119 (-1)
        GOTO 1250
      ENDIF
C * CATCH OTHERS
      GOTO 10
C * TEST FOR TOO MANY SPECIFIED ATOMS
  530 IF (IPR(220) .GT. NP1 + 1) THEN
        IPR(2) = 8
        GOTO 1120
      ENDIF
      IF (IPR(30) .EQ. 0) THEN
        IF (IPR(145) .LT. NP2) THEN
          IPR(145)         = IPR(145) + 1
          XLS(1, IPR(145)) = NTYP
          DO 540 K = 2, 9
            XLS(K, IPR(145)) = -1
  540     CONTINUE
          IPR(146) = 1
          DO 560 I = 2, IPR(220)
            CALL PLA046 (1, IFL(I), IENM, LBB, LBC, LBD,
     1                   XNQNR, YNQNR, NIEN)
            IF (NIEN .LT. 0) THEN
              IF (IFL(I)(1:3) .EQ. 'DIS') THEN
                IPR(220) = - IPR(220)
                GOTO 570
              ELSE IF (IFL(I)(1:4) .EQ. 'WITH') THEN
                IPR(220) = - IPR(220)
                GOTO 570
              ELSE
                NQ1 = IFL(I)
                GOTO 1110
              ENDIF
            ENDIF
            IPR(146) = IPR(146) + 1
            IF (IPR(146) .GT. 9) THEN
              IPR(145) = IPR(145) + 1
              IPR(146) = 2
              DO 550 K = 1, 9
                XLS(K, IPR(145)) = -1
  550         CONTINUE
            ENDIF
            XLS(IPR(146), IPR(145)) = XNQNR
  560     CONTINUE
          WRITE (LU6, 99987)
        ENDIF
        GOTO 10
      ENDIF
      IPR(220) = - IPR(220)
C * SINGLE DISTANCE, ANGLE OR TORSION ANGLE CALCULATION (+GEOM)
  570 IF (IPR(220) .EQ. 1 .OR. IPR(220) .GT. 5) GOTO 1060
      IPR(1)  = 7
      IPR(81) = IPR(220)
      GOTO 760
C * INCLUDE/EXCLUDE NAMED ELEMENTS FROM CALCULATIONS
  580 IF (IPR(30) .EQ. 1) THEN
C * INSTRUCTION NOT ALLOWED
        IPR(2) = 11
        GOTO 1120
      ELSE
        IPR(4) = 0
        I = 1
  590   I = I + 1
        IF (I .GT. IPR(220)) GOTO 1070
        IF (IFL(I)(1:3) .EQ. 'MET') THEN
          DO 600 J = 1, IAN
            IF (IATPR(IEN(J)) .GT. 0) THEN
              IPR(220)           = IPR(220) + 1
              N                  = IEL(IEN(J))
              N1                 = N / 100
              IFL(IPR(220))(1:3) = CHAR(ICHAR('A') - 1 + N1)//'  '
              N1                 = MOD(N, 100)
              IF (N1 .GT. 0) THEN
                IFL(IPR(220))(2:2) = CHAR(ICHAR('A') - 1 + N1)
              ENDIF
            ENDIF
  600     CONTINUE
          GOTO 590
        ENDIF
        CALL PLA037 (I, N, 2)
        IF (N .GT. 0) THEN
          IF (IPR(4) .LE. NP10) THEN
            IPR(4) = IPR(4) + 1
C * SCRATCH USE OF ARRAY RADI FOR INCLUDE OPTION
            RADR(IPR(4), 2) = N
          ELSE
            WRITE (LU6, 99978) NP10
          ENDIF
        ELSE
          IPR(2) = 16
          IPR(4)  = 0
          IAN     = IAN - 1
          GOTO 1120
        ENDIF
        GOTO 590
      ENDIF
  610 IPR(471) = IPR(471) + 1
      IF (IGBL(5) .NE. LU5) GOTO 10
C * UNKNOWN CARD ERROR
      IPR(2) = 7
      GOTO 1120
C * ATOMIC COORDS IN FREE-FORMAT INPUT
  620 IF (IPR(220) .LT. IPR(473) .OR. IPR(221) .LT. 3) GOTO 610
      IF (IGBL(8) .EQ. 2 .AND. IGBL(95) .EQ. 1) THEN
        IF (IFL(1)(1:1) .EQ. 'Q' .AND. FN(7) .LT. GL(26)) GOTO 10
      ENDIF
      CALL PLA079 (XNQNR)
C * CHECK FOR ERROR RETURN
      IF (IPR(2) .EQ. 0) THEN
        GOTO 10
      ELSE
        GOTO 1120
      ENDIF
C * BIJ & SBIJ DATA
C * (BETA-VALUES ARE TRANSFORMED TO U-VALUES AFTER TRANSFORMATION)
  630 DO 640 I = 1, 6
        FN(I) = FN(I) / GL(7)
  640 CONTINUE
      IF (IS .EQ. 40) GOTO 670
      GOTO 660
C * UIJ DATA & SUIJ DATA
  650 FN(1) = FN(1) * PAR(135)**2
      FN(2) = FN(2) * PAR(136)**2
      FN(3) = FN(3) * PAR(137)**2
      FN(4) = FN(4) * PAR(136) * PAR(137)
      FN(5) = FN(5) * PAR(135) * PAR(137)
      FN(6) = FN(6) * PAR(135) * PAR(136)
      IF (IS .EQ. 26) GOTO 670
  660 IF (IGBL(8) .EQ. 3) THEN
        IF (IFL(2)(1:1) .EQ. '?') GOTO 10
        IF (IPR(221) .NE. 12 .OR.
     1      (FN(2) .EQ. 0.0 .AND. FN(3) .EQ. 0.0 .AND. FN(4) .EQ. 0
     2      .AND. FN(5) .EQ. 0 .AND. FN(6) .EQ. 0)) THEN
          IF (IGBL(3) .EQ. 1) THEN
            WRITE (LU20, 99942) '_217', 1.0, 1.0, IFL(2)
          ELSE
            IPR(2) = 50
            GOTO 1120
          ENDIF
        ENDIF
      ENDIF
      CALL GEN025 (DUMV, FN, -1)
      CALL GEN001 (1, TM2, DUMV, UIJ)
      CALL GEN025 (UIJ, FN, 1)
      ICT     = 2
      IPR(32) = 2
      GOTO 680
C * SUIJ DATA
  670 ICT = 3
  680 FN(1) = FN(1) / PAR(113)**2
      FN(2) = FN(2) / PAR(114)**2
      FN(3) = FN(3) / PAR(115)**2
      FN(4) = FN(4) / (PAR(114) * PAR(115))
      FN(5) = FN(5) / (PAR(113) * PAR(115))
      FN(6) = FN(6) / (PAR(113) * PAR(114))
      GOTO 710
C * B DATA (SHOULD INCLUDE ATOM LABEL)
  690 IF (IPR(220) .EQ. 1) THEN
        IS = 1
        GOTO 20
      ENDIF
      FN(1) = FN(1) / GL(8)
      FN(2) = FN(2) / GL(8)
C * U DATA (SHOULD INCLUDE ATOM LABEL)
  700 IF (IPR(220) .EQ. 1) THEN
        IS = 1
        GOTO 20
      ENDIF
      ICT = 4
  710 IF (IPR(30) .EQ. 1 .OR. IPR(107) .EQ. 1) GOTO 610
      NQ2 = IFL(2)
      IF (IGBL(8) .EQ. 1) THEN
        IF (NQ4 .NE. NQ2) THEN
C * LABEL INCONSISTENT
          IPR(2) = 4
          GOTO 1120
        ENDIF
        XNQNR2 = XNQNR
      ELSE
        MODE = 0
        CALL PLA046 (-2, NQ2, IENM, LBB, LBC, LBD,
     1                   XNQNR2, YNQNR2, IDUM2)
      ENDIF
      IPR(32) = MAX (IPR(32), 1)
      WRITE (LU4) ICT, XNQNR2, (FN(K), K = 1, 8)
      IF (IGBL(8) .EQ. 3) THEN
        IF (IS .EQ. 25) THEN
          IS = 26
          DO 720 I = 1, 6
            FN(I) = FN(I + 6)
  720     CONTINUE
          GOTO 650
        ENDIF
      ENDIF
      GOTO 10
  730 IF (IPR(220) .GT. 1) THEN
        DO 740 I = 2, IPR(220)
          IF (IFL(I)(1:5) .EQ. 'LIST')    IGBL(57) = 1
          IF (IFL(I)(1:7) .EQ. 'NOCHECK') IPR(363) = 0
  740   CONTINUE
      ENDIF
      CALL PLA190
      IF (IPR(2) .EQ. 0) THEN
        IF (IPR(78) .EQ. -1) THEN
          IPR(2) = -5
        ELSE IF (IPR(78) .EQ. 1) THEN
          IPR(2) = -1
        ELSE IF (IPR(78) .EQ. 2) THEN
          IPR(2) = -8
        ELSE IF (IPR(78) .EQ. 3) THEN
          IPR(2) = -7
        ELSE IF (IPR(78) .EQ. 4) THEN
          IPR(2) = -6
        ENDIF
      ENDIF
      GOTO 1250
C * ASYM (IUCR-CHECK)
  750 IF (IABS(IGBL(8)) .EQ. 3 .AND. IGBL(94) .EQ. 0) THEN
       IF (IPR(493) .EQ. 0)
     1      WRITE (LU20, 99943) '_092', PAR(17), PAR(17)
        IPR(121) = IPR(121) - 1
        IFL(1)   = 'ASYM'
        IFL(2)   = 'EXPECT'
        IPR(220) = 2
        IF (PAR(168) .GT. 0.0)
     1      PAR(287) = SIN (PAR(168) / GL(5)) / PAR(17)
      ELSE
        IPR(121) = IPR(121) - 2
        GOTO 1090
      ENDIF
      CALL PLA140
      IPR(559) = IPR(377)
      IPR(560) = IPR(379)
      IPR(561) = IPR(305)
      IPR(562) = IPR(306)
      IPR(563) = IPR(307)
      IF ((IGBL(29) .GT. 0 .AND. IGBL(29) .LT. 20) .OR.
     1     IGBL(29) .EQ. 21) THEN
        IFL(1)   = 'ASYM'
        IFL(2)   = 'AVF'
        IFL(3)   = 'VALID'
        IPR(200) = 0
        IPR(220) = 3
        IPR(221) = 0
        IGBL63   = IGBL(63)
        IGBL(63) = 0
        CALL PLA140
        IGBL(18) = 0
        IGBL(63) = IGBL63
      ENDIF
      IF (IABS(IGBL(8)) .EQ. 3) CALL PLA231 (20)
      IPR(2) = -1
      GOTO 1250
  760 IF (IPR(30) .EQ. 0) THEN
        IGBL(52) = MAX (IGBL(52), IPR(23))
        IPR(205) = 0
      ENDIF
      GOTO 1190
C * PLUTON/PLOT - TEST FOR 'PLUTON' OR 'PLUTON/RENAME' SHORTCUT
  770 IF (IFL(2)(1:3) .EQ. 'NAT') IGBL(3) = 8
      IF (IGBL(3) .EQ. 8 .OR. IGBL(3) .EQ. 12) GOTO 1180
      IFL(2)   = IFL(1)
      IPR(220) = 2
C * PLOT INSTRUCTION CARD
  780 IPR(1)   = 5
      IPR(56)  = 0
      IPR(112) = 0
      IPR(205) = 0
      N        = 1
      K0       = 0
      IF (IGBL(45) .GT. 0 .AND. IGBL(5) .EQ. LU5) THEN
        IGBL(45) = IGBL(45) + 1
        WRITE (LU3, 99984) ICL(1:80)
        WRITE (LU6, 99973) ICL(1:70)
      ENDIF
      IF ((IPR(14) .EQ. 0  .OR. IPR(14) .EQ. 4) .AND.
     1     IPR(220) .EQ. 1) THEN
        IPR(220) = 2
        IFL(2)   = 'ADP'
        IF (IPR(346) .EQ. 1) THEN
          IFL(3) = 'COLOR'
          IPR(220) = 3
        ENDIF
      ENDIF
      IF (IPR(220) .GT. 1) THEN
        DO 790 I = 2, IPR(220)
          NI14 = IFL(I)(1:4)
          IF (NI14 .EQ. 'RING') THEN
            IPR(55)      = 2
            IPR(14)      = -1
          ELSE IF (NI14 .EQ. 'PLAN') THEN
            IPR(55)     = 1
            IPR(14)     = -1
          ELSE IF (NI14 .EQ. 'RESD') THEN
            IF (IPR(14) .GT. 0) THEN
              K0 = K0 + 1
              IF (K0 .LE. IPR(221)) IPR(140) = NINT(FN(K0))
            ELSE
              IPR(55)     = 3
              IPR(14)     = -1
            ENDIF
          ELSE IF (NI14 .EQ. 'LSPL') THEN
            IPR(55)     = 4
            IPR(14)     = -1
C * DISPLAY ON
          ELSE IF (NI14 .EQ. 'DISP') THEN
            CALL GGIP (-999.0, 0.0, 0.0, -3)
            CALL GGIP (-999.0, 0.0, 0.0, 2)
C * META ON
          ELSE IF (NI14 .EQ. 'META') THEN
            CALL GGIP (-999.0, 0.0, 0.0, -2)
          ELSE IF (NI14 .EQ. 'NEWM') THEN
            IPR(55)     = -1
            IPR(14)     = -1
            IPR(169)    = 0
            IF (IPR(30) .NE. 0) CALL GEN108 (LU8, 0)
            IPR(162)    = 0
          ELSE IF (NI14 .EQ. 'PERP') THEN
            IPR(56) = 0
          ELSE IF (NI14 .EQ. 'ALON') THEN
            IPR(56) = 1
          ELSE IF (NI14 .EQ. 'ADP ' .OR. NI14 .EQ. 'TME ') THEN
            IPR(14)     = 4
          ELSE IF (NI14 .EQ. 'POLY') THEN
            IPR(14)     = 5
          ELSE IF (NI14 .EQ. 'PLUT') THEN
            IPR(14)     = 6
          ELSE IF (NI14 .EQ. 'HATO') THEN
            IPR(212)    = 1
          ELSE IF (NI14 .EQ. 'NOHA')  THEN
            IPR(212)    = 0
          ELSE IF (NI14 .EQ. 'LABE') THEN
            IGBL(75)    = 1
          ELSE IF (NI14 .EQ. 'NOLA') THEN
            IGBL(75)    = 0
          ELSE IF (NI14 .EQ. 'ENVE') THEN
            IPR(211) = 1
          ELSE IF (NI14 .EQ. 'HETE') THEN
            IPR(211) = 0
          ELSE IF (NI14 .EQ. 'OCTA') THEN
            IPR(211) = 2
          ELSE IF (NI14 .EQ. 'PARE') THEN
            IPR(350) = 1
          ELSE IF (NI14 .EQ. 'NOPA') THEN
            IPR(350) = 0
          ELSE IF (NI14 .EQ. 'MARG') THEN
            IF (K0 .LT. IPR(221))  THEN
              K0 = K0 + 1
              PAR(44) = FN(K0)
            ENDIF
          ELSE IF (NI14 .EQ. 'TAPE') THEN
            IF (K0 .LT. IPR(221))  THEN
              K0 = K0 + 1
              PAR(48) = FN(K0)
            ENDIF
          ELSE IF (NI14 .EQ. 'NET ') THEN
            IPR(112) = 1
          ELSE IF (NI14 .EQ. 'MONO') THEN
            IPR(116) = 0
          ELSE IF (NI14 .EQ. 'STER') THEN
            IPR(116) = 1
          ELSE IF (NI14 .EQ. 'COLO') THEN
            IPR(346) = 1
          ELSE
            CALL PLA037 (I, L, 2)
            IF (IPR(2) .EQ. 0) THEN
              IF (L .LT. 0) IPR(162)  = IPR(162) * (NP1 + 1) + IABS(L)
            ELSE
              IPR(2) = 0
              WRITE (LU6, 99986) IFL(I)
            ENDIF
          ENDIF
  790   CONTINUE
        IF (IPR(30) .EQ. 0) THEN
          IPR(220) = 2
          IF (IPR(14) .LT. 0) THEN
            WRITE (LU6, 99983)
          ELSE
            WRITE (LU6, 99982)
          ENDIF
          GOTO 810
        ELSE
          IF (IPR(14) .GT. 0) GOTO 1130
          IF (IPR(136) .NE. 1) THEN
            IPR(2) = 12
            GOTO 1120
          ENDIF
        ENDIF
        IF (IPR(86) .EQ. 0) GOTO 10
      ELSE
        IF (IPR(14) .EQ. 0) GOTO 1060
      ENDIF
      GOTO 1130
C * CALC CONTROL CARD FOR PLA069. THE SUB-KEYWORDS ARE:
C * INTRA, INTER, COORDN, METAL, GEOM, HBOND, TMA, VOID, LIST, ADDSYM
  800 IPR(14)  = 0
      IPR(31)  = 0
      IPR(67)  = 0
      IPR(189) = 0
      IPR(197) = 0
      IPR(200) = 0
      IPR(205) = 0
      IF (IGBL(45) .GT. 0 .AND. IGBL(5) .EQ. LU5) THEN
        IGBL(45) = IGBL(45) + 1
        WRITE (LU3, 99984) ICL(1:80)
        WRITE (LU6, 99973) ICL(1:70)
      ENDIF
  810 IPR(136) = 0
C * HANDLE CALC ( = CALC ALL) CASE
      IF (IPR(220) .EQ. 1) THEN
        IF (IGBL(36) .EQ. 0) IGBL(36) = -1
        IGBL(22) = 0
        IPR(121) = 8
        IPR(495) = 1
        IPR(123) = 1
        IF (IPR(221) .GT. 0) THEN
          IPR(221) = 0
          IPR(2) = 7
          GOTO 1120
        ENDIF
      ELSE
        IPR(121) = 0
      ENDIF
  820 IF (IPR(30) .EQ. 0) THEN
        IPR(1) = 2
      ELSE
        IPR(1) = 6
      ENDIF
      IPR(57) = 0
      N = 0
      IGBL(52) = MAX (IGBL(52), IPR(23))
      PAR(262) = PAR(7)
      IF (IPR(14) .NE. 0) THEN
        IPR(121) = 1
        L = 2
        GOTO 920
      ENDIF
      L = 1
C * HANDLE CALC (ALL) CASE
C * (= ADDSYM, INTRA, INTER, COORDN, METAL, SOLV, (ASYM))
      IF (IPR(220) .EQ. 1) THEN
        IF (IPR(121) .EQ. 8) THEN
          GOTO 860
        ELSE IF (IPR(121) .EQ. 7) THEN
          GOTO 920
        ELSE IF (IPR(121) .EQ. 6) THEN
          GOTO 980
        ELSE IF (IPR(121) .EQ. 5) THEN
          GOTO 1020
        ELSE IF (IPR(121) .EQ. 4) THEN
          GOTO 1010
        ELSE IF (IPR(121) .EQ. 3) THEN
          GOTO 940
        ELSE IF (IPR(121) .EQ. 2) THEN
          GOTO 750
        ELSE IF (IPR(121) .EQ. 1) THEN
          GOTO 1090
        ENDIF
      ENDIF
      IF (IPR(221) .GT. 0) PAR(262) = 0.0
      IPR(121) = 1
  830 L        = L + 1
      IF (L .GT. IPR(220)) GOTO 1040
      DO 850 N0 = NP24 + 1, NP22
        NQ1 = IFL(L)
        IF (NQ1(1:4) .EQ. ISWS(N0)) THEN
          ISS = N0 - NP24 + 1
C * ISS = 2: GEOM
          IF (ISS .EQ. 2) THEN
            GOTO 900
C * ISS = 3: TMA, ATOMIC DISPLACEMENT MOTION CALCULATION
          ELSE IF (ISS .EQ. 3) THEN
            IF (IPR(30) .NE. 0) THEN
              IPR(2) = 29
              GOTO 1120
            ENDIF
            IPR(5) = 1
            IF (IPR(221) .GT. 0) THEN
              PAR(34) = FN(1)
              IF (IPR(221) .GT. 1) IPR(21) = NINT(FN(2))
            ENDIF
            IF (IPR(220) .GT. 2 .AND. IFL(3)(1:3) .EQ. 'CAR')
     1          IPR(347) = 1
            GOTO 920
C * ISS = 4: INTRA
          ELSE IF (ISS .EQ. 4) THEN
            GOTO 920
C * ISS = 5: INTER
          ELSE IF (ISS .EQ. 5) THEN
            GOTO 980
C * ISS = 6: NOTM(A)
          ELSE IF (ISS .EQ. 6) THEN
            IPR(5) = 0
C * ISS = 7: NOAN(G)
          ELSE IF (ISS .EQ. 7) THEN
            IPR(7) = 0
C * ISS = 8: NOTO(R)
          ELSE IF (ISS .EQ. 8) THEN
            IPR(8) = 0
C * ISS = 9: NOLS(PL)
          ELSE IF (ISS .EQ. 9) THEN
            IPR(9) = 0
C * ISS = 10: NOST(D)
          ELSE IF (ISS .EQ. 10) THEN
            IPR(72) = 0
C * ISS = 11: NORI(NG)
          ELSE IF (ISS .EQ. 11) THEN
            IPR(10) = 0
C * ISS = 12: NOBOND
          ELSE IF (ISS .EQ. 12) THEN
C * NOBO(ND)/NODI(ST)
            IPR(6) = 0
C * ISS = 13: NOMO(VE) OPTION
          ELSE IF (ISS .EQ. 13) THEN
            IF (IPR(30) .EQ. 1) THEN
C * INSTRUCTION NOT ALLOWED
              IPR(2) = 11
              GOTO 1120
            ELSE
              IGBL(30) = 1
            ENDIF
C * ISS = 14: NOSY(MM) OPTION
          ELSE IF (ISS .EQ. 14) THEN
            IGBL(52) = 1
C * ISS = 15: NOBP(A)
          ELSE IF (ISS .EQ. 15) THEN
            IPR(40) = 0
C * ISS = 16: EWLS
          ELSE IF (ISS .EQ. 16) THEN
C * (E)WLSPL - CALCULATE ESD-WEIGHTED PLANES
            IPR(41) = 2
C * ISS = 17: TOLA
          ELSE IF (ISS .EQ. 17) THEN
            N = N + 1
            IF (N .GT. IPR(221)) GOTO 1060
            PAR(2) = FN(N)
C * ISS = 18:
          ELSE IF (ISS .EQ. 18) THEN
            GOTO 1020
C * ISS = 19: COORDINATION
          ELSE IF (ISS .EQ. 19) THEN
            GOTO 1010
C * ISS = 20: AWLSPL - CALCULATE (ATOM-WEIGHT) WEIGHTED L.S.-PLANES
          ELSE IF (ISS .EQ. 20) THEN
            IPR(41) = 1
C * ISS = 21: HBONDS
          ELSE IF (ISS .EQ. 21) THEN
            IPR(31) = -1
            DO 840 K = 1, IPR(221)
              PAR(7 + K) = FN(K)
  840       CONTINUE
            IPR(121) = 0
            IF (IPR(77) .EQ. 1) THEN
              IPR(2) = 11
              GOTO 1120
            ENDIF
            IPR(77) = 1
C * ISS = 22: UWLSPL - LSPL - BASED ON UNIT WEIGHTS
          ELSE IF (ISS .EQ. 22) THEN
            IPR(41) = 0
C * ISS = 23: OUTPUT SHELX(L) INPUT-FILE (CALC SHELX(L) INSTRUCTION)
          ELSE IF (ISS .EQ. 23) THEN
            IF (EXTENS(1:3) .NE. 'res') THEN
              IGBL(31) = -2
            ELSE
              WRITE (LU6, 99998)
              IPR(121) = 0
              GOTO 10
            ENDIF
C * SET ROUND OFF
            IPR(68) = 0
            WRITE (LU6, 99989)
            GOTO 870
C * ISS = 24: OUTPUT OMEGA INPUT-FILE (CALC OMEGA INSTRUCTION)
          ELSE IF (ISS .EQ. 24) THEN
            IF (IPR(438) .EQ. 0) IGBL(31) = 1
            IF (IPR(220) .LT. 4) THEN
              IPR(6) = 1
              IPR(7) = 1
              IPR(8) = 1
            ENDIF
            GOTO 870
C * ISS = 25: OUTPUT PS300-DGE FILE
          ELSE IF (ISS .EQ. 25) THEN
            IGBL(31) = 2
            IPR(6)   = 1
            GOTO 870
C * ISS = 26: OUTPUT EUCLID-SPF - FILE (CALC EUCLID INSTRUCTION)
          ELSE IF (ISS .EQ. 26) THEN
            IGBL(31) = 3
C * SET ROUND OFF
            IPR(68) = 0
            WRITE (LU6, 99989)
            GOTO 870
C * ISS = 27: FIVE COORDINATION
          ELSE IF (ISS .EQ. 27) THEN
            IPR(122) = 5
            IF (N .LT. IPR(221)) THEN
              N = N + 1
              PAR(35) = FN(N)
            ELSE
              PAR(35) = 0.0
            ENDIF
C * ISS = 28: CALC ALL
          ELSE IF (ISS .EQ. 28) THEN
            IPR(121) = 7
            IPR(220) = 1
            GOTO 820
C * ISS = 29: TOLP
          ELSE IF (ISS .EQ. 29) THEN
            N = N + 1
            IF (N .GT. IPR(221)) GOTO 1060
            PAR(49) = FN(N)
C * ISS = 30: TOLR
          ELSE IF (ISS .EQ. 30) THEN
            N = N + 1
            IF (N .GT. IPR(221)) GOTO 1060
            PAR(3) = FN(N)
C * ISS = 31: NOTHCOR (DELABS)
          ELSE IF (ISS .EQ. 31) THEN
            IPR(398) = 0
C * ISS = 32: VOID
          ELSE IF (ISS .EQ. 32) THEN
            GOTO 950
C * ISS = 33: PROBE RADIUS
          ELSE IF (ISS .EQ. 33) THEN
            N = N + 1
            IF (N .GT. IPR(221)) GOTO 1060
            PAR(84) = FN(N)
C * ISS = 34: PSTEP
          ELSE IF (ISS .EQ. 34) THEN
            N = N + 1
            IF (N .GT. IPR(221)) GOTO 1060
            IPR(214) = NINT(FN(N))
C * ISS = 35: LIST
          ELSE IF (ISS .EQ. 35) THEN
            IPR(197) = 1
            IF (NQ1(5:7) .NE. '   ') THEN
              IPR(185) = ICHAR(NQ1(5:5)) - ICHAR('W')
              IPR(186) = ICHAR(NQ1(6:6)) - ICHAR('W')
              IPR(187) = ICHAR(NQ1(7:7)) - ICHAR('W')
            ENDIF
C * ISS = 36: SUBKEYWORD EXPAND
          ELSE IF (ISS .EQ. 36) THEN
            IPR(67) = 1
C * ISS = 37: CALC DIST
          ELSE IF (ISS .EQ. 37) THEN
            IPR(57)     = -2
            PAR(262)    = 3.0
            IPR(7)      = 0
            GOTO 1030
C * ISS = 38: TOLEA
          ELSE IF (ISS .EQ. 38) THEN
            N = N + 1
            IF (N .GT. IPR(221)) GOTO 1060
            PAR(26) = FN(N)
C * ISS = 39: MISS
          ELSE IF (ISS .EQ. 39) THEN
            GOTO 860
C * ISS = 40: SOLV
          ELSE IF (ISS .EQ. 40) THEN
            GOTO 940
C * ISS = 41: TOLM
          ELSE IF (ISS .EQ. 41) THEN
            N = N + 1
            IF (N .GT. IPR(121)) GOTO 1060
            PAR(27) = FN(N)
C * ISS = 42: NODI
          ELSE IF (ISS .EQ. 42) THEN
C * NOBO(ND)/NODI(ST)
            IPR(6) = 0
C * ISS = 43: BOND
          ELSE IF (ISS .EQ. 43) THEN
            IPR(6) = 1
C * ISS = 44: ANGLE
          ELSE IF (ISS .EQ. 44) THEN
            IPR(7) = 1
C * ISS = 45: TORS(ION)
          ELSE IF (ISS .EQ. 45) THEN
            IPR(8) = 1
C * ISS = 46: CSD-QUE
          ELSE IF (ISS .EQ. 46) THEN
            IGBL(31) = 4
            GOTO 870
C * ISS = 47: SQUEEZE
          ELSE IF (ISS .EQ. 47) THEN
            IPR(210) = 1
            IPR(326) = 1
            IF (IPR(221) .EQ. 1) IPR(142) = NINT(FN(1))
            IGBL(31) = 10
            CALL PLA021
            IPR(200) = 2
            GOTO 960
C * ISS = 48: SAR
          ELSE IF (ISS .EQ. 48) THEN
            IPR(326) = 1
C * ISS = 49: CALC FCF
          ELSE IF (ISS .EQ. 49) THEN
            IPR(210) = - 1
            IF (L .EQ. IPR(220)) GOTO 900
C * ISS = 50: DIFA
          ELSE IF (ISS .EQ. 50) THEN
            GOTO 890
C * ISS = 51: CALC NEWSYM
          ELSE IF (ISS .EQ. 51) THEN
            IPR(210) = - 3
            IF (FN(1) .NE. 0.0) PAR(383) = FN(1)
            IGBL(31) = 5
            CALL PLA021
            GOTO 900
C * ISS = 52: NOCHECK (DELABS)
          ELSE IF (ISS .EQ. 52) THEN
            IPR(363) = 0
C * ISS = 53: OUTPUT PDB-FORMATTED FILE
          ELSE IF (ISS .EQ. 53) THEN
            IGBL(31) = 7
            GOTO 870
C * ISS = 54: HINCL (TMA)
          ELSE IF (ISS .EQ. 54) THEN
            IPR(497) = 1
C * ISS = 55: NONSYM
          ELSE IF (ISS .EQ. 55) THEN
            IPR(495) = 3
            IF (IPR(221) .GT. 0) PAR(73) = FN(1)
            IF (IPR(221) .GT. 1) PAR(75) = FN(2)
            CALL PLA015 (0, 39)
            GOTO 910
C * ISS = 56: NONA OPTION (HBONDS)
          ELSE IF (ISS .EQ. 56) THEN
            IPR(300) = 0
C * ISS = 57: MAXDEV
          ELSE IF (ISS .EQ. 57) THEN
            N = N + 1
            IF (N .GT. IPR(221)) GOTO 1060
            PAR(76) = FN(N)
C * ISS = 58: WLSP
          ELSE IF (ISS .EQ. 58) THEN
C * (E)WLSPL - CALCULATE ESD-WEIGHTED PLANES
            IPR(41) = 2
C * ISS = 59: FCAL (SQUEEZE OPTION)
          ELSE IF (ISS .EQ. 59) THEN
            IPR(132) = 1
C * ISS = 60: ADDSYM
          ELSE IF (ISS .EQ. 60) THEN
            GOTO 860
C * ISS = 61: DELABS
          ELSE IF (ISS .EQ. 61) THEN
            GOTO 890
C * ISS = 62: NOSORT ATOMS OPTION
          ELSE IF (ISS .EQ. 62) THEN
            IGBL(33) = 0
C * ISS = 63: DISORDER (MINOR) INCLUDED
          ELSE IF (ISS .EQ. 63) THEN
            IPR(303) = 1
C * ISS = 64: GENERATE (HKL)
          ELSE IF (ISS .EQ. 64) THEN
            IPR(408) = 1
            IF (IPR(210) .EQ. -1) GOTO 900
            GOTO 880
C * ISS = 65: EXPE
          ELSE IF (ISS .EQ. 65) THEN
            IPR(408) = 2
            GOTO 880
C * ISS = 66: MAXRING
          ELSE IF (ISS .EQ. 66) THEN
            N = N + 1
            IF (N .GT. IPR(221)) GOTO 1060
            IPR(579) = NINT(FN(N))
C * ISS = 67: MOLSYM
          ELSE IF (ISS .EQ. 67) THEN
            IPR(495) = 2
            IF (IPR(221) .GT. 0) PAR(73) = FN(1)
            IF (IPR(221) .GT. 1) PAR(75) = FN(2)
            GOTO 910
C * ISS = 68: RENUM KEYWORD
          ELSE IF (ISS .EQ. 68) THEN
            IPR(501) = 1
C * ISS = 69: SOLV PLOT
          ELSE IF (ISS .EQ. 69) THEN
            IPR(326) = 2
C * ISS = 70: CALC RDF
          ELSE IF (ISS .EQ. 70) THEN
            PAR(262) = PAR(450)
            IF (IPR(221) .GT. 0) THEN
                PAR(262) = FN(1)
              IF (IPR(221) .GT. 1) PAR(451) = FN(2)
            ENDIF
            GOTO 1015
C * ISS = 71: SOLV GRID
          ELSE IF (ISS .EQ. 71) THEN
            N = N + 1
            IF (N .GT. IPR(221)) GOTO 1060
            PAR(80)  = FN(N)
            IPR(214) = 0
C * ISS = 72: SOLV F3D
          ELSE IF (ISS .EQ. 72) THEN
            IPR(326) = 3
C * ISS = 73: NOSF
          ELSE IF (ISS .EQ. 73) THEN
            IPR(595) = 1
          ELSE
            GOTO 850
          ENDIF
          GOTO 830
        ENDIF
  850 CONTINUE
      IF (IPR(210) .EQ. 0) THEN
C * IF NOT A SUB-KEYWORD THEN ASSUME ELEMENT SYMBOL FOLLOWED BY RADIUS
C * NOTE: INDIVIDUAL ATOM - RADIUS INTERPRETED IN PLA069 FOR IPR(17)=1
        IF (IPR(31) .EQ. 1) THEN
          IF (IPR(221) .GT. 0) THEN
            N = N + 1
            PAR(68) = FN(N)
          ELSE
            PAR(68) = PAR(7)
          ENDIF
        ENDIF
        CALL PLA037 (L, NID, 3)
        IF (IPR(31) .EQ. 0) IPR(156) = 1
        IF (L .GT. 2) THEN
          IF (NID .GT. 0) THEN
            IF (IPR(31) .LT. 1) N = N + 1
            IF (IPR(57) .LT. 0) THEN
              IPR(57) = - NID
              IF (N .EQ. IPR(221)) PAR(262) = FN(N)
            ELSE
              IF (N .GT. IPR(221)) THEN
                FNN = PAR(7)
              ELSE
                FNN = FN(N)
              ENDIF
              RADR(NID, 1) = FNN
            ENDIF
          ELSE IF (NID .EQ. 0 .AND. IPR(30) .NE. 0) THEN
            IF (IPR(31) .EQ. 1) THEN
              GOTO 10
            ELSE
              IPR(2) = 18
              GOTO 1120
            ENDIF
          ENDIF
        ELSE
          IPR(2) = 18
          GOTO 1120
        ENDIF
      ENDIF
      GOTO 830
C * ADDSYM
  860 IPR(121) = IPR(121) - 1
      IPR(30)  = 0
      IF (IPR(37) .EQ. 0) GOTO 1120
      IPR(205) = 1
      CALL PLA089
C * ERROR TEST
      IF (IPR(2) .NE. 0) GOTO 1120
      IF (IGBL(3) .EQ. 4) THEN
        IPR(1) = 3
        IF (IPR(2) .EQ. 0) IPR(2) = -1
        GOTO 1250
      ENDIF
      GOTO 10
  870 IF (IPR(438) .EQ. 0) THEN
        CALL PLA021
      ENDIF
      GOTO 910
  880 CALL PLA293 (PAR(17), 0)
      PAR(165) = ASIN (MIN(1.0, PAR(287) * PAR(17))) * GL(5)
      GOTO 830
C * CALC DELABS
  890 IPR(210) = - 2
      IF (IGBL(37) .EQ. 0) THEN
        IPR(2) = 56
        GOTO 1120
      ENDIF
C * SHORT GEOMETRY CALCULATION (GEOM)
  900 IF (IPR(220) .EQ. 2 .OR.
     1   (IPR(220) .EQ. 3 .AND. IFL(3)(1:3) .EQ. 'NOM')) THEN
        IPR(6)      = 1
        CALL PLA015 (0, 39)
        IF (IPR(210) .NE. -2) THEN
          IPR(7) = 1
          IPR(8) = 1
        ENDIF
      ENDIF
  910 IF (IPR(30) .NE. 0) THEN
        IPR(2) = 31
        GOTO 1120
      ENDIF
      IPR(31)  = 0
      IPR(121) = 0
      GOTO 830
C * CALC INTRA (UNIQUE MOLECULE CALCULATION)
  920 IPR(31)   = 0
      IPR(430)  = -1
      IF (IPR(30) .NE. 0) THEN
        IPR(2) = 31
        GOTO 1120
      ENDIF
      DO 930 K = 5, 11
        IPR(K) = 1
  930 CONTINUE
      IPR(495) = 1
      IPR(121) = IPR(121) - 1
C * SET FOR CALC INTRA AS LAST INSTRUCTION
      IF (IPR(121) .EQ. 0) IPR(136) = 1
      CALL PLA015 (0, 39)
      GOTO 830
C * SOLV
  940 IPR(200) = 2
      GOTO 960
C * VOID
  950 IPR(200) = 1
  960 IF (IPR(23) .EQ. 1) THEN
        IPR(2) =  33
        GOTO 1120
      ENDIF
      DO 970 K = 5, 10
        IPR(K)  = 0
  970 CONTINUE
      GOTO 1000
C * CALC INTER
  980 IPR(200) = 0
      IPR(104) = 0
      DO 990 K = 5, 10
        IPR(K)  = 0
  990 CONTINUE
      IF (IPR(77) .EQ. 1) THEN
        IPR(2) = 11
        GOTO 1120
      ENDIF
      IPR(77)  = 1
 1000 IPR(31)  = -1
      IPR(90)  = 1
      IPR(121) = IPR(121) - 1
      GOTO 830
C * CALC METAL
 1010 IF (IPR(155) .GT. 0) THEN
        IPR(57)  = 1
        PAR(262) = 5.0
        IPR(170) = 0
        IPR(5)   = 0
        IPR(6)   = 1
        IPR(7)   = 0
        IPR(8)   = 0
        IPR(9)   = 0
        IPR(10)  = 0
        CALL PLA015 (0, 39)
        GOTO 1030
      ELSE
        IPR(121) = IPR(121) - 1
        GOTO 10
      ENDIF
C * CALC RDF
 1015 IPR(57)  = 2
      IPR(170) = 0
      CALL PLA065 (0, 0)
      CALL PLA015 (0, 39)
      GOTO 1030
C * CALC COORDN
 1020 IPR(5)  = 0
      IPR(6)  = 1
      IPR(7)  = 16
      IPR(8)  = 0
      IPR(9)  = 0
      IPR(10) = 0
      IPR(1)  = 6
      IF (IGBL(121) .NE. 0 .AND. IPR(44) .EQ. 0)
     1    CALL PLA096 (0, ' ', -1.0, PAR(454))
      IF (IPR(30) .EQ. 0) THEN
        DO 1025 I = 1, 16
          SAV(I) = FN(I)
 1025   CONTINUE
        CALL PLA069
        DO 1026 I = 1, 16
          FN(I) = SAV(I)
 1026   CONTINUE
      ENDIF
 1030 IPR(31)     = 1
      IF (IPR(221) .EQ. 1) THEN
        IF ((IPR(220) .EQ. 3 .AND. IFL(3)(1:3) .EQ. 'NOA') .OR.
     1       IPR(220) .EQ. 2) THEN
          IF (IPR(57) .EQ. 1) IPR(170) = 1
          PAR(262) = FN(1)
        ENDIF
      ENDIF
      IPR(121) = IPR(121) - 1
      IPR(122) = 0
      CALL PLA015 (0, 39)
      GOTO 830
C * CALC CARD HANDLING
 1040 IF (IPR(39) .GT. 0) THEN
        GOTO 1130
      ELSE
C * MESSAGES
        WRITE (LU6, 99992)
        GOTO 1090
      ENDIF
 1050 IF (IPR(30) .EQ. 0) THEN
        CALL PLA280 (ICL)
        IGBL(52) = MAX (IGBL(52), IPR(23))
        CALL PLA069
        CALL PLA073 (1)
        IF (IPR(85) .EQ. 0) THEN
          IPR(5) = 0
          CALL PLA029
        ENDIF
        GOTO 10
      ENDIF
      CALL PLA288 (MODE)
      GOTO 10
C * NOT ENOUGH DATA ON CARD
 1060 IPR(2) = 5
      GOTO 1120
C * SAVE THIS INSTRUCTION
 1070 IF (IGBL(45) .GT. 0 .AND. IGBL(5) .EQ. LU5) THEN
        WRITE (LU3, 99984) ICL(1:80)
        IGBL(45) = IGBL(45) + 1
        WRITE (LU6, 99973) ICL(1:70)
      ENDIF
      GOTO 10
C * HANDLE END-OF-FILE
 1080 IF (IGBL(5) .EQ. LU5) THEN
        GOTO 1090
      ELSE IF (IGBL(5) .EQ. LU3) THEN
        IGBL(5) = LU5
C * OPEN MAIN X-WINDOW
        IGBL(23) = 10
        IGBL(24) = 1
        GOTO 10
      ELSE
        IF (IPR(37) .EQ. 0 .AND. IPR(367) .EQ. 0 .AND.
     1      PAR(101) .EQ. 0.0) GOTO 1120
        IF (IPR(3) .EQ. 1) THEN
          IPR(3) = -1
          GOTO 1120
        ELSE
          IGBL(5) = LU3
        ENDIF
      ENDIF
      CALL GEN108 (LU3, 0)
      GOTO 10
C * HANDLE END-CARD
 1090 IF (IGBL(5) .EQ. LU5) THEN
        IF (IABS(IGBL(45)) .GT. 1) THEN
C * WRITE END CARD TO SAVE-FILE
          WRITE (LU3, 99984) ICL(1:80)
          WRITE (LU6, 99973) ICL(1:70)
          IGBL(45) = -1
          CALL GEN108 (LU3, 0)
        ENDIF
        GOTO 1120
      ENDIF
C * TREAT END-CARD AS END-OF-FILE FOR SHELX-INPUT ON LU1
C * BUT IGNORE WHEN Q-PEAKS ARE REQUESTED
      IF (IGBL(5) .EQ. LU1 .AND. IABS(IGBL(8)) .EQ. 2) THEN
        IF (IGBL(95) .EQ. 0) THEN
          IGBL(5) = LU3
          CALL GEN108 (LU3, 0)
        ENDIF
        GOTO 10
      ENDIF
      IF (IPR(3) .EQ. 0) GOTO 1120
      IPR(2)  = 0
      IGBL(5) = LU1
      IGBL(8) = IABS(IGBL(8))
C * GIVE SUMMARY
      IPR(1)  = 3
      IF (IPR(2) .EQ. 0) IPR(2) = -1
      GOTO 1250
C * STOP/QUIT/EXIT - NO FULL END PROCESSING
 1100 WRITE (LU6, 99999) IGBL(49), NAME(1)(1 : KNM(1))
      GOTO 1260
C * UNSUITABLE ATOM LABEL ERROR
 1110 IPR(2)  = 3
C * ERROR HANDLING
 1120 IPR(1)   = 1
      IPR(121) = 0
 1130 IF (IPR(1) .EQ. 2) THEN
        CALL PLA069
C * ERROR TEST
        IF (IPR(2) .NE. 0) GOTO 1250
C * PRINT COORDINATES
        CALL PLA073 (1)
        IF (IPR(2) .NE. 0) GOTO 1250
C * CHECK BONDS ETC IN CIF
        IF (IABS(IGBL(8)) .EQ. 3) CALL PLA296
        GOTO 1140
      ELSE IF (IPR(1) .EQ. 5) THEN
        GOTO 1170
      ELSE IF (IPR(1) .EQ. 6) THEN
        GOTO 1140
      ELSE IF (IPR(1) .EQ. 7) THEN
        GOTO 1190
      ELSE
        IF (IPR(2) .EQ. 0) IPR(2) = -1
        GOTO 1250
      ENDIF
C * CALC INTRA MODE
 1140 IF (IPR(31) .EQ. 0) THEN
        IF (IPR(495) .LE. 1) THEN
C * HANDLE DISPLACEMENT PARAMETERS
          CALL PLA029
          IF (IGBL(3) .EQ. 23 .OR. IGBL(3) .EQ. 24 .OR.
     1        IGBL(3) .EQ. 27) THEN
            IPR(1)  = 3
            IF (IPR(2) .EQ. 0) IPR(2) = -1
            GOTO 1250
          ELSE IF (IGBL(3) .EQ. 25) THEN
            CALL PLA292 (LU6, LU16, LU17, IGBL(29), IPR(384))
            GOTO 1260
          ELSE
            IF (IPR(504) .EQ. 1) THEN
              CALL PLUTON (1)
              GOTO 1220
            ENDIF
C * OUTPUT CONNECTION TABLES
            IPR(18) = -2
            CALL PLA073 (0)
            IF (IPR(2) .NE. 0) GOTO 1250
            IF (IGBL(3) .EQ. 11) THEN
              IPR(1)  = 3
              IF (IPR(2) .EQ. 0) IPR(2) = -1
              GOTO 1250
            ENDIF
            IF (IPR(14) .NE. 6) THEN
C * LIST INTRA GEOMETRY
              CALL PLA076
C * GENERATE RINGS AND PLANES
              CALL PLA077
              IF (IPR(2) .NE. 0) GOTO 1250
C * LIST LEAST-SQUARES PLANES
              CALL PLA074
C * RING PUCKERING ANALYSIS
              CALL PLA075
C * FCF/DELABS/NEWSYM
              IF (IPR(210) .LT. 0) THEN
                IF (IPR(493) .EQ. 0) THEN
                  IF (IPR(210) .EQ. -3) THEN
                    IPR(493) = 2
                  ELSE
                    IPR(2)  = 47
                    GOTO 1250
                  ENDIF
                ENDIF
                IF (IPR(498) .GT. 0) THEN
                  IPR(2)  = 45
                  GOTO 1250
                ENDIF
                IF (IPR(210) .EQ. -3) THEN
                  CALL PLA160 (2, TM1)
                ELSE
                  CALL PLA179
                ENDIF
                IPR(1)  = 1
                IF (IPR(2) .EQ. 0) IPR(2) = -1
                GOTO 1250
              ENDIF
            ENDIF
          ENDIF
        ENDIF
C * CALC INTER, VOID, SQUEEZE, NEWSYM AND COORDINATION MODE
      ELSE
        IPR(17)  = IPR(31)
        IPR(189) = IPR(200)
        CALL PLA069
        IF (IPR(2) .NE. 0) GOTO 1250
        IF (IPR(57) .EQ. 2) THEN
          CALL PLA065 (-1, 0)
          GOTO 1240
        ENDIF
        IF (IGBL(3) .EQ. 9) THEN
          IPR(1)  = 3
          IF (IPR(2) .EQ. 0) IPR(2) = -1
          GOTO 1250
        ENDIF
        IF (IGBL(3) .EQ. 5 .AND. IPR(210) .EQ. 0) THEN
          IF (IGBL(31) .NE. 0) THEN
            CLOSE (LU2, ERR = 1160)
 1160       IGBL(31) = 0
          ENDIF
          IPR(1) = 3
          IF (IPR(2) .EQ. 0) IPR(2) = -1
          GOTO 1250
        ENDIF
        IF (IGBL(3) .EQ. 36) THEN
          IF (IPR(2) .EQ. 0) IPR(2) = -1
          GOTO 1250
        ENDIF
        IF (IPR(210) .EQ. 1) THEN
          IF (IPR(498) .EQ. 0) THEN
            CALL PLA029
            CALL PLA129
            IPR(1) = 1
          ELSE
            IPR(2) = 45
          ENDIF
          IF (IPR(2) .EQ. 0) IPR(2) = -1
          GOTO 1250
        ENDIF
        GOTO 1200
      ENDIF
C * EXECUTE PLOT OPTION
 1170 IF (IPR(14) .LT. 0) THEN
C * NEWMAN, RING, PLAN, LSPL, RESD PLOT
        CALL GEN108 (LU8, 0)
        CALL PLA101
      ELSE IF (IPR(14) .EQ. 4) THEN
C * DISPLACEMENT MOTION ELLIPSOID-PLOT
        IF (IPR(85) .EQ. 0) THEN
          IPR(5) = 0
          CALL PLA029
        ENDIF
        IF (IPR(140) .GT. IPR(75)) THEN
          IPR(2)  = 13
          GOTO 1250
        ENDIF
        IF (IPR(460) .LT. 3) THEN
          IGBL(23) = 9
          LMOD     = 1
          IFL(1)   = 'LSPL'
          CALL PLA015 (476, 1)
          IPR(453) = 0
          IPR(448) = 0
        ENDIF
        IF (IPR(341) .EQ. 5) THEN
          IGBL(23) = 9
        ENDIF
        IF (IPR(551) .LT. 3) THEN
          IGBL(23) = 9
          LMOD     = 1
          IFL(1)   = 'LSPL'
          IPR(551) = 1
          CALL PLA015 (552, 1)
          IPR(453) = 0
          IPR(448) = 0
        ENDIF
        CALL PLA106
        IF (IPR(2) .NE. 0) GOTO 1250
      ELSE IF (IPR(14) .EQ. 5) THEN
        MNH(6) = 1
        CALL PLA103
      ELSE IF (IPR(14) .EQ. 6) THEN
        IF (IPR(85) .EQ. 0) THEN
          IPR(5) = 0
          CALL PLA029
        ENDIF
        GOTO 1180
      ENDIF
      IF (IPR(430) .GT. 0) THEN
        IGBL(92) = MAX (IGBL(92), IPR(430))
        IGBL(93) = MAX (IGBL(93), IPR(431))
        IPR(31)  = -1
        IPR(17)  = -1
        IPR(90)  =  1
        IGBL(63) =  0
        CALL PLA069
        CALL PLA172
        IPR(1) = 1
        IF (IPR(2) .EQ. 0) IPR(2) = -1
        GOTO 1250
      ENDIF
      GOTO 1200
C * CALLS TO PLUTON
 1180 IF (IGBL(3) .NE. 8  .AND. IGBL(3) .NE. 12 .AND.
     1    IGBL(3) .NE. 13 .AND. IGBL(3) .NE. 26) THEN
        CALL PLUTON (1)
        GOTO 1220
      ELSE
C * EXPLICIT PLUTON/RENAME/HFIX/ANIS
        CALL PLUTON (-1)
        GOTO 1260
      ENDIF
C * EXECUTE LIST ON DISPLAY OPTIONS
 1190 IF (IPR(30) .EQ. 0) THEN
        CALL PLA069
        IF (IPR(2)  .NE. 0) GOTO 1250
        IF (IPR(205) .NE. 0) GOTO 1240
        CALL PLA073 (-1)
        IF (IPR(2) .NE. 0) GOTO 1250
      ENDIF
      IPR(18) = IPR(84)
      IF (IPR(1) .EQ. 4) THEN
        CALL PLA073 (-1)
        IF (IPR(2) .NE. 0) THEN
          GOTO 1250
        ENDIF
      ELSE IF (IPR(1) .EQ. 7) THEN
C * INTERACTIVE DIST, ANGLE, TORSION AND LSPL CALCULATION
        CALL PLA035 (1)
      ENDIF
      IF (IGBL(3) .EQ. 41) THEN
        IPR(2) = -1
        GOTO 1250
      ELSE
        GOTO 1240
      ENDIF
 1200 TIMT  = TIMEA
      TIMEA = CPUTIM()
      WRITE (LU6, 99948) TIMEA - TIMT, TIMEA - TIMEZ
      GOTO 1240
 1210 IGBL(1) = -1
      RETURN
 1220 IGBL(1) = 0
      RETURN
 1230 IGBL(1) = 1
      RETURN
 1240 IGBL(1) = 2
      RETURN
 1250 IGBL(1) = 3
      RETURN
 1260 IGBL(1) = 4
      RETURN
99999 FORMAT (':: Escape EXIT from PLATON - ', I4, ' Pages',
     1 ' on FILES ', A, '.lis', /)
99998 FORMAT ('!! Error: Input and Output have the same <name>.res')
99997 FORMAT ('!! Error: Input and Output have the same <name>.acc')
99996 FORMAT (A, 1X, 4(4X, F10.2))
99995 FORMAT (':: Data Set ', A, /)
99994 FORMAT (/, ':: Old/Current Label Size =', F5.2)
99993 FORMAT (   ':: New         Label Size =', F5.2, /)
99992 FORMAT (':: No ATOMS supplied as yet')
99991 FORMAT ('CELL ', 3F10.4, 3F10.2, A)
99990 FORMAT (':: Rounding Range 1 :', I3)
99989 FORMAT (':: Rounding set to OFF')
99988 FORMAT ('** ', A)
99987 FORMAT (':: LSPL/RING/FIT/LINE calculation will be included in ',
     1        'next CALC GEOM/INTRA run', /)
99986 FORMAT (':: Unrecognised keyword or label (ignored): ', A, /)
99985 FORMAT (':: Transformation on input data with Det =', F5.2, /)
99984 FORMAT (A)
99983 FORMAT (':: AUTO EXEC: Calc Intra',/)
99982 FORMAT (':: Automatic join instruction',/)
99981 FORMAT (A, 1X, 3F8.4, 3X, F8.4, F10.2)
99980 FORMAT ('Atom', 8X , 'U1', 6X, 'U2', 6X, 'U3', 8X, 'U(eq)',
     1         5X, 'U3/U1')
99979 FORMAT (':: No more than', I3, ' Atom Types allowed',
     1             ' on DOAC card', /)
99978 FORMAT (':: No more than', I3, ' Atom Types allowed',
     1             ' on (IN/EX)CLUDE card', /)
99977 FORMAT (':: Bond Type/code = #Lines    Bond Radius (Ang)')
99976 FORMAT (':: Normal   ', I5, I9, 9X, F6.2)
99975 FORMAT (':: To H     ', I5, I9, 9X, F6.2)
99974 FORMAT (':: To Metal ', I5, I9, 9X, F6.2)
99973 FORMAT (':: Saved: ', A)
99972 FORMAT ('::  Transformation for x,y,z coordinates', /,
     1        ':: (', 3F8.4, ') (x)  ', F10.4, /,
     1        ':: (', 3F8.4, ') (y) +', F10.4, /,
     1        ':: (', 3F8.4, ') (z)  ', F10.4, /)
99971 FORMAT (2A)
99970 FORMAT (6F10.4)
99969 FORMAT (A, 4F10.5)
99968 FORMAT ('END', /, 'END')
99967 FORMAT (//, 'Generated INPUT for Structure Tidy on: ', A, /)
99966 FORMAT (I4, 1X, A, I4, 5I2, 2I3, 5I2, I3, I2, I3, 3I2, I5, I2)
99965 FORMAT ('Atom Label   DFN A S P H C  R  T M P D A A  H O  P',
     1        ' U L      N')
99964 FORMAT (/, ':: AtomType  EllipsoidType   NumberOfShadeLines', //,
     1           ':: C        ', I10, 10X, I10, /,
     2           ':: H        ', I10, 10X, I10, /,
     3           ':: Other    ', I10, 10X, I10, //,
     4           'Note: Ellipsoid types: 0 = Principle Ellipsoids, ',
     5           ' 1 = Envelope Type', /)
99963 FORMAT (/, ':: Volume From ORMA =', F10.1, ', Please Check')
99962 FORMAT (/, 'W: No SU''s on parameters supplied on input', /)
99961 FORMAT ('>> RESTART <<')
99960 FORMAT (':: SHELXL HKLF Matrix:', 9F6.2, /)
99959 FORMAT (':: Coord. Cell:', 3F10.3, 3F10.2, /,
     1        ':: Refln. Cell:', 3F10.3, 3F10.2, /)
99958 FORMAT (':: SPGR P1 Substituted', /)
99957 FORMAT ('data_', A)
99955 FORMAT ('INTRA BONDS    for Dist(I-J) < RC(I) + RC(J)',
     1        ' + TOLA + (TOLEA/TOLCUO)')
99954 FORMAT ('INTER CONTACTS for Dist(I-J) < RW(I) + RW(J) + TOLR')
99953 FORMAT ('TOLA   [=PAR(2)] = ', F5.2,
     1        ' Ang., current INTRA tolerance')
99952 FORMAT ('TOLCUO [=PAR(5)] = ', F5.2,
     1        ' Ang., add for (Cu...O,N) Contacts')
99951 FORMAT ('TOLEA  [=PAR(26)] = ', F5.2,
     1        ' Ang., add for (Earth)Alkali- non-metal contacts')
99950 FORMAT ('TOLR   [=PAR(3)] = ', F5.2,
     1        ' Ang., current INTER tolerance')
99949 FORMAT ('Element   Covalent(RC) van der Waals(RW) Current')
99948 FORMAT (/, ':: CPU-time:', F8.1, ' (Total:', F8.1, ')')
99947 FORMAT (A, 2F10.0, 2A)
99946 FORMAT (/, ':: ', A)
99945 FORMAT (':: ', A)
99944 FORMAT (/, ':: Det TM = ', F10.2)
99943 FORMAT (A, 2F10.4)
99942 FORMAT (A, 2F10.0, A)
99941 FORMAT ('N')
      END
      SUBROUTINE PLA003
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16,
     1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NPVD=40000000,
     2 NP22=256,NP25=99,NP29=63,NP38=125,NP39=30,NP41=200,NP45=2048,
     3 NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /Q/ ICL, IFL(NP17)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /FNAME/ KNM(8), KXT, KNM16
      COMMON /NAMES/ NAME(8), EXTENS, PROGNM, FNLU1, FNLU16, RDTYPE
      CHARACTER NAME*80, EXTENS*9, PROGNM*28, FNLU1*80, FNLU16*80,
     1          RDTYPE*7
      COMMON /CGGT/ IGGT
      CHARACTER IGGT*80
      COMMON /PAGENM/ PAGET, PAGEIND(25)
      CHARACTER PAGET*8, PAGEIND*8
      IGBL(1) = 4
      IF (IGBL(63) .GT. 0) THEN
        LU = LU7
      ELSE
        LU = LU6
      ENDIF
      IR = IPR(2)
   10 IF (IR .GT. 0) THEN
C * 1: ATTEMPT TO EXCEED MAX ATOM LIMIT
        IF (IR .EQ. 1) THEN
          WRITE (LU, 99984) NP1
          GOTO 30
C * 2: LABEL PREOCCURRED
        ELSE IF (IR .EQ. 2) THEN
          WRITE (LU, 99977) NQ1
C * 3: UNSUITABLE ATOM LABEL
        ELSE IF (IR .EQ. 3) THEN
          WRITE (LU, 99978) NQ1
          WRITE (LU20, 99854) '_071', 1.0, 1.0, NQ1, NQ1
          IF (IGBL(3) .EQ. 1) THEN
            GOTO 90
          ELSE
            GOTO 30
          ENDIF
C * 4: LABEL INCONSISTENT
        ELSE IF (IR .EQ. 4) THEN
          WRITE (LU, 99983) IFL(2), NQ4
C * 5: NOT ENOUGH DATA ON CARD
        ELSE IF (IR .EQ. 5) THEN
          IF (LU .EQ. LU6) THEN
            WRITE (LU, 99982) ICL(1:76)
            CALL PLA015 (0, 49)
            IF (IPR(470) .EQ. 1) WRITE (LU, 99961)
          ENDIF
C * 6: INVALID ELEMENT SYMBOL
        ELSE IF (IR .EQ. 6) THEN
          WRITE (LU, 99981) NQ1(1:3)
C * 7: UNKNOWN CARD ERROR
        ELSE IF (IR .EQ. 7) THEN
          IF (LU .EQ. LU6) WRITE (LU, 99992) ICL(1:30)
C * 8: TOO MANY ATOMS SPECIFIED
        ELSE IF (IR .EQ. 8) THEN
          WRITE (LU, 99976) NP1
C * 9: FVAR ERROR (SHELX INPUT STYLE)
        ELSE IF (IR .EQ. 9) THEN
          WRITE (LU, 99975)
          GOTO 30
C * 10: POPULATION PARAMETER OVERFLOW
        ELSE IF (IR .EQ. 10) THEN
          WRITE (LU, 99974)
          GOTO 30
C * 11: INSTRUCTION NOT ALLOWED
        ELSE IF (IR .EQ. 11) THEN
          WRITE (LU, 99972) IFL(1)
C * 12: PLOT INSTRUCTION NOT ALLOWED HERE
        ELSE IF (IR .EQ. 12) THEN
          IF (LU .EQ. LU6) WRITE (LU, 99970)
C * 13: SPECIFIED RESIDUE NUMBER NOT PRESENT
        ELSE IF (IR .EQ. 13) THEN
          IF (LU .EQ. LU6) WRITE (LU, 99960) IPR(140)
C * 14:
        ELSE IF (IR .EQ. 14) THEN
C * 15: TRNS (FIX) INSTRUCTION N.O.K.
        ELSE IF (IR .EQ. 15) THEN
          IF (LU .EQ. LU6) WRITE (LU, 99957)
C * 16: INVALID ELEMENT SYMBOL
        ELSE IF (IR .EQ. 16) THEN
          WRITE (LU, 99981) NQ3(1:3)
C * 17: TRANSLATION CODE OUT-OF-RANGE
        ELSE IF (IR .EQ. 17) THEN
          WRITE (LU, 99947) (ITR(I), I = 1, 3), NQ1
          GOTO 30
C * 18: INVALID SUB-KEYWORD or ATOM NAME/TYPE
        ELSE IF (IR .EQ. 18) THEN
          IF (LU .EQ. LU6) WRITE (LU, 99949)
C * 19: VOID ARRAY OVERFLOW
        ELSE IF (IR .EQ. 19) THEN
          IF (LU .EQ. LU6) WRITE (LU, 99946) NPVD
C * 20:
        ELSE IF (IR .EQ. 20) THEN
C * 21:
        ELSE IF (IR .EQ. 21) THEN
C * 22: NOT ENOUGH OVERLAP MEMORY
        ELSE IF (IR .EQ. 22) THEN
          IF (LU .EQ. LU6) WRITE (LU, 99943)
C * 23: TOO MANY AXES (ADDSYM) CONDITION
        ELSE IF (IR .EQ. 23) THEN
          WRITE (LU, 99942) PAR(43)
C * 24: TOO MANY SOLVENT AREAS
        ELSE IF (IR .EQ. 24) THEN
          WRITE (LU, 99940)
C * 25: LMX/PLA091 ERROR
        ELSE IF (IR .EQ. 25) THEN
          WRITE (LU, 99939)
          GOTO 30
C * 26: OVERFLOW IN VOID-ROUTINE (NP1)
        ELSE IF (IR .EQ. 26) THEN
          WRITE (LU, 99938)
C * 27: SYMM/TRNS ERROR
        ELSE IF (IR .EQ. 27) THEN
          WRITE (LU, 99937)
C * 28: ARU-OUT OFF RANGE
        ELSE IF (IR .EQ. 28) THEN
          IF (IGBL(3) .EQ. 1) THEN
            WRITE (LU20, 99854) '_804', 1, 1
            IF (IGBL(36) .NE. 0) CALL PLA230 (0)
            GOTO 80
          ELSE
            WRITE (LU, 99935)
          ENDIF
C * 29: TMA-CALCULATION OUT-OF-SEQUENCE
        ELSE IF (IR .EQ. 29) THEN
          WRITE (LU, 99934)
C * 30: TOO MANY FVAR-PARAMETERS
        ELSE IF (IR .EQ. 30) THEN
          WRITE (LU, 99932)
          GOTO 30
C * 31:
        ELSE IF (IR .EQ. 31) THEN
          WRITE (LU, 99931)
C * 32: NON-RECOVERABLE PROBLEM
        ELSE IF (IR .EQ. 32) THEN
          WRITE (LU, 99929) IPR(323)
          IF (LU .NE. LU6) WRITE (LU6, 99929) IPR(323)
          GOTO 80
C * 33: CALC SOLV/VOID NOT ALLOWED IN ANGSTROM MODE
        ELSE IF (IR .EQ. 33) THEN
          WRITE (LU, 99928)
C * 34: FACE DIST .LT. 0
        ELSE IF (IR .EQ. 34) THEN
          WRITE (LU, 99923)
C * 35: NO MU-PROVIDED FOR ABSGAUSS or ABSTOMPA
        ELSE IF (IR .EQ. 35) THEN
          WRITE (LU, 99921)
          GOTO 30
C * 36: UNKNOWN ELEMENT TYPE ON SFAC LINE
        ELSE IF (IR .EQ. 36) THEN
          WRITE (LU, 99920)
          GOTO 30
C * 37: NO VALID DIRCOS
        ELSE IF (IR .EQ. 37) THEN
          WRITE (LU, 99916)
          GOTO 30
C * 38: NO VALID PSI-SCAN DATA
        ELSE IF (IR .EQ. 38) THEN
          WRITE (LU, 99915)
          GOTO 30
C * 39: No Refl Supplied
        ELSE IF (IR .EQ. 39) THEN
          WRITE (LU, 99914)
          GOTO 30
C * 40: NO TRMX WITH NEG DET ON HKLF
        ELSE IF (IR .EQ. 40) THEN
          WRITE (LU, 99913)
          GOTO 30
C * 41: UNKNOWN ELEMENT ON SFAC
        ELSE IF (IR .EQ. 41) THEN
          WRITE (LU, 99912)
          GOTO 30
C * 42: NO VALID ATOMS
        ELSE IF (IR .EQ. 42) THEN
          WRITE (LU, 99911)
          GOTO 30
C * 43: NO .hkl or .fcf
        ELSE IF (IR .EQ. 43) THEN
          WRITE (LU, 99910) NAME(4)(1:KNM(4)), NAME(7)(1:KNM(7))
          GOTO 30
C * 44: NO .hkl file given
        ELSE IF (IR .EQ. 44) THEN
          WRITE (LU, 99909) NAME(4)(1:KNM(4))
          GOTO 30
C * 45: SOMETHING WRONG WITH U/UIJ
        ELSE IF (IR .EQ. 45) THEN
          WRITE (LU, 99907) IPR(498)
          GOTO 30
C * 46: NO-SFAC PROBLEM
        ELSE IF (IR .EQ. 46) THEN
          WRITE (LU, 99906) NQ1
          GOTO 30
C * 47: NO LAMBDA GIVEN
        ELSE IF (IR .EQ. 47) THEN
          WRITE (LU, 99904) MAX (0.0, PAR(17))
C * 48: VOID TOO-LARGE
        ELSE IF (IR .EQ. 48) THEN
          WRITE (LU, 99901)
C * 49: SCRATCH OVERRUN IN EXOR/FMAP
        ELSE IF (IR .EQ. 49) THEN
          WRITE (LU, 99900) NP1
          GOTO 30
C * 50: INCOMPLETE UIJ(SUIJ) DATA ON CIF
        ELSE IF (IR .EQ. 50) THEN
          WRITE (6, 99898) IFL(2)
          WRITE (LU20, 99851) '_806', 1, 1
          GOTO 20
C * 51: INCOMPLETE ATOM DATA ON CIF
        ELSE IF (IR .EQ. 51) THEN
          WRITE (6, 99896) IFL(2)
          WRITE (LU20, 99851) '_805', 1, 1
          GOTO 20
C * 52:
        ELSE IF (IR .EQ. 52) THEN
          WRITE (LU, 99895)
          GOTO 30
C * 53:
        ELSE IF (IR .EQ. 53) THEN
          WRITE (LU, 99894)
          GOTO 30
C * 54: SYMM-LABEL PACK PROBLEM
        ELSE IF (IR .EQ. 54) THEN
          WRITE (LU, 99892)
C * 55: NO REFLECTION DATA PROBLEM
        ELSE IF (IR .EQ. 55) THEN
          WRITE (LU, 99891)
C * 56: NO DIR-COS
        ELSE IF (IR .EQ. 56) THEN
          WRITE (6, 99888)
          GOTO 20
C * 57: LABEL ALIAS OVERFLOW
        ELSE IF (IR .EQ. 57) THEN
          WRITE (LU, 99885)
          IF (IGBL(61) .EQ. 0 .AND. IPR(30) .EQ. 0) THEN
            IGBL(61) = 1
            CALL PLA281 (1)
            CALL GEN108 (LU20, 0)
            IPR(2) = 0
            GOTO 80
          ENDIF
          WRITE (LU20, 99854) '_071', 1.0, 1.0, NQ1, NQ1
C * 58: CELL PROBLEM
        ELSE IF (IR .EQ. 58) THEN
          IF (IGBL(3) .EQ. 1) THEN
            WRITE (LU20, 99854) '_801', 1.0, 1.0
            GOTO 90
          ELSE
            WRITE (6, 99848)
          ENDIF
          GOTO 80
C * 59: CIF-LINE TOO LONG
        ELSE IF (IR .EQ. 59) THEN
          IF (IGBL(3) .EQ. 1) THEN
            WRITE (LU20, 99854) '_802', 1.0, 1.0
            GOTO 90
          ELSE
            WRITE (6, 99847)
          ENDIF
          GOTO 80
C * 60: CIF-LOOP PROBLEM
        ELSE IF (IR .EQ. 60) THEN
          IF (IGBL(3) .EQ. 1) THEN
            WRITE (LU20, 99854) '_803', 1.0, 1.0
            GOTO 90
          ELSE
            WRITE (6, 99846)
          ENDIF
          GOTO 80
C * 61: READ/FORMAT ERROR
        ELSE IF (IR .EQ. 61) THEN
          WRITE (6, 99853)
          GOTO 20
C * 62: NSP-Problem
        ELSE IF (IR .EQ. 62) THEN
          WRITE (LU6, 99852)
          GOTO 30
C * 63: TRNS/TRMX PROBLEM
        ELSE IF (IR .EQ. 63) THEN
          WRITE (LU6, 99850)
          GOTO 20
C * 64: DATA FORMAT NOT RECOGNISED
        ELSE IF (IR .EQ. 64) THEN
          WRITE (LU, 99849)
        ENDIF
C * NON-FATAL ERROR
        IF (LU .EQ. LU7) GOTO 50
        IPR(2) = 0
        CALL GEN038 (IGGT, 1, 80)
        IGBL(23) = 10
        IGBL(24) = 1
        IF (LU .EQ. LU6) WRITE (LU, 99980) CHAR(IPR(223))
        GOTO 40
C * FATAL ERROR (EXECUTE EXIT STATEMENT)
   20   FNLU1 = NAME(3)(1:KNM(3))//'.'//EXTENS(1:KXT)
        KNMXT = KNM(3) + KXT + 1
        WRITE (6, 99897) FNLU1(1:KNMXT)
        STOP
C * FATAL ERROR (EXECUTE END STATEMENT)
   30   IF (LU .EQ. LU7) GOTO 50
        IPR(2) = 0
        WRITE (LU, 99979)
        IF (IGBL(54) .LT. IGBL(100)) THEN
          IGBL(54) = IGBL(54) + 1
          FN(1)    = IGBL(54)
          IPR(220) = 1
          IPR(221) = 1
          CALL PLA011
          IGBL(5)  = LU5
          IGBL(1)  = 1
          IPR(121) = 0
          GOTO 80
        ENDIF
      ENDIF
   40 IF (IR .NE. 0) THEN
        IF (LU .EQ. LU7 .OR. IGBL(63) .EQ. 0) THEN
          IUCR = IABS(IGBL(8) * IGBL(19) * IPR(30))
          IF (IUCR .EQ. 3 .OR. IUCR .EQ. 4) THEN
            IF (IGBL(36) .NE. 0) CALL PLA230 (0)
          ENDIF
        ENDIF
        PAGET = 'SUMMARY '
        IF (LU .EQ. LU7 .AND. IGBL(63) .GT. 3 .AND.
     1      IGBL(7) .EQ. 1) THEN
          IF (IR .LE. 0 .AND. IPR(3) .LE. 0) THEN
            IF (IABS(IGBL(8)) .EQ. 3) CALL PLA173 (0, LU, 1, 1)
            CALL PLA269 (0)
            WRITE (LU, 99962)
          ENDIF
        ENDIF
        IF (IPR(3) .GE. 0 .AND. IPR(37) .GT. 0) THEN
          IF (LU .EQ. LU7) THEN
            CALL PLA269 (0)
            CALL PLA269 (-999)
          ENDIF
          WRITE (LU, 99991)
          IF (IPR(23) .EQ. 0) THEN
            IF (PAR(17)  .LT. 0.001)   WRITE (LU, 99999)
            IF (PAR(107) .LT. 0.00001) WRITE (LU, 99998)
            IF (IGBL(30) .EQ. 1)       WRITE (LU, 99997)
            IF (IGBL(52) .EQ. 1)       WRITE (LU, 99996)
          ENDIF
          IF (IPR(129) .LT. 10) WRITE (LU, 99948)
          IF (IPR(209) .NE. 0)  WRITE (LU, 99951)
          IF (IPR(118) .NE. 0) WRITE (LU, 99925)
          IF (IPR(459) .NE. 0) WRITE (LU, 99903)
          IF (IPR(72)  .EQ. 0) WRITE (LU, 99956)
          IF (IPR(130) .EQ. 1) WRITE (LU, 99995)
          IF (IPR(124) .NE. 0) WRITE (LU, 99886)
          IF (IGBL(8)  .EQ. 2) WRITE (LU, 99973)
          IF (IPR(23) .EQ. 0 .AND. IPR(202) .EQ. 0) WRITE (LU, 99950)
          IF (PAR(42) .LT. 100.0) WRITE (LU, 99927)
          IF (IPR(44) .EQ. 1) WRITE (LU, 99988)
          IF (IPR(215) .GT. 0) WRITE (LU, 99952)
          IF (IPR(23) .EQ. 0 .AND. IPR(484) .EQ. 0) WRITE (LU, 99933)
          WRITE (LU, 99890)
          IF (IPR(153) .GT. 0) WRITE (LU, 99959) IPR(153)
          IF (IPR(161) .GT. 0) WRITE (LU, 99889) IPR(161)
          IF (IPR(160) .GT. 0)
     1      WRITE (LU, 99958) IPR(160), PAR(199), PAR(200)
          IF (IPR(403) .GT. 0) THEN
            WRITE (LU, 99924) IPR(403), PAR(251), PAR(252)
          ENDIF
          IF (IPR(404) .GT. 0) THEN
            WRITE (LU, 99918) IPR(404), PAR(253), PAR(254)
          ENDIF
          IF (IABS(IGBL(8)) .NE. 4) THEN
            IF (IPR(489) + IPR(490) .GT. 0) THEN
              WRITE (LU, 99930) IPR(489) + IPR(490)
            ENDIF
          ENDIF
          IF (IPR(50)  .GT. 0) WRITE (LU, 99966) IPR(50)
          IF (IPR(204) .GT. 0) WRITE (LU, 99965) IPR(204)
          IF (IPR(498) .GT. 0) WRITE (LU, 99907) IPR(498)
          IF (PAR(387) .LT. 1.0) WRITE (LU, 99887) PAR(387)
          IF (IPR(93)  .EQ. 1)
     1        WRITE (LU, 99990) ((TM1(I, J), J = 1, 3), I = 1, 3)
          IF (IPR(139) .EQ. 1) WRITE (LU, 99968) (SHFT(I), I = 1, 3)
          IF (IPR(100) .GT. 0) WRITE (LU, 99989) IPR(100)
          IF (IPR(101) .GT. 0) WRITE (LU, 99987) IPR(101)
          IF (IPR(171) .GT. 0) THEN
            IF (IABS(IGBL(8)) .NE. 4)
     1        WRITE (LU, 99963) PAR(30), IPR(171)
          ENDIF
          IF (IPR(172) .GT. 0) THEN
            IF (IABS(IGBL(8)) .NE. 4)
     1        WRITE (LU, 99754) PAR(30), IPR(172)
          ENDIF
          IF (IPR(102) .GT. 0) WRITE (LU, 99986) IPR(102)
          IF (IPR(103) .GT. 0) WRITE (LU, 99985) IPR(103)
          IF (IPR(401) .GT. 0) WRITE (LU, 99922) IPR(401)
          IF (IPR(402) .GT. 0) WRITE (LU, 99919) IPR(402)
          IF (IPR(471) .NE. 0) WRITE (LU, 99993) IPR(471), IPR(472)
          IF (IGBL(71) .NE. 0) WRITE (LU, 99994) IGBL(71)
          IF (IPR(135) .GT. 0) WRITE (LU, 99971) IPR(135)
          IF (IPR(138) .GT. 0) WRITE (LU, 99969) IPR(138)
          IF (PAR(150) .GT. 0) WRITE (LU, 99941) PAR(150)
          IF (PAR(149) .GT. 0) WRITE (LU, 99926) NINT(PAR(149))
          IF (IPR(126) .GT. 0) WRITE (LU, 99899) IPR(126)
          IF (IPR(429) .GT. 0) WRITE (LU, 99893) IPR(429)
          IF (IPR(405) .GT. 0) WRITE (LU, 99917) IPR(405)
          IF (IPR(149) .GT. 0) WRITE (LU, 99967) IPR(149)
          IF (IPR(494) .GT. 0) WRITE (LU, 99902) IPR(494)
          WRITE (LU, 99953)
        ENDIF
        IF (IGBL(63) .GT. 0 .AND. IGBL(7) .EQ. 1) THEN
          FNLU1 = NAME(3)(1:KNM(3))//'.'//EXTENS(1:KXT)
          KNMXT = KNM(3) + KXT + 1
          IF (FNLU1(1:5) .NE. 'zz123' .AND. IGBL(8) .NE. 0)
     1      WRITE (LU, 99905) FNLU1(1:KNMXT), DTYPE(IABS(IGBL(8)))
          NPAGE = IGBL(49)
          IF (IPR(2) .LT. 0) THEN
            IGBL(67) = 0
            IF (IGBL(70) .EQ. 1) THEN
              WRITE (LU, 99955) NPAGE, NAME(1)(1 : KNM(1)),
     1                                 NAME(1)(1 : KNM(1))
            ELSE
              WRITE (LU, 99855) NPAGE, NAME(1)(1 : KNM(1))
            ENDIF
          ELSE
            WRITE (LU, 99954) NPAGE, NAME(1)(1 : KNM(1)),
     1                               NAME(1)(1 : KNM(1))
          ENDIF
        ENDIF
        IGBL(8) = IABS(IGBL(8))
      ENDIF
   50 IF (LU .EQ. LU7) THEN
        LU = LU6
        GOTO 10
      ENDIF
      IF (IPR(1) .EQ. 1 .OR.
     1    IPR(1) .EQ. 2 .OR.
     2    IPR(1) .EQ. 4 .OR.
     3    IPR(1) .EQ. 5 .OR.
     4    IPR(1) .EQ. 6 .OR.
     5    IPR(1) .EQ. 7) THEN
        IF (IR .EQ. 0) IGBL(1) = 1
      ELSE IF (IPR(1) .EQ. 3 .AND. IGBL(8) .NE. 2) THEN
        READ (LU1, 99964, END = 70, ERR = 70) ICL(1:80)
        BACKSPACE LU1
        IGBL(1) = 1
      ENDIF
C * ERROR RECOVERY FOR AUTO SEQUENCE
   70 IF (IPR(3) .EQ. 1) THEN
        IGBL(5) = LU1
        IGBL(1) = 1
      ENDIF
   80 GOTO 100
   90 IF (IGBL(36) .NE. 0) CALL PLA230 (0)
  100 IF (IGBL(3) .EQ. 36) IGBL(1) = 4
      RETURN
99999 FORMAT ('W: No wavelength given.')
99998 FORMAT ('W: No Cell estimated standard deviation (CESD) given.')
99997 FORMAT ('W: NOMOVE option used.', /,
     1 ':: >>> WARNING: ''CONNECTED INPUT SET'' is assumed ''TRUE'' ',
     2  /,      ':: >>> Network Analysis may be INCORRECT when FALSE')
99996 FORMAT ('W: NOSYMM option used. (No Symmetry applied)')
99995 FORMAT ('E: Maximum residue number exceeded.')
99994 FORMAT ('N: Number of modified (= # ) ATOM labels ',
     1             33('.'),  I5)
99993 FORMAT ('N: Number of Ignored Lines on INPUT ', 38('.'),
     1   I5, /, 10X, 'of which blank in column 1 ', 37('.'), I5)
99992 FORMAT (':: ** Instruction N.O.K. ** :', A, /,
     1 ':: Check also for mistyped ATOM labels and ATOM types')
99991 FORMAT (/, 'Summary and Remarks : N = NOTE, W = WARNING, E ',
     1 '= ERROR', /, 80('='), /)
99990 FORMAT ('N: Input Data following TRNS ',
     1        '[e.g. (CELL/CESD)/SPGR/COORDS/'
     1 ,'UIJ)] have been', /, 4X, 'transformed according to the ',
     2 'specified Cell Transformation Matrix: ', 3(/, 20X, 3F10.5))
99989 FORMAT ('N: Number of deleted ATOMS from input stream ',
     1        29('.'), I5)
99988 FORMAT ('N: DISORDERED structure - ATOMS with Pop. .LT.',
     1 ' 1.0 are not moved or as a group.')
99987 FORMAT ('N: Number of detected and excluded disorder',
     1        ' operations ',14('.'), I5)
99986 FORMAT ('W: Number of valency check faults for H & C ',
     1        30('.'), I5)
99985 FORMAT ('W: Number of unusual bond angle faults ', 35('.'), I5)
99984 FORMAT (/, ':: FATAL attempt to EXCEED the max.ATOMS limit:', I5)
99983 FORMAT (':: U/UIJ/SUIJ/B/BIJ/SBIJ/ label: ', A, /, 4X,
     1 'inconsistent with ATOM label: ', A, /)
99982 FORMAT (':: Error - Not Enough Data Items on Input Line:',
     1        /, 3X, A)
99981 FORMAT (':: Error - Invalid Element Symbol: ', A)
99980 FORMAT (':: Last Line(s) Ignored', A, /)
99979 FORMAT (':: END Statement Executed for this Entry')
99978 FORMAT (//, ':: Unsuitable Keyword/ATOM label : ', A, //,
     1        3X, 'Legal are: C, H999, O(3), FE(77)', /)
99977 FORMAT (//, ':: Label ', A, ' pre-occurred '/)
99976 FORMAT (':: Too many ATOMS specified, Max.Nr:', I5)
99975 FORMAT (':: FVAR - error')
99974 FORMAT (':: Population parameter OVERFLOW')
99973 FORMAT ('N: SHELX-style data input.')
99972 FORMAT (':: Instruction ', A, ' NOT allowed at this point')
99971 FORMAT ('W: Number of unusual anisotropic displacement ',
     1        'parameters ', 17('.'), I5)
99970 FORMAT (':: * The PLOT instructions should be given after the',
     1 ' execution of ', /, 4X, 'the -CALC INTRA- instruction')
99969 FORMAT ('W:', I5, ' Times MOL-list overflow. Results ????')
99968 FORMAT ('N: INPUT data (COORDINATES) have been transformed',
     1 /, 5X, 'according to additive coordinate shift vector: ', /,
     2 16X, 3F10.5)
99967 FORMAT ('W: array OVERFLOW in INTER-mode (Results INCOMPLETE)',
     1 ' Code nnmmkk =', I8)
99966 FORMAT ('N: Number of positions fixed with TRNS by user ',
     1        27('.'), I5)
99965 FORMAT ('N: Number of moved primary input atoms: ',34('.'), I5)
99964 FORMAT (A)
99963 FORMAT ('N: Number of Unspecified Non-H Displacement ',
     1        'Parameters set to U =', F5.2, 1X, 3('.'), I5)
99754 FORMAT ('N: Number of Unspecified     H Displacement ',
     1        'Parameters set to U =', F5.2, 1X, 3('.'), I5)
99962 FORMAT (//, 58X, 11('='), /, 57('*'), ' N O T I C E ', 50('*'),
     1 /, 58X, 11('='), //, '- PLATON Reference : Spek, A.L. (2003),',
     2 ' J.Appl.Cryst. 36, 7-13', //, '- Output Values (Esd) may have',
     3 ' been set to 99, 999 or 9999 to Avoid Format Overflow', //,
     4 '- Derived Parameter SU''s (= Esd''s) may be Incorrect in',
     5 ' Cases where Covariances in the Atom Parameters should have',
     6 ' been taken', /, '  into Account (e.g. Those Involving Atoms',
     7 ' That were Refined with Constraints)', //, '- ROUNDING, in',
     8 ' particular of the Input Coordinate Data, may give deviating',
     9 ' values for derived geometry parameters.', /, '  However,',
     * ' differences should be within the associated esd-range.', //,
     1 '- PLATON is NOT a Finished Program. The Implementation of',
     2 ' Additional Options is Planned. Some of the More Advanced', /,
     3 2X, 'Features are Experimental and may Contain Loose Ends.',//,
     4 '- The Communication of Glitches Encountered will be',
     5 ' Appreciated: E-mail: a.l.spek@chem.uu.nl', //,
     6 '- Recent versions of PLATON may be obtained by',
     7 ' Anonymous FTP from xraysoft.chem.uu.nl', //, '- More INFO',
     8 ' can be found on http://www.cryst.chem.uu.nl/platon/', //)
99961 FORMAT (':: Following data will be skipped until End-Of-',
     1        'Section')
99960 FORMAT (':: Specified  RESIDUE number:', I3, ' NOT present')
99959 FORMAT ('W: Structure contains', I3,' isolated H-atom(s).')
99958 FORMAT ('W: Structure contains', I3, ' Intra/Inter contacts',
     1        ' < Sum(vdWrad) ', F5.2, ' A (max ', F5.2,')')
99957 FORMAT (':: TRNS (FIX) instruction N.O.K.')
99956 FORMAT ('N: No S.U.''s (esd) on observed/calculated parameters.')
99955 FORMAT (':: NORMAL END of PLATON :', I6, ' Pages on:', /,
     1        ':: ', A, '.lis (ASCII, 132 Characters Wide)', /,
     2        ':: ', A, '.lps (PostScript Version of .lis)', /)
99954 FORMAT (':: ABNORMAL END of PLATON :', I6, ' Pages on:', /,
     1        A, '.lis ASCII)', /, A, '.lps (PostScript)', /)
99953 FORMAT (/, 80('='), /)
99952 FORMAT ('W: Unit cell contains non-integral number of atoms',
     1 ' (please check).')
99951 FORMAT ('N: ADDSYM finds additional (pseudo)symmetry in the',
     1 ' structure (please check!)')
99950 FORMAT ('N: No Explicit space group name specified')
99949 FORMAT (':: Subkeyword NOT Acceptable')
99948 FORMAT ('N: Maximum Residue Number Reduced',
     1        ' (Round ARU to 0.1 units)')
99947 FORMAT ('E: Translation code [', 3I3, '] out-of-range -4:4',
     1        ' for ', A)
99946 FORMAT (':: Void-array overflow, Raise NPVD to value > ', I7)
99943 FORMAT (':: Not enough storage available to handle OVERLAP')
99942 FORMAT (':: Too many axes found. Rerun with obl. ang. <', F4.1)
99941 FORMAT ('N: Total Potential Solvent Accessible Void Vol ',
     1            18('.'), F8.1, ' Ang^3')
99940 FORMAT (':: Too many independent solvent areas')
99939 FORMAT (':: STOP LMX/PLA091')
99938 FORMAT (':: Overflow in VOID/SOLV routine (NP1)')
99937 FORMAT (':: No SYMM matrix allowed with TRNS option')
99935 FORMAT (':: ARU-code not representable (out-of-range)')
99934 FORMAT (':: CALC TMA not allowed after previous CALC INTRA')
99933 FORMAT ('N: No-Hydrogen atoms in this structure')
99932 FORMAT ('E: Too many FVAR - parameters (increase NP25)')
99931 FORMAT (':: No CALC INTRA or GEOM after previous (implicit) ',
     1        ' CALC INTRA allowed')
99930 FORMAT ('N: Number of Isotropic Non-H Atoms ', 39('.'), I5)
99929 FORMAT ('E: Non-Recoverable problem in routine PLA', I3.3)
99928 FORMAT (':: CALC SOLV/VOID incompatible with ANGSTROM mode')
99927 FORMAT ('N: Maximum allowed number of residues reduced')
99926 FORMAT ('N: Electron Count / Cell =', I7,
     1 ' - To be included in D(calc), F000 & Mol.Wght.')
99925 FORMAT ('W: Look carefully at the approximate inversion',
     1        ' symmetry reported by ADDSYM')
99924 FORMAT ('W: Structure contains', I3, ' Intra H..H contacts',
     1        ' < Sum(vdW-rad) ', F5.2, ' A (max ', F5.2,')')
99923 FORMAT ('W: Negative Distance Detected (i.e. Origin Outside ',
     1        'Xtal)')
99922 FORMAT ('W: Number of Carbon Atoms with missing H-atoms ',
     1         27('.'), I5)
99921 FORMAT ('E: No Mu-value provided')
99920 FORMAT ('E: Unknown Element Type on SFAC line, Fatal')
99919 FORMAT ('W: Number of (Carbon) Atoms with no sp(x) ',
     1        'assignment ', 21('.'), I5)
99918 FORMAT ('W: Structure contains', I3, ' Inter H..H contacts',
     1        ' < Sum(vdW-rad) ', F5.2, ' A (max ', F5.2,')')
99917 FORMAT ('N: Number of Non-HBonded D-H atoms ', 39('.'), I5)
99916 FORMAT ('W: No Valid Direction Cosine or Psi-values Found', /)
99915 FORMAT ('W: No Valid Psi-scans Found')
99914 FORMAT ('W: No Reflections Supplied !', /)
99913 FORMAT ('E: I Can''t accept transformations on hkl with a',
     1           ' NEGATIVE Det. ')
99912 FORMAT ('E: Unknown ELEMENT Type on SFAC')
99911 FORMAT ('E: No Valid Atoms found on Input File')
99910 FORMAT ('E: No ', A,'.hkl or ', A,'.fcf Reflection file present')
99909 FORMAT ('E: No ', A,'.hkl Reflection file present', /)
99907 FORMAT ('E: Something wrong with', I5,
     1        ' input U/Uij(s) (incomplete?)', /)
99906 FORMAT ('E: SFAC data incomplete or missing on shelx.res/ins file'
     1         , ' for: ', A, /)
99905 FORMAT (':: Input Data from File ', A, ' - Data Type ', A, /)
99904 FORMAT (':: No proper wavelength (Ag,Mo,Cu) recognised (',
     1        F8.5, ')')
99903 FORMAT ('W: Look carefully at the (approximate) Translation',
     1        ' symmetry reported by ADDSYM')
99902 FORMAT ('W: Number of out of range ARU-coding problems =', I5, /,
     1        '   Analysis of Inter Contacts may be incomplete')
99901 FORMAT ('E: Void TOO LARGE to be Interesting; Search Aborted', /,
     1            '(at own risk: SET IPR 491 1000000 before SQUEEZE)')
99900 FORMAT (/, 'E: Scratch Array Overrun in PLA152 (Fatal)', /,
     1        '    Use larger program version i.e. NP1 ',
     2        '> ', I9, /)
99899 FORMAT (/, 'W: # MAXPATH EXCEEDED IN R/S-Assignment Routine =',
     1        I3)
99898 FORMAT (/, 'E: Insufficient Data on UIJ/SUIJ - CIF-Input for ',
     1        A, /)
99897 FORMAT (':: EXIT Statement Executed for: ', A)
99896 FORMAT (/, 'E: Insufficient Data on ATOM - CIF-Input for ',
     1        A, /)
99895 FORMAT (/, 'E: Symmetry Problem in PLA081', /)
99894 FORMAT (/ )
99893 FORMAT ('N: Number of Unrecognized Keywords ', 39('.'), I5)
99892 FORMAT ('E: SYMM-LABEL PACK PROBLEM')
99891 FORMAT ('E: No Reflection Data Available')
99890 FORMAT (80('-'))
99889 FORMAT ('W: Structure contains', I3,' isolated O-atom(s).')
99888 FORMAT ('E: No Direction Cosines or Psi found on Reflection Data')
99887 FORMAT ('W: Low density (check!) of ', 38('.'), F8.3, ' gcm-3')
99886 FORMAT ('W: Coordinates do not form a Connected Set')
99885 FORMAT ('E: Label Alias Overflow: TRY: SET IGBL(61) 1')
99855 FORMAT (':: NORMAL END of PLATON :', I6, ' Pages on FILE ',
     1        A, '.lis', /)
99854 FORMAT (A, 2F10.0, 2A)
99853 FORMAT (//, 'E: READ ERROR - FATAL', /)
99852 FORMAT ('E: NSP-Problem in PLA029: Nr species too large')
99851 FORMAT (A, 2I10)
99850 FORMAT ('W: Incorrect Number of Numerical Arguments on TRNS/TRMX')
99849 FORMAT ('E: Check data type (cif,res,fdat,spf,res) of the input')
99848 FORMAT (/, ':: CELL PROBLEM')
99847 FORMAT (/, 'CIF-LINE LONGER THAN 2048 CHARACTERS')
99846 FORMAT (/, 'CIF-LOOP PROBLEM')
      END
      SUBROUTINE PLA004 (MODE)
      PARAMETER (NP4=9,NP10=16,NP12=600,NP13=500,NP17=99,NP22=256,
     1 NP38=125,NP39=30,NP45=2048)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /Q/ ICL, IFL(NP17)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /FNAME/ KNM(8), KXT, KNM16
      COMMON /NAMES/ NAME(8), EXTENS, PROGNM, FNLU1, FNLU16, RDTYPE
      CHARACTER NAME*80, EXTENS*9, PROGNM*28, FNLU1*80, FNLU16*80,
     1          RDTYPE*7
      COMMON /PATHS/ PLAPATH, BROWSER, CGETENV
      CHARACTER PLAPATH*255, BROWSER*255, CGETENV*255
      EXTERNAL SYSTEM
      IF (IGBL(36) * IGBL(66) * IGBL(32) .NE. 0) CALL PLA298 (0)
C * OUTPUT-FILE TYPE
C *  1 - OMEGA,  2 - MOGLI, 3 - EUCLID, 4 - CSD, 7 - PDB
C * 10 - SQUEEZE
C * -2 - SHELXL
   10 IF (IGBL(3) .EQ. 1 .OR. IGBL(22) .NE. 0)
     1        CLOSE (LU2, STATUS = 'DELETE', ERR = 20)
   20 LU   = LU6
      IEND = 1
      IF (IGBL(63) .GT. 0) IEND = 2
      DO 30 I = 1, IEND
        IF (I .EQ. 2) LU = LU7
        IF (IGBL(31) .EQ. 1) THEN
          IF (IPR(430) .EQ. 0) THEN
            WRITE (LU, 99997) NAME(5)(1:KNM(5))
          ELSE
          ENDIF
        ELSE IF (IGBL(31) .EQ. 2) THEN
          WRITE (LU, 99996) NAME(2)(1:KNM(2)), NAME(2)(1:KNM(2))
        ELSE IF (IGBL(31) .EQ. 3) THEN
          WRITE (LU, 99995) NAME(3)(1:KNM(3))
        ELSE IF (IGBL(31) .EQ. -2) THEN
          WRITE (LU, 99988) NAME(7)(1:KNM(7))
        ELSE IF (IGBL(31) .EQ. 4) THEN
          WRITE (LU, 99994) NAME(6)(1:KNM(6))
        ELSE IF (IGBL(31) .EQ. 5) THEN
          WRITE (LU, 99985) NAME(8)(1:KNM(8))
        ELSE IF (IGBL(31) .EQ. 6) THEN
          WRITE (LU, 99988) NAME(7)(1:KNM(7))
        ELSE IF (IGBL(31) .EQ. 7) THEN
          WRITE (LU, 99977) NAME(3)(1:KNM(3))
        ELSE IF (IGBL(31) .EQ. 8) THEN
           WRITE (LU, 99990) NAME(1)(1:KNM(1))
        ELSE IF (IGBL(31) .EQ. 9) THEN
          WRITE (LU, 99991) NAME(1)(1:KNM(1))
        ELSE IF (IGBL(31) .EQ. 10) THEN
          WRITE (LU, 99976) NAME(1)(1:KNM(1)),
     1                      NAME(1)(1:KNM(1))
        ENDIF
   30 CONTINUE
      IF (MODE .EQ. 0) THEN
C * STOP AND CLOSE GRAPHICS (IF ANY)
        XGGIP = -999.0
        PCAL  =  0.0
        PLOTS =  0.0
        CALL GGIP (XGGIP, PCAL, PLOTS, -5)
C * CLOSE 'ALERT' FILE
        CLOSE (LU20, STATUS = 'DELETE', ERR = 10)
      ENDIF
      CLOSE (UNIT = LU29, STATUS = 'DELETE')
      IF (IGBL(92) .GT. 0) THEN
        IF (IGBL(93) .GE. 0 .AND. IGBL(31) .NE. 8)
     1    WRITE (LU6, 99992) NAME(1)(1:KNM(1))
        IF (IGBL(92) .EQ. 2) THEN
          WRITE (LU6, 99993) NAME(1)(1:KNM(1))
        ELSE
          IF (IGBL(12) .EQ. 0) CLOSE (LU12, STATUS = 'DELETE')
        ENDIF
        IF (IPR(431) .EQ. -1 .OR. IPR(431) .EQ. -2) THEN
          IF (IGBL(13) .EQ. 0) CLOSE (LU13, STATUS = 'DELETE')
        ENDIF
      ELSE
        IF (IGBL(12) .EQ. 0) CLOSE (LU12, STATUS = 'DELETE', ERR = 40)
   40   IF (IGBL(13) .EQ. 0) CLOSE (LU13, STATUS = 'DELETE', ERR = 50)
      ENDIF
   50 CLOSE (LU14, STATUS = 'DELETE', ERR = 60)
   60 IF (IGBL(36) .GT. 0) THEN
        LU6 = 6
        CALL PLA230 (1)
        WRITE (LU6, 99971) NAME(1)(1:KNM(1))
      ENDIF
      IF (IGBL(22) .LT. 0) THEN
        LU6 = 6
        WRITE (LU6, 99962) NAME(1)(1:KNM(1))
      ENDIF
      IF (IGBL(16) .EQ. 0) CLOSE (LU21, STATUS = 'DELETE', ERR = 70)
   70 IF (IPR(326) .EQ. 1 .AND. IPR(198) .GT. 0 .AND.
     1    IPR(189) .EQ. 2 .AND. IPR(210) .NE. 1) THEN
        WRITE (LU6, 99989) NAME(1)(1:KNM(1))
      ELSE
        CLOSE (LU15, STATUS = 'DELETE', ERR = 80)
      ENDIF
   80 IF (IGBL(18) .EQ. 1 .AND. IPR(408) .LT. 1
     1    .AND. IGBL(3) .NE. 34 .AND. IGBL(3) .NE. 1) THEN
        WRITE (LU6, 99966) NAME(1)(1:KNM(1)), IPR(378)
      ELSE IF (IGBL(18) .EQ. 2) THEN
        WRITE (LU6, 99965) NAME(1)(1:KNM(1))
      ENDIF
      IF (IPR(210) .EQ. 1) THEN
        WRITE (LU6, 99998) NAME(1)(1:KNM(1))
      ELSE IF (IPR(210) .EQ. -1) THEN
        WRITE (LU6, 99987) NAME(4)(1:KNM(4))
      ELSE IF (IPR(210) .EQ. -2) THEN
        WRITE (LU6, 99986) NAME(1)(1:KNM(1))
      ELSE IF (IPR(2) .EQ. -4) THEN
        WRITE (LU6, 99972) NAME(1)(1:KNM(1))
      ELSE IF (IPR(2) .EQ. -5) THEN
        WRITE (LU6, 99979) NAME(1)(1:KNM(1))
      ELSE IF (IPR(2) .EQ. -6 .AND. IPR(432) .GT. 0) THEN
        WRITE (LU6, 99980) NAME(4)(1:KNM(4))
      ELSE IF (IPR(2) .EQ. -7 .AND. IPR(432) .GT. 0) THEN
        WRITE (LU6, 99982) NAME(1)(1:KNM(1))
      ELSE IF (IPR(2) .EQ. -8 .AND. IPR(432) .GT. 0) THEN
        WRITE (LU6, 99983) NAME(1)(1:KNM(1))
      ELSE IF (IPR(2) .EQ. -9) THEN
        WRITE (LU6, 99978) NAME(1)(1:KNM(1))
      ELSE IF (IPR(2) .EQ. -10) THEN
        WRITE (LU6, 99963) NAME(1)(1:KNM(1))
      ELSE IF (IPR(2) .EQ. -11) THEN
        WRITE (LU6, 99964) NAME(1)(1:KNM(1))
      ELSE IF (IPR(2) .EQ. -12) THEN
        WRITE (LU6, 99960) NAME(1)(1:KNM(1))//'.rp1'
      ELSE IF (IPR(2) .EQ. -13 .AND. IPR(525) .EQ. 0) THEN
        WRITE (LU6, 99984) NAME(1)(1:KNM(1))
      ELSE IF (((IPR(2) .EQ. -14 .AND. IPR(408) .NE. 2) .OR.
     1          IGBL(17) .EQ. 1) .AND. IGBL(22) .EQ. 0) THEN
        WRITE (LU6, 99981) NAME(1)(1:KNM(1)), IPR(377)
      ELSE IF (IPR(2) .EQ. -15) THEN
        WRITE (LU6, 99970) NAME(1)(1:KNM(1))
      ELSE IF (IPR(2) .EQ. -16 .AND. IPR(384) .GT. 0) THEN
        WRITE (LU6, 99967) NAME(1)(1:KNM(1))
      ELSE
        CLOSE (LU17, STATUS = 'DELETE', ERR = 90)
      ENDIF
   90 CLOSE (LU1)
      IF (IGBL(21) .EQ. 0) CLOSE (LU23, STATUS = 'DELETE', ERR = 100)
      CLOSE (LU24, STATUS = 'DELETE')
  100 IF (IGBL(4)  .EQ. 0) THEN
        CLOSE (LU25, STATUS = 'DELETE', ERR = 110)
      ELSE
        WRITE (LU6, 99974) NAME(2)(1:KNM(2))
      ENDIF
  110 IF (IGBL(20) .EQ. 0) THEN
        IF (IGBL(26) .EQ. 0) THEN
          CLOSE (LU26, STATUS = 'DELETE', ERR = 120)
        ELSE
          CALL PLUT29 (-1, ICL, NQ1, 0)
          WRITE (LU6, 99975) NAME(1)(1:KNM(1))
        ENDIF
      ENDIF
  120 IF (IGBL(98) .NE. 0) WRITE (LU6, 99999) NAME(1)(1:KNM(1))
      IF (IGBL(11) .NE. 0) WRITE (LU6, 99969) NAME(1)(1:KNM(1))
      IF (IPR(123) .EQ. 0 .AND. ((IGBL(7) .EQ. 1 .AND. IGBL(3)  .EQ. 8)
     1   .OR. IGBL(63) .EQ. 0 .OR. IGBL(23) .EQ. 17 .OR.
     2        IGBL(23) .EQ. 18 .OR. IGBL(23) .EQ. 19)) THEN
        CLOSE (LU7, STATUS = 'DELETE', ERR = 150)
      ELSE IF (IGBL(70) .EQ. 1 .AND. MODE .EQ. 0) THEN
        IF (IGBL(7) .EQ. 1) THEN
          CALL GEN108 (LU7, 0)
          CLOSE  (LU1)
          READ (LU7, 99961, END = 140) PRBUF
          CALL GEN108 (LU7, 0)
          FNLU1  = NAME(1)(1:KNM(1)) //'.lps'
          OPEN (UNIT = LU1,  FILE = FNLU1, STATUS = 'UNKNOWN')
          CALL GEN089 (LU7, LU1, IGBL(49), IGBL(102))
          GOTO 150
  140     CLOSE (LU7, STATUS = 'DELETE')
        ENDIF
      ENDIF
  150 IF (IGBL(27) .EQ. 1) THEN
        WRITE (LU6, 99973) NAME(1)(1:KNM(1))
      ELSE
        CLOSE (LU27, STATUS = 'DELETE', ERR = 160)
      ENDIF
  160 IF (IPR(516) .EQ. 1) THEN
        CLOSE (LU17)
        OPEN (LU61, FILE = NAME(1)(1:KNM(1))//'.hkp',
     1        STATUS = 'UNKNOWN')
        OPEN (LU62, FILE = NAME(1)(1:KNM(1))//'_trm.fcf',
     1        STATUS = 'UNKNOWN')
  170   READ  (LU61, 99961, END = 180) LINE
        WRITE (LU62, 99961) LINE
        GOTO 170
  180   CLOSE (LU61, STATUS = 'DELETE')
        CLOSE (LU62)
        CALL SYSTEM
     1    (PLAPATH(1:IGBL(80))//' -T '//NAME(1)(1:KNM(1))//'_trm.fcf')
      ENDIF
      IF (IPR(580) .LT. 0)  THEN
        IF (IPR(580) .EQ. -1) THEN
          WRITE (LU6, 99959) NAME(1)(1:KNM(1))
        ELSE
          WRITE (LU6, 99958) NAME(1)(1:KNM(1))
        ENDIF
      ENDIF
      IF (MODE .NE. 0) THEN
        CLOSE (LU7, STATUS = 'DELETE')
        LU1     = 1
        LINE    = ICL(5:80)
        IGBL(7) = 0
        IGBL(8) = 0
      ELSE
        STOP
      ENDIF
      RETURN
99999 FORMAT (/,
     1        ':: POV-Ray File on :', A, '.pov')
99998 FORMAT (':: SQUEEZE  out on :', A, '.hkp')
99997 FORMAT (':: OMEGA File   on :', A, '.ome')
99996 FORMAT (':: MOGLI Files  on :', A, '.dge')
99995 FORMAT (':: SPF File     on :', A, '.eld')
99994 FORMAT (':: CSD-QUE      on :', A, '.que')
99993 FORMAT (':: PUBL. Tables on :', A, '.pub')
99992 FORMAT (':: SUPP. Mat.   on :', A, '.sup')
99991 FORMAT (':: CIF/CSD-File on :', A, '.csd')
99990 FORMAT (':: CIF/ACC-File on :', A, '.acc')
99989 FORMAT (':: SAR-File     on :', A, '.sar')
99988 FORMAT (':: SHELXL Style Output on :', A, '.res')
99987 FORMAT (':: FCF-CIF  hkl on :', A, '.hkp')
99986 FORMAT (':: DELABS   hkl on :', A, '.hkp')
99985 FORMAT (':: SPGR.PAR     on :', A, '.par')
99984 FORMAT (':: HKLF3.HKL    on :', A, '.hkp')
99983 FORMAT (':: ABSGAUSS hkl on :', A, '.hkp')
99982 FORMAT (':: ABSTOMPA hkl on :', A, '.hkp')
99981 FORMAT (':: ASYM     hkl on :', A, '.hkp (# refl. =', I7, ')')
99980 FORMAT (':: ABSPSI   hkl on :', A, '.hkp')
99979 FORMAT (':: ABSSPHER hkl on :', A, '.hkp')
99978 FORMAT (':: PSIDIR   hkl on :', A, '.hkp')
99977 FORMAT (':: PDB-FILE out on :', A, '.pdb')
99976 FORMAT (':: SQUEEZE  xyz on :', A, '.sqz', /,
     1        ':: SQUEEZE  CIF on :', A, '.sqf')
99975 FORMAT (/, ':: Modified SHELX-File on ', A, '.new')
99974 FORMAT (/,
     1        ':: MOGLI   File on :', A, '.dge')
99973 FORMAT (/,
     1        ':: Journal File on :', A, '.pjn', //,
     2        ':: Normal End of PLATON/PLUTON RUN.')
99972 FORMAT (':: MULABS   hkl on :', A, '.hkp')
99971 FORMAT (':: CHECK    out on :', A, '.chk')
99970 FORMAT (':: HKLTRANS hkl on :', A, '.hkp')
99969 FORMAT (':: RASMOL(pdb)  on :', A, '.ras')
99967 FORMAT (':: HKLF4.HKL    on :', A, '.hkp')
99966 FORMAT (':: ASYM    -hkl on :', A, '.hks (# refl. =', I7, ')')
99965 FORMAT (':: POWDER   cpi on :', A, '.cpi')
99964 FORMAT (':: HKLF5.HKL    on :', A, '.hkp')
99963 FORMAT (':: SHXABS   hkl on :', A, '.hkp')
99962 FORMAT (':: FCF-CHK  out on :', A, '.fck')
99961 FORMAT (A)
99960 FORMAT (':: Expanded coordinate set (shelx-style) on :', A)
99959 FORMAT (':: Fourier3D    on :', A, '.fou')
99958 FORMAT (':: Solv3D       on :', A, '.slv')
      END
      SUBROUTINE PLA005 (MODE, LINE, ICL, LRT)
      PARAMETER (NP12=600,NP13=500,NP17=99,NP38=125,NP39=30)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /FNAME/ KNM(8), KXT, KNM16
      COMMON /NAMES/ NAME(8), EXTENS, PROGNM, FNLU1, FNLU16, RDTYPE
      CHARACTER NAME*80, EXTENS*9, PROGNM*28, FNLU1*80, FNLU16*80,
     1          RDTYPE*7
      CHARACTER IDM*(80), LINE*(*), ICL*(*)
C * MODE = -1
C * MODE =  0 - PLATON
C * MODE =  1 - PLUTON
C * GET ARGUMENTS & FLAGS
      IF (MODE .LT. 0) THEN
        J0 = 0
C * FIRST CHECK FOR PROGRAM NAME ALIASES
        DO 10 J = J0, IARGC()
          CALL GETARG (J, IDM)
          IF (LRT .EQ. 0) THEN
            LRT = 1
            IF (INDEX (IDM, 'platon') .NE. 0) THEN
              GOTO 10
            ELSE IF (INDEX (IDM, 'pluton') .NE. 0) THEN
              IDM = '-p'
            ELSE IF (INDEX (IDM, 'cifchk') .NE. 0) THEN
              IDM = '-u'
            ELSE IF (INDEX (IDM, 's ') .NE. 0) THEN
              IDM = '-s'
            ELSE IF (INDEX (IDM, 'helena ') .NE. 0) THEN
              IDM = '-k'
c SIMULATE -Y option when called as 'stidy'
              IDM = '-Y'
            ENDIF
          ENDIF
C * ADP-ORTEP MODE
          IF (IDM(1:2)      .EQ. '-a') THEN
            IGBL(3) = 3
C * CALC GEOM CSD
          ELSE IF (IDM(1:2) .EQ. '-b') THEN
            IGBL(3) = 11
C * CALC MODE
          ELSE IF (IDM(1:2) .EQ. '-c') THEN
            IGBL(3) = 2
C * DELABS - MODE
          ELSE IF (IDM(1:2) .EQ. '-d') THEN
            IGBL(3) = 6
C * MULABS - MODE
          ELSE IF (IDM(1:2) .EQ. '-e') THEN
            IGBL(3) = 18
C * HFIX
          ELSE IF (IDM(1:2) .EQ. '-f') THEN
            IGBL(3) = 13
C * CALC GEOM SHELX
          ELSE IF (IDM(1:2) .EQ. '-g') THEN
            IGBL(3) = 24
            IGBL(25) = 0
C * HKL CALC
          ELSE IF (IDM(1:2) .EQ. '-h') THEN
            IGBL(3) = 10
C * PATTERSON PLOT
          ELSE IF (IDM(1:2) .EQ. '-i') THEN
            IGBL(3) = 22
C * CALC GEOM EUCLID
          ELSE IF (IDM(1:2) .EQ. '-j') THEN
            IGBL(3) = 23
            IGBL(25) = 0
C * HELENA - MODE
          ELSE IF (IDM(1:2) .EQ. '-k') THEN
            IGBL(3) = 15
            NAME(1) = 'helena'
            NAME(2) = 'shelx'
            NAME(5) = 'abspsi'
            KNM(1)  = 6
            KNM(2)  = 5
            KNM(5)  = 6
            EXTENS  = 'cad'
            KXT     = 3
C * ASYM AVF VIEW
          ELSE IF (IDM(1:2) .EQ. '-l') THEN
            IGBL(3) = 17
C * ADDSYM - MODE
          ELSE IF (IDM(1:2) .EQ. '-m') THEN
            IGBL(3) = 4
C * ADDSYM SHELX - MODE
          ELSE IF (IDM(1:2) .EQ. '-n') THEN
            IGBL(3) = 16
C * MENU OFF
          ELSE IF (IDM(1:2) .EQ. '-o') THEN
            IGBL(25) = 0
C * PLUTON MODE
          ELSE IF (IDM(1:2) .EQ. '-p') THEN
            IGBL(3) = 8
C * SQUEEZE - MODE
          ELSE IF (IDM(1:2) .EQ. '-q') THEN
            IGBL(3) = 5
C * RENAME MODE
          ELSE IF (IDM(1:2) .EQ. '-r') THEN
            IGBL(3) = 12
C * S - MODE
          ELSE IF (IDM(1:2) .EQ. '-s') THEN
            IGBL(3) = 14
            NAME(1) = 's'
            KNM(1)  = 1
            GOTO 20
C * TABLE  - MODE
          ELSE IF (IDM(1:2) .EQ. '-t') THEN
            IGBL(3) = 7
C * IUCR MODE
          ELSE IF (IDM(1:2) .EQ. '-u') THEN
            IPR(119) = 0
            IGBL(3)  = 1
            IGBL(70) = 0
C * SOLV MODE
          ELSE IF (IDM(1:2) .EQ. '-v') THEN
            IGBL(3) = 9
C * DIFFERENCE MAP
          ELSE IF (IDM(1:2) .EQ. '-w') THEN
            IGBL(3) = 19
C * FO MAP
          ELSE IF (IDM(1:2) .EQ. '-x') THEN
            IGBL(3) = 20
C * SQUEEZE MAP
          ELSE IF (IDM(1:2) .EQ. '-y') THEN
            IGBL(3) = 21
C * WRITE IDENT
          ELSE IF (IDM(1:2) .EQ. '-z') THEN
            WRITE (LU6, '(''PLATON-Version='', I10)') IGBL(9)
            STOP
C * PLUTON ANIS
          ELSE IF (IDM(1:2) .EQ. '-A') THEN
            IGBL(3) = 26
C * TABL ACC
          ELSE IF (IDM(1:2) .EQ. '-C') THEN
            IGBL(3) = 35
C * AUTOMOLFIT
          ELSE IF (IDM(1:2) .EQ. '-I') THEN
            IGBL(3)  = 41
            IGBL(25) = 0
            IGBL(32) = 0
C * SILENT S NQA - MODE
          ELSE IF (IDM(1:2) .EQ. '-F') THEN
            IGBL(50) = 2
            IGBL(3)  = 14
            NAME(1)  = 's'
            KNM(1)   = 1
            GOTO 20
C * CALC KPI
          ELSE IF (IDM(1:2) .EQ. '-K') THEN
            IGBL(3)  = 36
            IGBL(25) = 0
C * TWINROTMAT (INTERACTIVE)
          ELSE IF (IDM(1:2) .EQ. '-L') THEN
            IGBL(3)  = 40
C * TWINROTMAT (FILTER MODE)
          ELSE IF (IDM(1:2) .EQ. '-M') THEN
            IGBL(3)  = 37
            IGBL(25) = 0
C * ADDSYM EQUAL SHELX - MODE
          ELSE IF (IDM(1:2) .EQ. '-N') THEN
            IGBL(3) = 38
C * PLOT ADP PS
          ELSE IF (IDM(1:2) .EQ. '-O') THEN
            IGBL(25) = 0
            IGBL(3)  = 28
C * HKL2POWDER IOBS
          ELSE IF (IDM(1:2) .EQ. '-P') THEN
            IGBL(3) = 29
C * POWDER ICALC (POSTSCRIPT + CPI)
          ELSE IF (IDM(1:2) .EQ. '-Q') THEN
            IGBL(3) = 31
C * RENUM ==> SHELX
          ELSE IF (IDM(1:2) .EQ. '-R') THEN
            IGBL(3) = 27
C * CIF2RES & FCF2HKL
          ELSE IF (IDM(1:2) .EQ. '-S') THEN
            IGBL(3) = 25
C * TWINROTMAT (RL-PLOT)
          ELSE IF (IDM(1:2) .EQ. '-T') THEN
            IGBL(3) = 30
C * IUCR MODE (without VALIDATION DOC)
          ELSE IF (IDM(1:2) .EQ. '-U') THEN
            IGBL(3)  = 1
            IGBL(83) = 0
            IGBL(70) = 0
C * FCF-VALIDATION (LAUE)
          ELSE IF (IDM(1:2) .EQ. '-V') THEN
            IGBL(3)  = 33
C * FCF-VALIDATION (BIJVOET)
          ELSE IF (IDM(1:2) .EQ. '-W') THEN
            IGBL(3)  = 34
            IGBL(70) = 0
C * SHX86
          ELSE IF (IDM(1:2) .EQ. '-X') THEN
            IGBL(3) = 32
C * STIDY
          ELSE IF (IDM(1:2) .EQ. '-Y') THEN
            IGBL(3) = 39
C * CATCH OTHER
          ELSE IF (IDM(1:1) .EQ. '-') THEN
            IGBL(8) = 1
            LINE    = 'zz12345.zzz'
            LRT     = 2
          ELSE
            LINE = IDM
            LRT  = 2
          ENDIF
   10   CONTINUE
      ELSE
        IF (IGBL(3) .NE. 0) CALL GEN038 (ICL, 1, 80)
        IF (IGBL(3) .EQ. 1) THEN
          IF (IGBL(19) .NE. 0) THEN
            IF (IABS(IGBL(8)) .EQ. 3 .OR. IABS(IGBL(8)) .EQ. 4) THEN
              ICL      = 'VALID'
              IGBL(45) = 1
              CALL GEN108 (LU3, 0)
            ELSE
              WRITE (6,
     1   '('' ==== >>> Cannot do -u !!! - CIF not Recognized'', /)')
              CALL PLA004 (0)
            ENDIF
          ELSE
            WRITE (6,
     1   '('' ==== >>> Cannot do -u !!! - no check.def found'', /)')
          ENDIF
        ELSE IF (IGBL(3) .EQ. 2) THEN
          ICL      = 'CALC'
          IGBL(45) = 1
          CALL GEN108 (LU3, 0)
        ELSE IF (IGBL(3) .EQ. 3 .OR. IGBL(3) .EQ. 28) THEN
          ICL = 'PLOT ADP COLOR'
          IGBL(45) = 1
          IPR(308) = 2
          CALL GEN108 (LU3, 0)
        ELSE IF (IGBL(3) .EQ. 4) THEN
          ICL = 'CALC ADDSYM'
        ELSE IF (IGBL(3) .EQ. 5) THEN
          ICL = 'CALC SQUEEZE'
        ELSE IF (IGBL(3) .EQ. 6) THEN
          ICL = 'CALC DELABS'
        ELSE IF (IGBL(3) .EQ. 7) THEN
          ICL = 'TABLE'
        ELSE IF (IGBL(3) .EQ. 9) THEN
          ICL = 'CALC SOLV'
        ELSE IF (IGBL(3) .EQ. 10) THEN
          ICL = 'ASYM GENERATE'
        ELSE IF (IGBL(3) .EQ. 11) THEN
          ICL = 'CALC GEOM CSD'
        ELSE IF (IGBL(3) .EQ. 16) THEN
          ICL = 'CALC ADDSYM SHELX'
        ELSE IF (IGBL(3) .EQ. 17) THEN
          ICL = 'ASYM AVF VIEW'
        ELSE IF (IGBL(3) .EQ. 18) THEN
          ICL = 'MULABS'
        ELSE IF (IGBL(3) .EQ. 19) THEN
          PAR(274) = 0.0
          PAR(275) = 0.0
          PAR(276) = 0.0
          ICL      = 'CONTOUR DI TN'
        ELSE IF (IGBL(3) .EQ. 20) THEN
          PAR(274) = 0.0
          PAR(275) = 0.0
          PAR(276) = 0.0
          ICL      = 'CONTOUR FO TN'
        ELSE IF (IGBL(3) .EQ. 21) THEN
          PAR(274) = 0.0
          PAR(275) = 0.0
          PAR(276) = 0.0
          ICL      = 'CONTOUR SQ TN'
        ELSE IF (IGBL(3) .EQ. 22) THEN
          PAR(274) = 0.0
          PAR(275) = 0.0
          PAR(276) = 0.0
          ICL      = 'CONTOUR PT TN'
        ELSE IF (IGBL(3) .EQ. 23) THEN
          IGBL(70) = 0
          ICL      = 'CALC GEOM EUCLID'
        ELSE IF (IGBL(3) .EQ. 24) THEN
          IGBL(70) = 0
          ICL      = 'CALC GEOM SHELX'
        ELSE IF (IGBL(3) .EQ. 25) THEN
          ICL      = 'CALC GEOM SHELX'
        ELSE IF (IGBL(3) .EQ. 27) THEN
          IGBL(70) = 0
          ICL      = 'CALC GEOM RENUM SHELX'
        ELSE IF (IGBL(3) .EQ. 29) THEN
          ICL      = 'POWDER IOBS'
        ELSE IF (IGBL(3) .EQ. 30) THEN
          IF (IGBL(29) .LE. 0) THEN
            ICL      = 'CALC FCF'
            IPR(516) = 1
          ELSE
            ICL = 'ROTMAT'
          ENDIF
        ELSE IF (IGBL(3) .EQ. 31) THEN
          ICL = 'POWDER'
        ELSE IF (IGBL(3) .EQ. 33) THEN
          ICL = 'ASYM AVF VALID'
        ELSE IF (IGBL(3) .EQ. 34) THEN
          ICL = 'ASYM VALID'
        ELSE IF (IGBL(3) .EQ. 35) THEN
          ICL = 'TABL ACC'
        ELSE IF (IGBL(3) .EQ. 36) THEN
          ICL = 'CALC VOID'
        ELSE IF (IGBL(3) .EQ. 37 .OR. IGBL(3) .EQ. 40) THEN
          ICL = 'ROTMAT'
        ELSE IF (IGBL(3) .EQ. 38) THEN
          ICL = 'CALC ADDSYM EQUAL SHELX'
        ELSE IF (IGBL(3) .EQ. 41) THEN
          ICL = 'FIT'
        ELSE
          IF (MODE .EQ. 0) THEN
            IF (IGBL(72) .EQ. 0) THEN
              WRITE (LU6, 99999)
              WRITE (LU6, 99998) IGBL(9)
              IGBL(72) = 1
            ENDIF
            IF (IPR(39) .EQ. 0) THEN
              IF (IABS(IGBL(8)) .EQ. 3) THEN
                ICL = 'END'
                GOTO 20
              ELSE
                WRITE (LU6, 99997)
              ENDIF
            ENDIF
          ENDIF
          LRT = 2
        ENDIF
      ENDIF
   20 RETURN
99999 FORMAT ('::', 29X,
     1        'S.e.l.e.c.t.e.d  I.n.s.t.r.u.c.t.i.o.n.s', /,
     2        '::', 1X, 24('*'), 2X,
     3        'CALC for an exhaustive geometry calculation', /,
     4        '::', 1X, '*        PLATON        *', 2X,
     5        'PLOT ADP for default labeled ORTEP-look-alike', /,
     6        '::', 1X, '*        ======        *', 2X,
     7        'TABL CIF for an Acta Cryst C CIF-file', /,
     8        '::', 1X, '*    A Multipurpose    *', 2X,
     9        'LEPAGE to check for higher metrical symmetry', /,
     *        '::', 1X, '*   Crystallographic   *', 2X,
     1        'CALC ADDSYM for a check for MISsed SYMmetry')
99998 FORMAT ('::', 1X, '*         Tool         *', 2X,
     1        'CALC NONSYM for a non-cryst. symm. check', /,
     2        '::', 1X, '*          --          *', 2X,
     3        'CALC SOLV to search for missed solvent areas', /,
     4        '::', 1X, '*(C) 1980-2006 A.L.Spek*', 2X,
     5        'CALC SQUEEZE to handle disordered solvents', /,
     6        '::', 1X, '*          --          *', 2X,
     7        'PLOT NEWMAN for NEWMAN-Projection Plots', /,
     6        '::', 1X, '*   version : ', I6, '   *', 2X,
     7        'LIST RADII for current radii list', /,
     8        '::', 1X, 24('*'), 2X,
     9        'HELP for Available Instruction Information', /,
     *        '::', 1X, 26X, 'PLUTON to enter the PLUTON sub-program')
99997 FORMAT (/, ':: Warning: no ATOMS given yet')
      END
      SUBROUTINE PLA006 (MODE, IS)
      PARAMETER (NP4=9,NP10=16,NP12=600,NP13=500,NP17=99,NP22=256,
     1 NP24=176,NP37=175,NP38=125,NP39=30,NP45=2048)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /Q/ ICL, IFL(NP17)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, ICL*(NP45),
     1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4, TKST*10,
     2 JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5, KRSYST*12,
     3 LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, ZSPG*7, SPGRNM(4)*26,
     4 CHSG*6
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /CGGT/ IGGT
      CHARACTER IGGT*80, ICH*1
      COMMON /CHDAT/ CRD(NP37), LABP(16), COLR(NP10 + 1), BWCT(NP10 + 1)
      CHARACTER CRD*4, LABP*2, COLR*10, BWCT*10
   10 J     = 0
      ICONT = 0
      A     = 0.0
      IF (IGBL(8) .EQ. 3) THEN
        KL    = 0
        KN    = 0
        LRETN = 0
        CALL PLA007 (MODE, LRETN, KL, KN)
      ENDIF
   20 KN    =  0
      KL    =  0
      IS    = -1
      CALL GEN074 (FN, 0.0, 1, NP17)
      DO 30 I = 1, NP17
        CALL GEN038 (IFL(I), 1, 7)
   30 CONTINUE
      IF (IGGT(1:1) .EQ. ' ') THEN
        IF (IGBL(23) .GT. 0  .AND. IGBL(23) .NE. 10 .AND.
     1      IGBL(23) .NE. 11 .AND. IGBL(23) .NE. 12 .AND.
     2      IGBL(5) * IGBL(24) * IGBL(25) .EQ. LU5)
     3          CALL PLA280 ('PLOT')
      ENDIF
      IF (IGGT(1:1) .NE. ' ') THEN
        ICL = IGGT
        IF (IGBL(74) .EQ. 1) WRITE (LU6, 99999) IGBL(23), ICL(1:60)
        CALL GEN038 (IGGT, 1, 80)
        GOTO 60
      ENDIF
   40 IF (IGBL(5) .EQ. LU5) THEN
        LRT = 1
        CALL PLA005 (MODE, LINE, ICL, LRT)
        IF (LRT .EQ. 1) THEN
          GOTO 60
        ELSE IF (LRT .EQ. 2) THEN
          GOTO 50
        ENDIF
      ENDIF
   50 IF (IGBL(5) .NE. LU1 .OR. IGBL(8) .NE. 4) THEN
        CALL PLA019 (0, IER)
        IF (IER .NE. 0) GOTO 290
        IF (MODE .EQ. 1 .AND. IGBL(5) .EQ. LU1) THEN
          CALL GEN038 (NQ1, 1, 7)
          CALL PLUT29 (1, ICL, NQ1, 0)
        ENDIF
      ENDIF
C * CHECK/FIND-OUT DATA TYPE (= IGBL(8))
   60 IF (IGBL(8) .EQ. 0) THEN
        DO 70 I = 1, 80
          IF (ICL(I:I) .EQ. CHAR(13)) GOTO 50
          IF (ICL(I:I) .NE. CHAR(32)) THEN
C * TEST FOR CIF STRUCTURE (IGBL(8) = 3)
            LRETN = -1
            CALL PLA007 (MODE, LRETN, KL, KN)
            IF (LRETN .EQ. -2) GOTO 290
C * TEST FOR FDAT-STRUCTURE (IGBL(8) = 4)
            IF (IGBL(8) .EQ. 0) THEN
              CALL PLA008 (MODE, LRETN, KL, KN)
              IF (LRETN .EQ. -2) GOTO 50
C * CHECK FOR PDB-FILE-STRUCTURE  (IGBL(8) = 5)
              IF (IGBL(8) .EQ. 0) THEN
                CALL PLA009 (MODE, LRETN, KL, KN)
C * CHECK FOR CHEM-3D - FORMAT TRIGGERED BY NUMBER IN FIRST THREE POSITIO
                IF (IGBL(8) .EQ. 0) THEN
                  CALL PLA010 (MODE, LRETN)
C * ASSUME SPF = 1 (OR RES = 2)
                  IF (IGBL(8) .EQ. 0) THEN
                    IF (ICL(1:3) .EQ. 'REM') GOTO 50
                    IF (ICL(1:4) .EQ. 'TITL') THEN
                      IGBL(8) = 1
                    ELSE
                      IPR(2)  = 64
                      GOTO 310
                    ENDIF
                  ENDIF
                ENDIF
              ENDIF
            ENDIF
            GOTO 60
          ENDIF
   70   CONTINUE
        GOTO 50
C * RESTRICTED CIF - FORMAT (COMPATIBLE WITH SHELXL)
      ELSE IF (IGBL(8) .EQ. 3) THEN
        LRETN = 1
        CALL PLA007 (MODE, LRETN, KL, KN)
        IF (LRETN .EQ. 1) THEN
          GOTO 20
        ELSE IF (LRETN .EQ. 2) THEN
          GOTO 240
        ELSE IF (LRETN .EQ. 3) THEN
          GOTO 240
        ELSE IF (LRETN .EQ. 4) THEN
          GOTO 290
        ELSE IF (LRETN .EQ. 5) THEN
          GOTO 260
        ENDIF
C * FDAT - FILE STRUCTURE
      ELSE IF (IGBL(8) .EQ. 4) THEN
        LRETN = 1
        CALL PLA008 (MODE, LRETN, KL, KN)
        IF (LRETN .EQ. 1) THEN
          GOTO 240
        ELSE IF (LRETN .EQ. 2) THEN
          GOTO 270
        ELSE IF (LRETN .EQ. 3) THEN
          GOTO 290
        ENDIF
C * PDB-FILE STRUCTURE
      ELSE IF (IGBL(8) .EQ. 5) THEN
        LRETN = 1
        CALL PLA009 (MODE, LRETN, KL, KN)
        IF (LRETN .EQ. 1) THEN
          GOTO 240
        ELSE IF (LRETN .EQ. 4) THEN
          GOTO 290
        ELSE IF (LRETN .EQ. 6) THEN
          GOTO 255
        ENDIF
C * CHEM-3D FORMAT
      ELSE IF (IGBL(8) .EQ. 6) THEN
        LRETN = 1
        CALL PLA010 (MODE, LRETN)
        IF (LRETN .EQ. 1) THEN
          GOTO 240
        ELSE IF (LRETN .EQ. 4) THEN
          GOTO 290
        ELSE IF (LRETN .EQ. 6) THEN
          GOTO 255
        ENDIF
C * SPF or RES  & Instructions
      ELSE
        CALL GEN020 (1, ICL, 1, 4)
        N = INDEX (ICL(1:80), CHAR(13))
        IF (N .NE. 0) ICL(N:N) = CHAR(32)
        IF (ICL(1:4) .EQ. 'TITL' .OR. ICL(1:3) .EQ. 'REM' .OR.
     1      ICL(1:4) .EQ. 'MESS' .OR. ICL(1:4) .EQ. 'FILE') THEN
          I80 = 4
        ELSE IF (ICL(1:4) .EQ. 'ENTR') THEN
          I80 = 5
        ELSE
          I80 = 80
        ENDIF
        CALL GEN020 (1, ICL, 1, I80)
        IF (IPR(470) .EQ. 1) THEN
          IF (IGBL(5) .EQ. LU1) THEN
            IF (ICL(1:3) .NE. 'END') THEN
              IPR(471) = IPR(471) + 1
              GOTO 20
            ENDIF
          ENDIF
          IPR(470) = 0
        ENDIF
        ICH = ICL(1:1)
        IF (KL .EQ. 0 .AND. KN .EQ. 0 .AND.
     1        (ICH .EQ. ' ' .OR. ICH .EQ. '#' .OR. ICH .EQ. '+')) THEN
          IF (MODE .EQ. 0) THEN
            IF (IGBL(5) .EQ. LU5) THEN
              GOTO 300
            ELSE
              IPR(472) = IPR(472) + 1
              IPR(471) = IPR(471) + 1
            ENDIF
            GOTO 20
          ENDIF
        ENDIF
        IF (IGBL(5) .EQ. LU2 .AND. MODE .NE. 0)
     1      WRITE (LU6, 99997) ICL(1:80)
        IF (IGBL(5) .EQ. LU3) WRITE (LU6, 99998) ICL(1:80)
        IMAX = 80
        DO 80 I = 1, IMAX
          IF (ICL(I:I) .EQ. '!') THEN
            IMAX = I - 1
            GOTO 90
          ELSE IF (ICL(I:I) .EQ. '=') THEN
            IMAX  = I - 1
            ICONT = 1
            GOTO 90
          ENDIF
   80   CONTINUE
        ICONT = 0
   90   NCHAR = 7
        I     = 0
  100   A     = 0.0
        IP    = 0
        NP    = 0
        L     = 0
        S     = 1.0
  110   I     = I + 1
        IF (I .LE. IMAX) THEN
          ICH   = ICL(I:I)
          IF (ICH .EQ. CHAR(9)) THEN
            ICH = CHAR(32)
            ICL(I:I) = ICH
          ENDIF
          IF (L .EQ. 0 .AND. ICH .EQ. ' ') GOTO 110
          L = L + 1
          DO 120 J = 1, 10
            IF (ICH .EQ. CHAR(ICHAR('0') + J - 1)) THEN
              IF (IGBL(5) .NE. LU5 .AND. KL .EQ. 0) GOTO 20
              NP = NP + IP
              A  = 10.0 * A + J - 1
              GOTO 110
            ENDIF
  120     CONTINUE
          IF (ICH .EQ. '.') THEN
            IP = 1
          ELSE IF (ICH .EQ. '+') THEN
            IF (L .GT. 1) GOTO 140
            S = 1.0
          ELSE IF (ICH .EQ. '-') THEN
            IF (L .GT. 1) GOTO 140
            S = -1.0
          ELSE IF (ICH .EQ. ']') THEN
            GOTO 140
          ELSE
            IF (L .GT. 1) GOTO 140
            GOTO 150
          ENDIF
          GOTO 110
        ENDIF
        IF (L .LE. 0) GOTO 240
C * END OF NUMERIC FIELD
  140   IF (KN .LT. NP17) THEN
          KN     = KN + 1
          FN(KN) = S * A / 10.0**NP
        ENDIF
        IF (ICH .EQ. '+' .OR. ICH .EQ. '-') I = I - 1
        GOTO 100
C * START NEW LITERAL FIELD
  150   IF (KL .LT. NP17) KL = KL + 1
        IF (KL .GT. 1 .AND. IS .LT. 0) THEN
          IF (MODE .EQ. 0) THEN
            CALL GEN102 (IS, IFL(1), ISWS, NP24)
          ELSE
            CALL GEN102 (IS, IFL(1), CRD,  NP37)
          ENDIF
C * DO NOT INTERPRETE TITL, REM AND MESS LINES
          IF (IS .GT. 1 .AND. IS .LT. 5) GOTO 300
        ENDIF
  160   IFL(KL)(L:L) = ICH
        L     = L + 1
        IGGTN = (KL - 1) * 7 + L
        IF (IGGTN .LE. 80) IGGT(IGGTN:IGGTN) = ICH
        IF (IGGTN .EQ. 2) CALL GEN038 (IGGT, 3, 80)
  170   I = I + 1
        IF (I .GT. IMAX) GOTO 190
        ICH = ICL(I:I)
        IF (ICH .EQ. ' ' .OR. ICH .EQ. ',') GOTO 190
        IF (ICH .EQ. '[' .AND. L .GT. 3) GOTO 190
        IF (ICH .EQ. '.') GOTO 180
        IF (ICH .EQ. '+' .OR. ICH .EQ. '-') THEN
          IF (IGBL(8) .NE. 2 .OR. I .GT. 4) GOTO 180
        ENDIF
        IF (L .GT. NCHAR) THEN
          GOTO 170
        ELSE
          GOTO 160
        ENDIF
  180   I = I - 1
  190   GOTO 100
      ENDIF
  240 IF (IS .LT. 0) THEN
        IF (IFL(1)(1:4) .EQ. 'TEXT') THEN
          CALL PLA115 (1, 1, 0.0, 0.0, 0)
          CALL PLA013 (0, 1)
          GOTO 10
        ENDIF
        IF (MODE .EQ. 0) THEN
          CALL GEN102 (IS, IFL(1), ISWS, NP24)
        ELSE
          CALL GEN102 (IS, IFL(1), CRD,  NP37)
        ENDIF
      ENDIF
      IF (ICONT .EQ. 1) THEN
        IF (IS .LT. 2 .OR. IS .GT. 4) GOTO 40
      ENDIF
      IENDS = 0
      IF (MODE .EQ. 0) THEN
        IF (IS .EQ. 14)  IENDS = 1
      ELSE
        IF (IS .EQ. 140) IENDS = 1
      ENDIF
      IF (IENDS .EQ. 1) THEN
        CALL PLA019 (0, IER)
          IF (IER .GE. 0) THEN
          BACKSPACE IGBL(5)
        ELSE
          IS = -1
        ENDIF
      ENDIF
      GOTO 300
  255 IS =  0
      GOTO 280
  260 IS = -2
      GOTO 280
  270 IS       = -1
  280 IPR(3)   = 1
  290 IGBL(8)  = - IABS(IGBL(8))
  300 IPR(220) = KL
      IPR(221) = KN
      IF (MODE .EQ. 1) THEN
        IF (IS .EQ. 93) THEN
          IS = 65
        ELSE IF (IS .EQ. 71) THEN
          IS = 26
        ELSE IF (IS .EQ. 64) THEN
          IS = 40
        ELSE IF (IS .EQ. 32) THEN
          IS = 31
        ELSE IF (IS .EQ. 156) THEN
          IS = 13
        ENDIF
      ENDIF
  310 RETURN
99999 FORMAT (':: GGIP(', I3, '): ', A)
99998 FORMAT (':: SEx:', A)
99997 FORMAT (':: Def:', A)
      END
      SUBROUTINE PLA007 (MODE, LRETN, KL, KN)
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118,
     1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP22=256,
     2 NP25=99,NP29=63,NP34=509,NP38=125,NP39=30,NP41=200,NP45=2048,
     3 NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /Q/ ICL, IFL(NP17)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9),
     1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10),
     2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10),
     3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /CGGT/ IGGT
      CHARACTER IGGT*80, ICH*1, ICHU*1
      COMMON /NNLP/ NLP(50)
      COMMON /CIF/ CIFDIR
      CHARACTER CIFDIR(NP34)*36
      COMMON /WORDC/ NWRD
      CHARACTER NWRD*80, KEYWRD*36, QT*1, UCIFD*36
      DIMENSION FA(2)
      COMMON /CIFCOM/ ISEMC, ILOOP, NL, KW, NW, JKEY, CELL(12)
      COMMON /LITREF/ LREF
      CHARACTER LREF(25)*80
      IF (LRETN .GT. 0) THEN
        ICH   = ICL(1:1)
        IF (ICH .EQ. ';') THEN
          ISEMC = MOD (ISEMC + 1, 2)
          IF (ISEMC .EQ. 1) THEN
            LINE = ICL(2:80)
            GOTO 170
          ELSE
            ICL = ''''//LINE(1:78)//''''
          ENDIF
        ENDIF
        IF (ISEMC .EQ. 1) THEN
          LINE = ICL(1:80)
          GOTO 170
        ENDIF
        I = 1
        IF (ICH .EQ. CHAR(13)) THEN
          GOTO 170
        ELSE IF (ICH .EQ. '#') THEN
          GOTO 170
        ELSE IF (ICH .EQ. CHAR(32)) THEN
          DO 10 I = 2, 80
            IF (ICL(I : I) .NE. CHAR(32)) GOTO 20
   10     CONTINUE
          GOTO 170
        ENDIF
   20   IF (ICL(I : I + 4) .EQ. 'data_') THEN
          N = INDEX (ICL(1:80), 'CSD_CIF')
          IF (N .EQ. 0) THEN
            N        = I + 5
          ELSE
            IF (ICL(N+8:N+11) .EQ. 'MIF_') THEN
              N = N + 12
            ELSE
              N = N + 8
            ENDIF
            IGBL(94) = 1
          ENDIF
          IF (IPR(39) .EQ. 0) THEN
            JID = ICL(N:79 + N)
            N   = INDEX (JID, CHAR(13))
            IF (N .NE. 0) JID(N:N) = CHAR(32)
          ENDIF
          LRETN = 0
          CALL PLA118 (0, LRETN, CELL, FA)
          IPR(499) = IPR(499) + 1
          IF (IPR(499) .GT. 1) THEN
            IF (IPR(39) .EQ. 0) THEN
              IF (IGBL(50) .EQ. 0) WRITE (LU6, 99999) JID
              GOTO 170
            ENDIF
            BACKSPACE IGBL(5)
            IFL(1)  = 'ENDS'
            ICL     = 'ENDS'
            KL      = 1
            KN      = 0
            IGBL(8) = - IABS(IGBL(8))
            GOTO 200
          ENDIF
          ICL    = 'TITL '//JID(1:75)
          IFL(1) = 'TITL'
          IF (IGBL(3) .NE. 14) CALL GEN108 (LU11, 0)
          WRITE (LU20, 99987) LINE(I:80)
          KL = 1
          GOTO 200
        ELSE IF (ICL(I : I + 4) .EQ. 'loop_') THEN
          DO 30 J = I + 5, 80
            IF (ICL(J:J) .NE. CHAR(32)) THEN
              IGGT(1:80) = ICL(J:80)
              GOTO 40
            ENDIF
   30     CONTINUE
   40     ILOOP    = 1
          IPR(301) = 0
          KL       = 0
          KN       = 0
          GOTO 170
        ELSE IF (ICL(I : I + 4) .EQ. 'stop_') THEN
          GOTO 170
        ENDIF
        KW = 0
        NW = 0
        NL = 0
        CALL GEN038 (KEYWRD, 1, 36)
   50   IESC = 0
        IF (ICL(81:81) .EQ. CHAR(13)) ICL(81:81) = CHAR(32)
        IF (ICL(81:90) .EQ. '          ') THEN
          IMX = 80
        ELSE
          IMX = NP45 - 1
          WRITE (LU6, 99988) ICL(1:15)
          IPR(544) = IPR(544) + 1
          IF (IPR(544) .EQ. 1) WRITE (LU20, 99997) '_802', 1, 1
        ENDIF
        DO 130 I = 1, IMX + 1
          ICH = ICL(I : I)
          IF (ICH .EQ. '#') GOTO 140
          IF (ICH .LT. CHAR(32)) ICH = CHAR(32)
          ICHU = ICH
          CALL GEN020 (1, ICHU, 1, 1)
          IF (KW .EQ. 0) THEN
            IF (NW .EQ. 0) THEN
              IF (ICH .EQ. '_') THEN
                KW          = 1
                KEYWRD(1:1) = ICH
                IF (ILOOP .EQ. 0) IPR(301) = 1
              ELSE IF (ICH .NE. CHAR(32)) THEN
                IF (ICH .NE. '''' .AND. ICH .NE. '"') THEN
                  CALL GEN038 (NWRD, 3, 80)
                  NW        = 2
                  NWRD(2:2) = ICHU
                  QT        = CHAR(32)
                ELSE
                  NW        = 1
                  QT        = ICH
                ENDIF
                IF (ICH .EQ. CHAR(92)) THEN
                  IESC = 1
                ENDIF
                IF (IESC .EQ. 1) THEN
                  IESC = 0
                ENDIF
              ENDIF
            ELSE
              NW = NW + 1
              IF (NW .GT. 1 .AND. NW .LE. 80) THEN
                NWRD(NW:NW) = ICHU
              ELSE IF (NW .EQ. 81) THEN
                WRITE (6, 99986) ICL(1:80), ICL(81:160)
              ENDIF
              IF ((ICH .EQ. '''' .OR. ICH .EQ. '"') .AND. IESC .EQ. 1)
     1          THEN
                IESC = 0
              ELSE IF (ICH .EQ. CHAR(92)) THEN
                IESC = 1
              ELSE IF (ICH .EQ. QT) THEN
                IF (QT .EQ. ' ' .OR. QT .EQ. '"') NWRD(NW:NW) = ''''
                ILOOP = 0
                CALL GEN042 (NWRD, FA, INUM)
                IF (NL .LT. IPR(301)) THEN
                  NL    = NL + 1
                  NLPNL = NLP(NL)
                  IF (NLPNL .EQ. 370) THEN
                    IF (NW .GT. 2) THEN
                      IF (NW .GT. 19) NW = 19
                      CCIF(9) = NWRD(2 : NW - 1)
                      NCIF(9) = NW - 2
                    ENDIF
                    CALL GEN020 (-1, CCIF(9), 1, 9)
                  ELSE IF (NLPNL .EQ. 451) THEN
                    RLWS(1) = ''''//NWRD(2:79)
                    IF (RLWS(1)(70:70) .EQ. '3') THEN
                      ISTP = 0
                    ELSE IF (RLWS(1)(71:71) .EQ. '3') THEN
                      ISTP = 1
                    ELSE
                      ISTP = -1
                    ENDIF
                    IF (ISTP .GE. 0) THEN
                     CALL GEN020 (-1, RLWS(1),  2, 13)
                      IF (RLWS(1)(18:19) .EQ. 'FO') RLWS(1)(19:19) = 'o'
                      IF (RLWS(1)(17:18) .EQ. 'FO')
     1                  RLWS(1)(12:25) = CHAR(92)//'s^2^(Fo^2^)+('
                      CALL GEN020 (-1, RLWS(1), 47 + ISTP, 51 + ISTP)
                      CALL GEN020 (-1, RLWS(1), 57 + ISTP, 57 + ISTP)
                      CALL GEN020 (-1, RLWS(1), 64 + ISTP, 64 + ISTP)
                      IF (RLWS(1)(37:45) .EQ. '+0.0000P]')
     1                    RLWS(1)(37:45) =    ']        '
                    ENDIF
                    J = INDEX (RLWS(1), 'P)')
                    IF (J .NE. 0) THEN
                      IF (RLWS(1)(J - 8:J - 7) .EQ. '+(') THEN
                        READ (RLWS(1)(J - 6: J - 1), 99990) PAR(227)
                        J = INDEX (RLWS(1), 'P]')
                        IF (J .NE. 0) THEN
                          IF (RLWS(1)(J - 9:J - 8) .EQ. '2^') THEN
                            READ (RLWS(1)(J - 7: J - 1), 99989)
     1                            PAR(228)
                          ELSE IF (RLWS(1)(J-10:J-9) .EQ. '2^') THEN
                            READ (RLWS(1)(J - 8: J - 1), 99989)
     1                            PAR(228)
                          ENDIF
                        ENDIF
                      ENDIF
                      IF (PAR(227) .EQ. 0.1 .AND. PAR(228) .EQ. 0.0)
     1                  WRITE (LU20, 99997) '_085', 1, 1
                    ENDIF
                  ELSE IF (NLPNL .EQ. 163 .OR. NLPNL .EQ. 481) THEN
                    J = INDEX (NWRD, 'NEUTRON')
                    IF (J .NE. 0) IPR(493) = 5
                    J = INDEX (NWRD, 'SYNCHROTRON')
                    IF (J .NE. 0) IPR(493) = 4
                  ELSE IF (NLPNL .EQ. 353) THEN
                    RLWS(2) = ''''//NWRD(2:79)
                  ELSE IF (NLPNL .EQ. 412 .OR. NLPNL .EQ. 443) THEN
                    IF (NW .GT. 2) THEN
                      IF (NW .GT. 19) NW = 19
                      CCIF(1) = NWRD(2:NW-1)
                      NCIF(1) = NW - 2
                    ENDIF
                    CALL GEN020 (-1, CCIF(1),  1, 17)
                  ELSE IF (NLPNL .EQ. 369) THEN
                    IF (NW .GT. 2) THEN
                      IF (NW .GT. 19) NW = 19
                      CCIF(2) = NWRD(2:NW-1)
                      NCIF(2) = NW - 2
                    ENDIF
                    IF (CCIF(2)(1:4) .EQ. 'FSQD') THEN
                      CCIF(2) = 'Fsqd'
                      IPR(309) = 2
                    ELSE
                      IPR(309) = 1
                    ENDIF
C * GET ABSORPTION CORRECTION TYPE
                  ELSE IF (NLPNL .EQ. 232) THEN
                    RLWS(3)  = ''''//NWRD(2:79)
                    IPR(485) = -2
                    IF (INUM .LT. 0) THEN
                      IPR(485) = -1
                    ELSE IF (NWRD(2:3) .EQ. 'NO') THEN
                      IPR(485) = 0
                    ELSE IF (NWRD(2:3) .EQ. 'AN') THEN
                      IPR(485) = 1
                    ELSE IF (NWRD(2:3) .EQ. 'IN' .OR.
     1                       NWRD(2:3) .EQ. 'GA') THEN
                      IPR(485) = 2
                    ELSE IF (NWRD(2:3) .EQ. 'NU') THEN
                      IPR(485) = 3
                    ELSE IF (NWRD(2:3) .EQ. 'EM' .OR.
     1                       NWRD(2:3) .EQ. 'PS') THEN
                      IPR(485) = 4
                    ELSE IF (NWRD(2:3) .EQ. 'MU') THEN
                      IPR(485) = 5
                    ELSE IF (NWRD(2:3) .EQ. 'RE') THEN
                      IPR(485) = 6
                    ELSE IF (NWRD(2:3) .EQ. 'SP') THEN
                      IPR(485) = 7
                    ELSE IF (NWRD(2:3) .EQ. 'CY') THEN
                      IPR(485) = 8
                    ENDIF
                  ELSE IF (NLPNL .EQ. 358) THEN
                    IF (NW .GT. 2) THEN
                      IF (NW .GT. 19) NW = 19
                      CCIF(3) = NWRD(2:NW-1)
                      NCIF(3) = NW - 2
                    ENDIF
                    CALL GEN020 (-1, CCIF(3),  1, 17)
                  ELSE IF (NLPNL .EQ. 354) THEN
                    IF (NW .GT. 2) THEN
                      IF (NW .GT. 19) NW = 19
                      CCIF(4) = NWRD(2:NW-1)
                      NCIF(4) = NW - 2
                    ENDIF
                    CALL GEN020 (-1, CCIF(4),  1, 17)
                  ELSE IF (NLPNL .EQ. 48) THEN
                    IF (NW .GT. 2) THEN
                      IF (NW .GT. 19) NW = 19
                      CCIF(10) = NWRD(2:NW-1)
                      NCIF(10) = NW - 2
                    ENDIF
                    CALL GEN020 (-1, CCIF(10),  1, 17)
                  ELSE IF (NLPNL .EQ. 49) THEN
                    IF (NW .GT. 2) THEN
                      IF (NW .GT. 19) NW = 19
                      CCIF(11) = NWRD(2:NW-1)
                      NCIF(11) = NW - 2
                    ENDIF
                    CALL GEN020 (-1, CCIF(11),  1, 17)
                  ELSE IF (NLPNL .EQ. 50) THEN
                    IF (NW .GT. 2) THEN
                      IF (NW .GT. 19) NW = 19
                      CCIF(12) = NWRD(2:NW-1)
                      NCIF(12) = NW - 2
                    ENDIF
                    CALL GEN020 (-1, CCIF(12),  1, 17)
                  ELSE IF (NLPNL .EQ. 239) THEN
                    IF (NW .GT. 2) THEN
                      IF (NW .GT. 19) NW = 19
                      CCIF(5) = NWRD(2:NW-1)
                      NCIF(5) = NW - 2
                    ENDIF
                    CALL GEN020 (-1, CCIF(5),  1, 17)
                  ELSE IF (NLPNL .EQ. 234) THEN
                    IF (NW .GT. 2) THEN
                      IF (NW .GT. 19) NW = 19
                      CCIF(14) = NWRD(2:NW-1)
                      NCIF(14) = NW - 2
                    ENDIF
                    CALL GEN020 (-1, CCIF(14),  1, 17)
                  ELSE IF (NLPNL .EQ. 232) THEN
                    IF (NW .GT. 2) THEN
                      IF (NW .GT. 19) NW = 19
                      CCIF(15) = NWRD(2:NW-1)
                      NCIF(15) = NW - 2
                    ENDIF
                    CALL GEN020 (-1, CCIF(15),  1, 17)
                  ELSE IF (NLPNL .EQ. 478) THEN
                    IF (NW .GT. 2) THEN
                      IF (NW .GT. 19) NW = 19
                      CCIF(17) = NWRD(2:NW-1)
                      NCIF(17) = NW - 2
                    ENDIF
                  ELSE IF (NLPNL .EQ. 357) THEN
                    IF (NW .GT. 2) THEN
                      IF (NW .GT. 19) NW = 19
                      CCIF(13) = NWRD(2:NW-1)
                      NCIF(13) = NW - 2
                    ENDIF
                    CALL GEN020 (-1, CCIF(13),  1, 17)
                  ELSE IF (NLPNL .EQ. 308) THEN
                    LREF(1) = NWRD(2:NW-1)
                  ELSE IF (NLPNL .EQ. 321) THEN
                    LREF(2)(1:NW) = NWRD(2: NW - 1)//', '
                  ELSE IF (NLPNL .EQ. 320) THEN
                    LREF(2)(7:NW + 6) = NWRD(2:NW-1)//', '
                  ELSE IF (NLPNL .EQ. 309) THEN
                    LREF(2)(12:NW + 11) = NWRD(2:NW-1)
                  ELSE IF (NLPNL .EQ. 323) THEN
                    IF (IPR(565) .LT. 23) THEN
                      IPR(565) = IPR(565) + 1
                      LREF(2 + IPR(565)) = NWRD(2:NW-1)
                    ENDIF
                  ELSE IF (NLPNL .EQ. 419 .OR. NLPNL .EQ. 490) THEN
                    IF (IPR(319) .EQ. 0) THEN
                      IPR(319) = 1
                      CALL SGSM (IDM, 0, FN, 0, 1, IERR)
                      IPR(48) = 1
                    ENDIF
                    DO 60 J = I + 1, 80
                      IF (ICL(J:J) .NE. ' ') THEN
                        IGGT(1:80) = ICL(J:80)
                        GOTO 70
                      ENDIF
   60               CONTINUE
   70               IFL(1) = 'SYMM   '
                    ICL    = 'SYMM '//NWRD(2:NW-1)
                    KL     = 1
                    KN     = 0
                    IF (MODE .EQ. 0 .AND. IGBL(3) .NE. 14)
     1                 WRITE (LU11) ICL(1:80),
     2                 (IFL(J), J = 1, 4), (FN(J), J = 1, 6)
                  ELSE IF (NLPNL .EQ. 164) THEN
                    KL = 1
                    KN = 1
                    IFL(1) = 'RADN'
                    FN(1)  = FA(1)
                    GOTO 200
                  ELSE IF (NLPNL .EQ. 245) THEN
                    FN(1) = FA(1)
                  ELSE IF (NLPNL .EQ. 246) THEN
                    FN(2) = FA(1)
                  ELSE IF (NLPNL .EQ. 247) THEN
                    FN(3) = FA(1)
                  ELSE IF (NLPNL .EQ. 248) THEN
                    IF (FA(1) .GT. 0.0) THEN
                      FN(4)  = FA(1)
                      KL     = 1
                      KN     = 4
                      IFL(1) = 'FACE'
                      GOTO 200
                    ENDIF
                  ELSE IF (NLPNL .EQ. 507) THEN
                    PAR(437) = PAR(437) + FA(1)
                  ELSE IF (NLPNL .EQ. 508) THEN
                    PAR(438) = PAR(438) + FA(1)
                  ELSE IF (NLPNL .EQ. 1) THEN
                    KL     = 2
                    KN     = 0
                    IFL(1) = 'UIJ'
                    IFL(2) = NWRD(2:NW-1)
                    IF (INUM .NE. 0) THEN
                      WRITE (LU20, 99991) '_799', 1.0, 1.0, IFL(2)
                    ENDIF
                  ELSE IF (NLPNL .EQ. 3) THEN
                    IF (INUM .EQ. 0) GOTO 200
                    FN(1)  = FA(1)
                    FN(7)  = FA(2)
                    KN     = KN + 2
                  ELSE IF (NLPNL .EQ. 4) THEN
                    IF (INUM .EQ. 0) GOTO 200
                    FN(6)  = FA(1)
                    FN(12) = FA(2)
                    KN     = KN + 2
                  ELSE IF (NLPNL .EQ. 5) THEN
                    IF (INUM .EQ. 0) GOTO 200
                    FN(5)  = FA(1)
                    FN(11) = FA(2)
                    KN     = KN + 2
                  ELSE IF (NLPNL .EQ. 6) THEN
                    IF (INUM .EQ. 0) GOTO 200
                    FN(2)  = FA(1)
                    FN(8)  = FA(2)
                    KN     = KN + 2
                  ELSE IF (NLPNL .EQ. 7) THEN
                    IF (INUM .EQ. 0) GOTO 200
                    FN(4)  = FA(1)
                    FN(10) = FA(2)
                    KN     = KN + 2
                  ELSE IF (NLPNL .EQ. 8) THEN
                    IF (INUM .EQ. 0) GOTO 200
                    FN(3)  = FA(1)
                    FN(9)  = FA(2)
                    KN     = KN + 2
                  ELSE IF (NLPNL .EQ. 452) THEN
                    FN(1)  = FA(1) / GL(8)
                    FN(7)  = FA(2) / GL(8)
                    KN     = KN + 2
                  ELSE IF (NLPNL .EQ. 453) THEN
                    FN(6)  = FA(1) / GL(8)
                    FN(12) = FA(2) / GL(8)
                    KN     = KN + 2
                  ELSE IF (NLPNL .EQ. 454) THEN
                    FN(5)  = FA(1) / GL(8)
                    FN(11) = FA(2) / GL(8)
                    KN     = KN + 2
                  ELSE IF (NLPNL .EQ. 455) THEN
                    FN(2)  = FA(1) / GL(8)
                    FN(8)  = FA(2) / GL(8)
                    KN     = KN + 2
                  ELSE IF (NLPNL .EQ. 456) THEN
                    FN(4)  = FA(1) / GL(8)
                    FN(10) = FA(2) / GL(8)
                    KN     = KN + 2
                  ELSE IF (NLPNL .EQ. 457) THEN
                    FN(3)  = FA(1) / GL(8)
                    FN(9)  = FA(2) / GL(8)
                    KN     = KN + 2
                  ELSE IF (NLPNL .EQ. 22) THEN
                    KN     = 4
                    IFL(1) = 'ATOM'
                    IFL(2) = NWRD(2:NW-1)
                    IF (INUM .NE. 0) THEN
                      WRITE (LU20, 99991) '_798', 1.0, 1.0, IFL(2)
                    ENDIF
                    FN(4) = 1.0
                    KL    = KL + 2
                  ELSE IF (NLPNL .EQ. 35) THEN
                    IFL(3) = NWRD(2:NW-1)
                    KL     = KL + 1
                  ELSE IF (NLPNL .EQ. 19) THEN
                    IF (INUM .EQ. 0) GOTO 200
                    FN(1) = FA(1)
                    FN(5) = FA(2)
                    KN    = KN + 2
                  ELSE IF (NLPNL .EQ. 20) THEN
                    IF (INUM .EQ. 0) GOTO 200
                    FN(2) = FA(1)
                    FN(6) = FA(2)
                    KN    = KN + 2
                  ELSE IF (NLPNL .EQ. 21) THEN
                    IF (INUM .EQ. 0) GOTO 200
                    FN(3) = FA(1)
                    FN(7) = FA(2)
                    KN    = KN + 2
                  ELSE IF (NLPNL .EQ. 11) THEN
                    IF (INDEX(NWRD(2:2), 'C') .NE. 0) FN(21) = 1.0
                  ELSE IF (NLPNL .EQ. 31) THEN
                    IF (INDEX(NWRD(2:NW-1), 'R')  .NE. 0) FN(22) = 1.0
                    IF (INDEX(NWRD(2:NW-1), 'G')  .NE. 0) FN(22) = 2.0
                    IF (INDEX(NWRD(2:NW-1), 'PR') .NE. 0) FN(22) = 3.0
                    IF (INDEX(NWRD(2:NW-1), 'S')  .NE. 0) FN(22) = 4.0
                  ELSE IF (NLPNL .EQ. 33) THEN
                  ELSE IF (NLPNL .EQ. 30) THEN
                    IF (INUM .EQ. 0)  THEN
                      KN = KN - 2
                      GOTO 200
                    ELSE IF (INUM .LT. 0) THEN
                      FA(1) = 1.0
                      FA(2) = 0.0
                    ENDIF
                    IF (FA(1) .LT. 0.0001) THEN
                      WRITE (LU20, 99991) '_074', 0.5, 0.5, IFL(2)
                      GOTO 170
                    ENDIF
                    FN(4) = FA(1)
                    FN(8) = FA(2)
                  ELSE IF (NLPNL .EQ. 36) THEN
                    IF (INUM .EQ. 0) THEN
                      KN = KN - 2
                      GOTO 200
                    ENDIF
                    FN(9)  = FA(1)
                    FN(10) = FA(2)
                  ELSE IF (NLPNL .EQ. 423) THEN
                    IF (INUM .EQ. 0) THEN
                      KN = KN - 2
                      GOTO 200
                    ENDIF
                    FN(9)  = FA(1) / GL(8)
                    FN(10) = FA(2) / GL(8)
C * BOND
                  ELSE IF (NLPNL .EQ. 265) THEN
                    LINE   = 'BOND '
                    IFL(1) = NWRD(2:NW - 1)
                    FN(3)  = 1.555
                    FN(4)  = 1.555
                  ELSE IF (NLPNL .EQ. 266) THEN
                    IFL(2) = NWRD(2:NW - 1)
                  ELSE IF (NLPNL .EQ. 267) THEN
                    FN(1)  = FA(1)
                    FN(2)  = FA(2)
                  ELSE IF (NLPNL .EQ. 269) THEN
                    IF (INUM .LE. 0) FA(1) = 1.555
                    FN(3)  = FA(1)
                  ELSE IF (NLPNL .EQ. 270) THEN
                    IF (INUM .LE. 0) FA(1) = 1.555
                    FN(4)  = FA(1)
C * CONTACT
                  ELSE IF (NLPNL .EQ. 271) THEN
                    LINE   = 'CONTACT '
                    IFL(1) = NWRD(2:NW - 1)
                    FN(3)  = 1.555
                    FN(4)  = 1.555
                  ELSE IF (NLPNL .EQ. 272) THEN
                    IFL(2) = NWRD(2:NW - 1)
                  ELSE IF (NLPNL .EQ. 273) THEN
                    FN(1)  = FA(1)
                    FN(2)  = FA(2)
                  ELSE IF (NLPNL .EQ. 275) THEN
                    IF (INUM .LE. 0) FA(1) = 1.555
                    FN(3)  = FA(1)
                  ELSE IF (NLPNL .EQ. 276) THEN
                    IF (INUM .LE. 0) FA(1) = 1.555
                    FN(4)  = FA(1)
C * ANGLE
                  ELSE IF (NLPNL .EQ. 258) THEN
                    LINE   = 'ANGLE '
                    IFL(1) = NWRD(2:NW - 1)
                    FN(3)  = 1.555
                    FN(4)  = 1.555
                    FN(5)  = 1.555
                  ELSE IF (NLPNL .EQ. 259) THEN
                    IFL(2) = NWRD(2:NW - 1)
                  ELSE IF (NLPNL .EQ. 260) THEN
                    IFL(3) = NWRD(2:NW - 1)
                  ELSE IF (NLPNL .EQ. 257) THEN
                    FN(1)  = FA(1)
                    FN(2)  = FA(2)
                  ELSE IF (NLPNL .EQ. 262) THEN
                    IF (INUM .LE. 0) FA(1) = 1.555
                    FN(3)  = FA(1)
                  ELSE IF (NLPNL .EQ. 263) THEN
                    IF (INUM .LE. 0) FA(1) = 1.555
                    FN(4)  = FA(1)
                  ELSE IF (NLPNL .EQ. 264) THEN
                    IF (INUM .LE. 0) FA(1) = 1.555
                    FN(5)  = FA(1)
C * TORSION
                  ELSE IF (NLPNL .EQ. 279) THEN
                    LINE   = 'TORSION '
                    IFL(1) = NWRD(2:NW - 1)
                    FN(3)  = 1.555
                    FN(4)  = 1.555
                    FN(5)  = 1.555
                    FN(6)  = 1.555
                  ELSE IF (NLPNL .EQ. 280) THEN
                    IFL(2) = NWRD(2:NW - 1)
                  ELSE IF (NLPNL .EQ. 281) THEN
                    IFL(3) = NWRD(2:NW - 1)
                  ELSE IF (NLPNL .EQ. 282) THEN
                    IFL(4) = NWRD(2:NW - 1)
                  ELSE IF (NLPNL .EQ. 278) THEN
                    FN(1)  = FA(1)
                    FN(2)  = FA(2)
                  ELSE IF (NLPNL .EQ. 284) THEN
                    IF (INUM .LE. 0) FA(1) = 1.555
                    FN(3)  = FA(1)
                  ELSE IF (NLPNL .EQ. 285) THEN
                    IF (INUM .LE. 0) FA(1) = 1.555
                    FN(4)  = FA(1)
                  ELSE IF (NLPNL .EQ. 286) THEN
                    IF (INUM .LE. 0) FA(1) = 1.555
                    FN(5)  = FA(1)
                  ELSE IF (NLPNL .EQ. 287) THEN
                    IF (INUM .LE. 0) FA(1) = 1.555
                    FN(6)  = FA(1)
C * H-BOND
                  ELSE IF (NLPNL .EQ. 426) THEN
                    LINE   = 'HBOND '
                    IFL(1) = NWRD(2:NW - 1)
                    FN(9)  = 1.555
                    FN(10) = 1.555
                    FN(11) = 1.555
                  ELSE IF (NLPNL .EQ. 427) THEN
                    IFL(2) = NWRD(2:NW - 1)
                  ELSE IF (NLPNL .EQ. 428) THEN
                    IFL(3) = NWRD(2:NW - 1)
                  ELSE IF (NLPNL .EQ. 429) THEN
                    FN(1)  = FA(1)
                    FN(2)  = FA(2)
                  ELSE IF (NLPNL .EQ. 430) THEN
                    FN(3)  = FA(1)
                    FN(4)  = FA(2)
                  ELSE IF (NLPNL .EQ. 431) THEN
                    FN(5)  = FA(1)
                    FN(6)  = FA(2)
                  ELSE IF (NLPNL .EQ. 432) THEN
                    FN(7)  = FA(1)
                    FN(8)  = FA(2)
                  ELSE IF (NLPNL .EQ. 466) THEN
                    IF (INUM .LE. 0) FA(1) = 1.555
                    FN(9) = FA(1)
                  ELSE IF (NLPNL .EQ. 467) THEN
                    IF (INUM .LE. 0) FA(1) = 1.555
                    FN(10) = FA(1)
                  ELSE IF (NLPNL .EQ. 433) THEN
                    IF (INUM .LE. 0) FA(1) = 1.555
                    FN(11) = FA(1)
C * SUM & MOIETY FORMULA
                  ELSE IF (NLPNL .EQ. 107) THEN
                    N = 1
   80               N = N + 1
                    IF (NWRD(N:N) .EQ. ' ') GOTO 80
                    RLWS(4) = NWRD(N:79)
                  ELSE IF (NLPNL .EQ. 109) THEN
                    N = 1
   90               N = N + 1
                    IF (NWRD(N:N) .EQ. ' ') GOTO 90
                    RLWS(5) = NWRD(N:79)
                    IFL(1)  = 'FSUM'
                    ICL     = RLWS(5)
                    GOTO 200
C * HALL SPACEGROUP
                  ELSE IF (NLPNL .EQ. 421 .OR. NLPNL .EQ. 486) THEN
                    IF (IPR(319) .EQ. 0) IPR(318) =  1
                    IF (NW .GT. 2) THEN
                      IF (NW .GT. 19) NW = 19
                      CCIF(16) = NWRD(2:NW-1)
                      NCIF(16) = NW - 2
                    ENDIF
                    CALL GEN020 (-1, CCIF(16), 3, 17)
                    IF (NWRD(2:2) .NE. '?' .AND. NWRD(2:2) .NE. ' ')
     1                THEN
                      IFL(1) = 'HALL'
                      ICL    = 'HALL '//NWRD(2:NW-1)
                      KL     = 2
                      KN     = 0
                      GOTO 200
                    ENDIF
C * H-M SPACEGROUP
                  ELSE IF (NLPNL .EQ. 422 .OR. NLPNL .EQ. 487 .OR.
     1                     NLPNL .EQ. 488) THEN
                    IF (IPR(319) .EQ. 0) IPR(318) =  1
                    IF (NW .GT. 19) NW = 19
                    NB = 2
                    NE = NW - 1
                    CALL GEN039 (0, NWRD, 2, NW -1, NB, NE)
                    CCIF(6) = NWRD(NB:NE)
                    NCIF(6) = NE - NB + 1
                    CALL GEN020 (-1, CCIF(6), 2, 17)
                    IF (NWRD(NB:NB) .NE. '?' .AND.
     1                  NWRD(NB:NB) .NE. ' ') THEN
                      IFL(1) = 'SPGR'
                      ICL    = 'SPGR '//NWRD(NB:NE)
                      JID(11:11 + NE - NB) = NWRD(NB:NE)
                      CALL GEN020 (-1, JID, 12, 23)
                      KL     = 2
                      KN     = 0
                      GOTO 200
                    ELSE
C * NO H-M SPACEGROUP SPECIFIED
                      WRITE (LU20, 99997) '_122', 1, 1
                    ENDIF
C * A-AXIS
                  ELSE IF (NLPNL .EQ. 78) THEN
                    CALL PLA118 (1, LRETN, CELL, FA)
                    GOTO 180
C * B-AXIS
                  ELSE IF (NLPNL .EQ. 79) THEN
                    CALL PLA118 (2, LRETN, CELL, FA)
                    GOTO 180
C * C-AXIS
                  ELSE IF (NLPNL .EQ. 80) THEN
                    CALL PLA118 (3, LRETN, CELL, FA)
                    GOTO 180
C * ALPHA
                  ELSE IF (NLPNL .EQ. 74) THEN
                    CALL PLA118 (4, LRETN, CELL, FA)
                    GOTO 180
C * BETA
                  ELSE IF (NLPNL .EQ. 75) THEN
                    CALL PLA118 (5, LRETN, CELL, FA)
                    GOTO 180
C * GAMMA
                  ELSE IF (NLPNL .EQ. 76) THEN
                    CALL PLA118 (6, LRETN, CELL, FA)
                    GOTO 180
C * VOLUME
                  ELSE IF (NLPNL .EQ. 93) THEN
                    PAR(164) = FA(1)
                    PAR(327) = MAX (0.0, FA(2))
                    IF (FA(2) .LE. 0.0 .AND. IGBL(94) .EQ. 0) THEN
                      WRITE (LU20, 99997) '_151', 1, 1
                    ELSE
                      CALL GEN041 (PAR(164), PAR(327), IPR(313), 2,
     1                             IPR(314), IPR(68))
                    ENDIF
                    GOTO 170
                  ELSE IF (INUM .EQ. 1) THEN
                    IF (NLPNL .EQ. 164) THEN
                      KL     = 1
                      KN     = 1
                      IFL(1) = 'RADN'
                      FN(1)  = FA(1)
                      GOTO 200
C * REPORTED Z
                    ELSE IF (NLPNL .EQ. 77) THEN
                      IPR(276) = NINT(FA(1))
C * CELL_MEASUREMENT_TEMPERATURE
                    ELSE IF (NLPNL .EQ. 88) THEN
                      IPR(261) = NINT(FA(1))
                      IF (NINT(FA(1)) .EQ. 293)
     1                  WRITE (LU20, 99997) '_199', 1, IPR(261)
                      KL     = 1
                      KN     = 1
                      IFL(1) = 'TEMP'
                      IFL(2) = 'K'
                      FN(1)  = FA(1)
                      GOTO 200
C * CELL_AMBIENT_TEMPERATURE
                    ELSE IF (NLPNL .EQ. 133) THEN
                      IPR(310) = NINT(FA(1))
                      IF (IPR(310) .EQ. 293)
     1                  WRITE (LU20, 99997) '_200', 1, IPR(310)
C * MOL-WEIGHT
                    ELSE IF (NLPNL .EQ. 110) THEN
                      PAR(308) = FA(1)
C * REPORTED F000
                    ELSE IF (NLPNL .EQ. 240) THEN
                      PAR(324) = FA(1)
C * HMIN... LMAX, THETA-MIN THETA-MAX
                    ELSE IF (NLPNL .EQ. 198) THEN
                      IPR(268) = NINT(FA(1))
                    ELSE IF (NLPNL .EQ. 199) THEN
                      IPR(267) = NINT(FA(1))
                    ELSE IF (NLPNL .EQ. 200) THEN
                      IPR(270) = NINT(FA(1))
                    ELSE IF (NLPNL .EQ. 201) THEN
                      IPR(269) = NINT(FA(1))
                    ELSE IF (NLPNL .EQ. 202) THEN
                      IPR(272) = NINT(FA(1))
                    ELSE IF (NLPNL .EQ. 203) THEN
                      IPR(271) = NINT(FA(1))
C * REFLECTION -THETA-MIN
                    ELSE IF (NLPNL .EQ. 207) THEN
                      PAR(167) = FA(1)
C * REFLECTION -THETA-MAx
                    ELSE IF (NLPNL .EQ. 206) THEN
                      PAR(168) = FA(1)
C * REFLECTION - THETA FULL
                    ELSE IF (NLPNL .EQ. 444) THEN
                      PAR(312) = FA(1)
C * MEAS FRACTION THETA-MAX
                    ELSE IF (NLPNL .EQ. 458) THEN
                      PAR(313) = FA(1)
C * MEAS FRACTION THETA-FULL
                    ELSE IF (NLPNL .EQ. 459) THEN
                      PAR(314) = FA(1)
C * DENSITY(diffrn)
                    ELSE IF (NLPNL .EQ. 235) THEN
                      PAR(267) = FA(1)
C * DENSITY(meas)
                    ELSE IF (NLPNL .EQ. 236) THEN
                      PAR(158) = FA(1)
C * NR REFL & PARAMETERS
                    ELSE IF (NLPNL .EQ. 204) THEN
                      IPR(262) = NINT(FA(1))
                    ELSE IF (NLPNL .EQ. 410) THEN
                      IPR(263) = NINT(FA(1))
                    ELSE IF (NLPNL .EQ. 411) THEN
                      IPR(264) = NINT(FA(1))
                    ELSE IF (NLPNL .EQ. 442) THEN
                      IPR(264) = NINT(FA(1))
C * NUMBER OF UNIQUE REFLECTIONS
                    ELSE IF (NLPNL .EQ. 361) THEN
                      IPR(265) = NINT(FA(1))
C * NUMBER OF L.S.-PARAMETERS
                    ELSE IF (NLPNL .EQ. 360) THEN
                      IPR(266) = NINT(FA(1))
C * R-all
                    ELSE IF (NLPNL .EQ. 363) THEN
                      IF (FA(1) .GT. 1.0) FA(1) = FA(1) * 0.01
                      PAR(309) = FA(1)
C * R-obs/gt
                    ELSE IF (NLPNL .EQ. 364 .OR. NLPNL .EQ. 445) THEN
                      IF (FA(1) .GT. 1.0) FA(1) = FA(1) * 0.01
                      PAR(173) = FA(1)
                      WRITE (JID(24:31), '(''R ='',F5.2)') FA(1)
C * wR-All/Ref
                    ELSE IF (NLPNL .EQ. 371 .OR. NLPNL .EQ. 446) THEN
                      IF (FA(1) .GT. 1.0) FA(1) = FA(1) * 0.01
                      PAR(174) = FA(1)
C * wR-obs/gt
                    ELSE IF (NLPNL .EQ. 372 .OR. NLPNL .EQ. 460) THEN
                      IF (FA(1) .GT. 1.0) FA(1) = FA(1) * 0.01
                      PAR(310) = FA(1)
C * S(all/ref/obs)
                    ELSE IF (NLPNL .EQ. 355 .OR. NLPNL .EQ. 447 .OR.
     1                       NLPNL .EQ. 356) THEN
                      PAR(299) = FA(1)
C * S(Restrained-obs)
                    ELSE IF (NLPNL .EQ. 365) THEN
                      PAR(300) = FA(1)
C * DIFF-DENS-MAX
                    ELSE IF (NLPNL .EQ. 347) THEN
                      PAR(177) = FA(1)
C * DIFF-DENS-MIN
                    ELSE IF (NLPNL .EQ. 348) THEN
                      PAR(176) = FA(1)
C * DIFF-DENS-RMS
                    ELSE IF (NLPNL .EQ. 462) THEN
                      PAR(175) = FA(1)
C * R(int)
                    ELSE IF (NLPNL .EQ. 196) THEN
                      PAR(197) = FA(1)
                      WRITE (LU20, 99996) '_020', PAR(197), PAR(197)
C * R(sig)
                    ELSE IF (NLPNL .EQ. 197) THEN
                      PAR(198) = FA(1)
C * SHIFT/ESD(SU)-MAX
                    ELSE IF (NLPNL .EQ. 367 .OR. NLPNL .EQ. 448) THEN
                      PAR(178) = FA(1)
C * SHIFT/ESD(SU)-MEAN
                    ELSE IF (NLPNL .EQ. 368 .OR. NLPNL .EQ. 461) THEN
                      PAR(179) = FA(1)
C * FLACK PARAMETER
                    ELSE IF (NLPNL .EQ. 350) THEN
                      CALL GEN041 (FA(1), FA(2), IPR(279), 3,
     1                             IPR(280), IPR(68))
                      PAR(433) = FA(1)
                      PAR(434) = FA(2)
                      IF (FA(2) .LE. 0.0) THEN
                        WRITE (LU20, 99996) '_036', 1.0, 1.0
                      ELSE
                        WRITE (LU20, 99996) '_032', FA(2), FA(2)
                      ENDIF
                      IF (FA(1) .LT. 99999.0) THEN
                        WRITE (LU20, 99996) '_033', ABS(FA(1)), FA(1)
                      ENDIF
                      IF (FA(1) .EQ. 0.0 .AND. FA(2) .GT. 0.0)
     1                  WRITE (LU20, 99996) '_850', 1.0, FA(2)
C * EXTINCTION PARAMETER
                    ELSE IF (NLPNL .EQ. 352) THEN
                      RATIO = 0.0
                      IF (FA(2) .GT. 0.0) THEN
                        IF (FA(1) .LT. 0.1 * FA(2)) THEN
                          RATIO1 = 10.0
                        ELSE
                          RATIO  = FA(1) / FA(2)
                          RATIO1 = 1.0 / RATIO
                        ENDIF
                        WRITE (LU20, 99996) '_031', RATIO1, RATIO
                      ENDIF
                      CALL GEN041 (FA(1), FA(2), IPR(277), -8,
     1                             IPR(278), IPR(68))
                      PAR(229) = FA(1)
C * # LS-Restraints
                    ELSE IF (NLPNL .EQ. 362) THEN
                      IPR(273) = NINT(FA(1))
C * DATA RELATED TO ABSORPTION
                    ELSE IF (NLPNL .EQ. 229) THEN
                      PAR(301) = FA(1)
C * XTAL-SIZE-MAX
                    ELSE IF (NLPNL .EQ. 251) THEN
                      PAR(302) = FA(1)
C * XTAL-SIZE-MID
                    ELSE IF (NLPNL .EQ. 252) THEN
                      PAR(303) = FA(1)
C * XTAL-SIZE-MIN
                    ELSE IF (NLPNL .EQ. 253) THEN
                      PAR(304) = FA(1)
C * XTAL-RADIUS
                    ELSE IF (NLPNL .EQ. 254) THEN
                      PAR(305) = FA(1)
                    ELSE IF (NLPNL .EQ. 230) THEN
                      PAR(306) = FA(1)
                    ELSE IF (NLPNL .EQ. 231) THEN
                      PAR(307) = FA(1)
                    ENDIF
                  ENDIF
                  IF (NL .EQ. IPR(301)) THEN
                    IF (KL .GT. 0) GOTO 200
                    IF (MODE .EQ. 0 .AND. IGBL(3) .NE. 14) THEN
                      IF (LINE(1:4) .EQ. 'BOND' .OR.
     1                    LINE(1:5) .EQ. 'ANGLE' .OR.
     2                    LINE(1:5) .EQ. 'TORSI' .OR.
     3                    LINE(1:7) .EQ. 'CONTACT') THEN
                        WRITE (LU11) LINE, (IFL(N), N = 1, 4),
     1                                     (FN(N),  N = 1, 6)
                      ELSE IF (LINE(1:5) .EQ. 'HBOND') THEN
                        IF (IFL(1)(1:1) .NE. '?') THEN
                          CALL PLA046 (1, IFL(1), IENM1, LBB, LBC, LBD,
     1                      XNQNR, YNQNR, NIEN)
                          IF (NIEN .LT. 0) THEN
                            WRITE (LU20, 99995) '_715', 1, 1, IFL(1)
                          ELSE
                            VDWR1 = VDWR(IEN(IENM1))
                            CALL PLA046 (1, IFL(2), IENM2, LBB, LBC,
     1                      LBD, XNQNR, YNQNR, NIEN)
                            IF (NIEN .LT. 0) THEN
                              WRITE (LU20, 99995) '_716', 1, 1, IFL(2)
                            ELSE
                              VDWR2 = VDWR(IEN(IENM2))
                              CALL PLA046 (1, IFL(3), IENM3, LBB, LBC,
     1                          LBD, XNQNR, YNQNR, NIEN)
                              IF (NIEN .LT. 0) THEN
                                WRITE (LU20, 99995) '_717', 1, 1, IFL(3)
                              ELSE
                                IENM0 = IEN(IENM3)
                                VDWR3 = VDWR(IENM0)
                                IF (FN(1) .GT. 0.0) THEN
                                  LINE = 'D-H'
                                  WRITE (LU11) LINE, (IFL(N), N = 1, 4),
     1                              (FN(N), N = 1, 2), FN(9), FN(10),
     2                               0.0, 0.0
                                ENDIF
                                IF (FN(3) .GT. 0.0) THEN
                                  DELTA = FN(3) - VDWR2 - VDWR3
                                  IF (DELTA .GT. -0.2) THEN
                                    NQ2 = IFL(2)
                                    CALL PLA268 (NQ2)
                                    IF (IFL(3)(1:2) .NE. 'CG')
     1                                WRITE (LU20, 99985)
     2                                '_480', DELTA, FN(3), NQ2, IFL(3)
                                  ENDIF
                                  LINE = 'H..A'
                                  WRITE (LU11) LINE, (IFL(N), N = 2, 5),
     1                              (FN(N), N = 3, 4), FN(10), FN(11),
     2                               0.0, 0.0
                                ENDIF
                                IF (FN(5) .GT. 0.0) THEN
                                  DELTA = FN(5) - VDWR1 - VDWR3
                                  IF (DELTA .GT. 0.0) THEN
                                    WRITE (LU20, 99985)
     1                              '_481', DELTA, FN(5), IFL(1), IFL(3)
                                  ENDIF
                                  LINE = 'D..A'
                                  WRITE (LU11) LINE, IFL(1),
     1                              (IFL(N), N = 3, 5)
     2                             ,(FN(N), N = 5, 6), FN(9), FN(11),
     3                                 0.0, 0.0
                                ENDIF
                                IF (FN(7) .GT. 0.0) THEN
                                  DELTA = 180.0 - FN(7)
                                  IF (DELTA .GT. 60.0) THEN
                                    WRITE (LU20, 99985)
     1                             '_482', DELTA, FN(7), IFL(1), IFL(3)
                                  ENDIF
                                  LINE = 'D-H..A'
                                  WRITE (LU11) LINE, (IFL(N), N = 1, 4),
     1                             (FN(N), N = 7, 8), FN(9), FN(10),
     2                              FN(11), 0.0
                                ENDIF
                              ENDIF
                            ENDIF
                            LINE(1:1) = CHAR(32)
                          ENDIF
                        ENDIF
                      ENDIF
                    ENDIF
                  ENDIF
                ENDIF
C * NOTE GENERATION BY SHELXL
                IF (JKEY .EQ. 72) THEN
                  IPR(400) = 1
                ENDIF
                CALL GEN038 (NWRD, 1, 80)
                NW = 0
              ELSE
                IESC = 0
              ENDIF
            ENDIF
          ELSE
C * CONTINUE/FINISH BUILDING KEYWORD
            IF (ICH .EQ. CHAR(32)) THEN
              IPR(301) = IPR(301) + ILOOP
              IF (IPR(301) .GT. 0) THEN
                IF (IPR(301) .LE. 50) THEN
                  NLP(IPR(301)) = 0
                ELSE
                  IPR(2) = 60
                  GOTO 210
                ENDIF
              ENDIF
C * CHECK FOR OFFICIAL KEYWORDS
              DO 100 J = 1, NP34
                IF (KEYWRD .EQ. CIFDIR(J)) THEN
                  IF (IPR(301) .GT. 0) THEN
                    IF (IPR(301) .LE. 50) THEN
                      NLP(IPR(301)) = J
                    ELSE
                      IPR(2) = 60
                      GOTO 210
                    ENDIF
                  ENDIF
                  JKEY = J
                  GOTO 120
                ENDIF
  100         CONTINUE
C * CHECK FOR UPPER/LOWER CASE VARIANTS
              CALL GEN020 (-1, KEYWRD, 1, 36)
              DO 110 J = 1, NP34
                UCIFD = CIFDIR(J)
                CALL GEN020 (-1, UCIFD, 1, 36)
                IF (KEYWRD .EQ. UCIFD) THEN
                  IF (IPR(301) .GT. 0) THEN
                    IF (IPR(301) .LE. 50) THEN
                      NLP(IPR(301)) = J
                    ELSE
                      IPR(2) = 60
                      GOTO 210
                    ENDIF
                  ENDIF
                  GOTO 120
                ENDIF
  110         CONTINUE
              J  = 0
              IPR(429) = IPR(429) + 1
              WRITE (LU6, 99998) KEYWRD
  120         CALL GEN038 (KEYWRD, 1, 36)
              KW = 0
              IF (J .NE. 385) THEN
                GOTO 130
              ELSE
                IF (IGBL(3) .EQ. 14) THEN
                  LRETN = 5
                  GOTO 170
                ELSE
                  GOTO 210
                ENDIF
              ENDIF
            ELSE
              IF (KW .LT. 36) THEN
                KW            = KW + 1
                KEYWRD(KW:KW) = ICH
              ENDIF
            ENDIF
          ENDIF
  130   CONTINUE
C * HANDLE INCOMPLETE LOOP (CONTINUE ON NEW LINE)
  140   IF (KW .EQ. 0 .AND. NL .LT. IPR(301) .AND. NL .GT. 0) THEN
          CALL PLA019 (0, IER)
          IF (IER .LT. 0) GOTO 210
          IF (ICL(1:1) .EQ. ';') THEN
C * HANDLE ; PROBLEM IN LOOP
  150       CALL PLA019 (0, IER)
            IF (IER .LT. 0) GOTO 210
            IF (ICL(1:1) .NE. ';') GOTO 150
            ICL(1:9) = ' '' ? '' # '
          ENDIF
          NW = 0
          GOTO 50
        ENDIF
      ELSE IF (LRETN .EQ. 0) THEN
        NWRD(1:1) = ''''
        ISEMC     = 0
        ILOOP     = 0
        NL        = 0
        JKEY      = 0
        LRETN     = 1
C * LOOK FOR CIF-STYLE (TRIGGERED BY data_)
      ELSE IF (LRETN .EQ. -1) THEN
        N = INDEX (ICL, 'data_')
        IF (N .GT. 0) THEN
          IGBL(8) = 3
          IF (ICL(N + 5:N + 11) .EQ. 'CSD_CIF') IGBL(104) = 1
          IPR(220) = 1
          IPR(221) = 0
          CALL PLA011
          IGBL(30) = 1
          WRITE (LU6, 99994)
        ENDIF
      ENDIF
  170 RETURN
  180 IF (LRETN .EQ. 2) THEN
        DO 190 N = 1, 12
          FN(N) = CELL(N)
  190   CONTINUE
        KL     = 1
        KN     = 6
        IFL(1) = 'CELL'
      ENDIF
      RETURN
  200 LRETN = 3
      RETURN
  210 LRETN = 4
      RETURN
99999 FORMAT ('W: CIF Data_Record with no Data: Skipped', //,
     1        ':: New Data Set ', A, /)
99998 FORMAT ('W: Keyword ', A, ' Not in PLATON/CIFDIR')
99997 FORMAT (A, 2I10)
99996 FORMAT (A, 2F10.3)
99995 FORMAT (A, 2I10, A)
99994 FORMAT (/, ':: Restricted CIF-File Format assumed',
     1           ' (Automatic NOMOVE effective) ', /)
99991 FORMAT (A, 2F10.1, A)
99990 FORMAT (F6.4)
99989 FORMAT (F7.4)
99988 FORMAT (':: Record Longer than 80 Bytes found,',
     1        ' 2048 Bytes Assumed: ', A, ' ...')
99987 FORMAT (A)
99986 FORMAT (':: ERROR in RECORD:', /, A, /, A, /, '... etc ...', /)
99985 FORMAT (A, 2F10.2, 2A)
      END
      SUBROUTINE PLA008 (MODE, LRETN, KL, KN)
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16,
     1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP22=256,NP25=99,
     2 NP29=63,NP38=125,NP39=30,NP41=200,NP45=2048,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /Q/ ICL, IFL(NP17)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /CSD/ MODEF, IDC(11), IFLG(19), ICEL(6), IPRX(6),
     1 XCRD(4, 3), ISIG(6), CESD(6), IXJX(60), IFDAT(16)
      COMMON /CCSD/ RCODE, SPGP, CNAME(4), MFDAT, ITXT(30), TFDAT(16)
      CHARACTER RCODE*8, SPGP*8, CNAME*5,  MFDAT*1, ITXT*80, TFDAT*2
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, ICL*(NP45),
     1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4, TKST*10,
     2 JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5, KRSYST*12,
     3 LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, ZSPG*7, SPGRNM(4)*26,
     4 CHSG*6
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
C * ROUTINE HANDLES CSD-FDAT INPUT
      SCALE = 0.0
      IF (LRETN .GT. 0) THEN
        GOTO 40
   10   WRITE (LU6, 99997) RCODE
        MODEF = 0
   20   IF (IGBL(58) .NE. 0) THEN
          IGBL(54) = IGBL(54) - 1
          FN(1)    = IGBL(54)
          CALL PLA011
          GOTO 30
        ENDIF
        IGBL(54) = IGBL(54) + 1
   30   READ (IGBL(5), 99996, END = 160) ICL(1:80)
        IF (ICL(1:1) .NE. '#') GOTO 30
        BACKSPACE IGBL(5)
   40   IF (MODEF .EQ. 0) THEN
   50     READ (IGBL(5), 99996, END = 160) ICL(1:80)
          IF (ICL(1:1) .NE. '#') GOTO 50
          READ (ICL, 99989, ERR = 30) MFDAT, RCODE, IDC, IFLG
          IF (IFLG(1) .EQ. 0 .OR. IDC(6) .EQ. 0 .OR.
     1        IDC(8) .EQ. 0) THEN
            WRITE (LU6, 99997) RCODE
            GOTO 20
          ENDIF
          READ (IGBL(5), 99996, END = 170) ICL(1:80)
          READ (ICL, 99988, ERR = 30) ICEL, IPRX, ISIG,
     1          SPGP, NTOL
          PAR(2) = MAX (0.4, NTOL / 100.0)
          IF (ICEL(1) .EQ. 0) GOTO 20
          NWTXT  = (IDC(2) + IDC(3) + IDC(4) + IDC(5) + 79) / 80
          IF (NWTXT .GT. 0) THEN
            READ (IGBL(5), 99996, ERR = 30) (ITXT(I), I = 1, NWTXT)
            WRITE (LU6, 99995) (ITXT(I)(1:77), I = 1, NWTXT)
          ENDIF
          IFL(1)(1:4) = 'TITL'
          KL = 1
          KN = 0
          IF (IDC(2) .NE. 0) THEN
            WRITE (ICL, 99998) RCODE, SPGP, ITXT(1)(1:IDC(2))
          ELSE
            WRITE (ICL, 99998) RCODE, SPGP
          ENDIF
          MODEF = 1
        ELSE IF (MODEF .EQ. 1) THEN
          DO 60 II = 1, 6
            FN(II) = ICEL(II) / 10.0**IPRX(II)
   60     CONTINUE
          IFL(1)(1:4) = 'CELL'
          KL    = 1
          KN    = 6
          MODEF = 2
        ELSE IF (MODEF .EQ. 2) THEN
          DO 70 II = 1, 6
            FN(II) = ISIG(II) / 10.0**IPRX(II)
   70     CONTINUE
          IFL(1)(1:4) = 'CESD'
          KL    = 1
          KN    = 6
          MODEF = 3
        ELSE IF (MODEF .EQ. 3) THEN
          IFL(1)(1:4) = 'SPGR'
          IFL(2)      = SPGP(1:7)
          KL          = 2
          KN          = 0
          ICL         = 'SPGR '//SPGP
          CALL GEN038 (ICL, 14, 80)
          CCIF(6)     = SPGP
          NB = 1
          NE = 17
          CALL GEN039 (1, CCIF(6), 1, 17, NB, NE)
          NCIF(6) = NE - NB + 1
          MODEF   = 4
          IF (IFL(2)(1:1) .EQ. ' ') GOTO 40
        ELSE IF (MODEF .EQ. 4) THEN
          IF (IFLG(4) .EQ. 1) THEN
            ICL = 'LATT P C'
          ELSE
            ICL = 'LATT P A'
          ENDIF
          CALL SGSM (ICL, 0, XJX, LU6, 0, IERR)
          IF (IDC(6) .GT. 0) THEN
            NS = IDC(6)
            N  = -4
   80       READ (IGBL(5), 99996) ICL(1:80)
            READ (ICL(1:75), 99993, ERR = 30) (IXJX(I), I = 1, 60)
            NB = 0
            N  = N + 5
            NE = MIN (N + 4, IDC(6))
            DO 110 I = N, NE
              DO 100 J = 1, 3
                DO 90 K = 1, 3
                  XJX(K + (J - 1) * 3) = IXJX(NB + K) - 1
   90           CONTINUE
                XJX(9 + J) = MOD(IXJX(NB + 4) + 12, 12) / 12.0
                NB = NB + 4
  100         CONTINUE
              WRITE (ICL, 99994) (XJX(L), L = 1, 12)
              CALL SGSM (ICL, 0, XJX, LU6, 15, IERR)
              IF (IERR .NE. 0) THEN
                WRITE (LU6, 99997) RCODE
                MODEF = 0
                GOTO 20
              ENDIF
  110       CONTINUE
            NS = NS - 5
            IF (NS .GT. 0) GOTO 80
          ENDIF
          CALL SGSM (ICL, 0, XJX, LU6, 18, IERR)
          IF (IERR .NE. 0) THEN
            WRITE (LU6, 99997) RCODE
            MODEF = 0
            GOTO 20
          ENDIF
          IPR(48) = NINT(XJX(9))
          IF (IDC(7) .GT. 0) READ (IGBL(5), 99992, END = 170)
     1        (TFDAT(K), IFDAT(K), K = 1, IDC(7))
          NAT  = IDC(8) + IDC(9)
          NATA = 0
  120     IF (NAT .GT. 0) THEN
            NATE = MIN (NAT, 5 - IFLG(3))
            READ (IGBL(5), 99996, END = 170) ICL(1:80)
            IF (IFLG(3) .EQ. 1) THEN
              READ (ICL, 99991, ERR = 10)
     1             (CNAME(I), (XCRD(I, K), K = 1, 3), I = 1, NATE)
              SCALE = 0.0001
            ELSE IF (IFLG(3) .EQ. 2) THEN
              READ (ICL, 99990, ERR = 10)
     1             (CNAME(I), (XCRD(I, K), K = 1, 3), I = 1, NATE)
              SCALE = 0.00001
            ELSE
              WRITE (LU6, 99997) RCODE
              MODEF = 0
              GOTO 20
            ENDIF
            DO 140 I = 1, NATE
              IF (NATA .LT. IDC(8)) THEN
                NATA     = NATA + 1
                IFL(1)   = 'ATOM'
                IFL(2)   = CNAME(I)
                DO 130 J = 1, 3
                  FN(J) = XCRD(I, J) * SCALE
  130           CONTINUE
                KL       = 2
                IPR(221) = 3
                IF (MODE .EQ. 0) THEN
                  CALL PLA079 (XNQNR)
                ELSE
                  CALL PLUT03 (IER)
                ENDIF
              ENDIF
  140       CONTINUE
            NAT = NAT - NATE
            GOTO 120
          ENDIF
          IFL(1)  = 'ENDS'
          ICL     = 'ENDS'
          MODEF   = 0
          KL      = 1
          IGBL(8) = - IABS(IGBL(8))
          KN = 0
        ENDIF
        LRETN = 1
C * CHECK FOR FDAT-STRUCTURE (TRIGGERED BY # ON FIRST LINE POSITION 1)
C *                          (AND REFCODE IN COLUMN 2:7)
      ELSE IF (LRETN .EQ. -1) THEN
        IF (ICL(1:1) .EQ. '#') THEN
          N   = 0
          NN  = 0
          NC  = 0
          NN1 = 0
          NC1 = 0
          DO 150 J = 2, 80
            CALL GEN105 (3, ICL(J:J), N)
            IF (N .GT. 0) THEN
              IF (J .GT. 7) THEN
                NN1 = NN1 + 1
              ELSE
                NN = NN + 1
              ENDIF
            ELSE
              CALL GEN105 (1, ICL(J:J), N)
              IF (N .GT. 0) THEN
                IF (J .GT. 7) THEN
                  NC1 = NC1 + 1
                ELSE
                  NC  = NC  + 1
                ENDIF
              ENDIF
            ENDIF
  150     CONTINUE
          IF (NN + NC .NE. 6 .OR. NC1 .NE. 0 .OR. NN1 .LT. 10) THEN
            LRETN = -2
            GOTO 180
          ENDIF
          IGBL(8)  = 4
          IGBL(30) = 1
          IGBL(70) = 0
          MODEF    = 0
          WRITE (LU6, 99999)
          IPR(220) = 1
          IPR(221) = 0
          IF (IGBL(25) .NE. 0) THEN
            CALL PLA011
          ELSE
            CALL GEN108 (LU1, 0)
          ENDIF
          GOTO 180
        ENDIF
      ENDIF
      GOTO 180
  160 LRETN = 2
      GOTO 180
  170 LRETN = 3
  180 RETURN
99999 FORMAT (/, ':: FDAT Type File Format Assumed', /)
99998 FORMAT ('TITL ', A, 2X, A, 2X, A)
99997 FORMAT ('W: Entry = ', A, ' Skipped: Incomplete or Erroneous')
99996 FORMAT (A)
99995 FORMAT (':: ', A)
99994 FORMAT ('SYMM ', 9F5.0, 3F8.5)
99993 FORMAT (15(3I1, I2))
99992 FORMAT (16(A,I3))
99991 FORMAT (4(A5, 3F5.0))
99990 FORMAT (3(A5, 3F7.0, 1X))
99989 FORMAT (2A, 14X, 11I3, 19I1)
99988 FORMAT (6I6, 6I1, 6I2, 9X, A, 3X, I2)
      END
      SUBROUTINE PLA009 (MODE, LRETN, KL, KN)
      PARAMETER (NP4=9,NP10=16,NP12=600,NP13=500,NP17=99,NP22=256,
     1 NP38=125,NP39=30,NP45=2048)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /Q/ ICL, IFL(NP17)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, ICL*(NP45),
     1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4, TKST*10,
     2 JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5, KRSYST*12,
     3 LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, ZSPG*7, SPGRNM(4)*26,
     4 CHSG*6
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      IF (LRETN .EQ. 1) THEN
        NATC = 0
        NATO = 0
        NATN = 0
        NATS = 0
        NATH = 0
        NAT  = 0
        NAT2 = 0
        NCRY = 0
        XADD = 25.0
        ADD  = 0.0
   10   READ (IGBL(5), 99997, ERR = 50, END = 40) ICL(1:80)
        CALL GEN020 (1, ICL, 1, 80)
        IF (ICL(1:4) .EQ. 'ATOM' .OR. ICL(1:4) .EQ. 'HETA') THEN
          READ (ICL, 99998) NQ1, (FN(L), L = 1, 3)
          FN(1) = FN(1) + ADD
          NB = 1
          NE = 2
          N1 = 0
          N2 = 0
          IF (ICHAR(NQ1(1:1)) .GT. 64 .AND. ICHAR(NQ1(1:1)) .LT. 91)
     1      N1 = 1
          IF (ICHAR(NQ1(2:2)) .GT. 64 .AND. ICHAR(NQ1(2:2)) .LT. 91)
     1      N2 = 1
          IF (N1 .EQ. 1 .AND. N2 .EQ. 0) THEN
            NE = 1
          ELSE IF (N1 .EQ. 0 .AND. N2 .EQ. 1) THEN
            NB = 2
          ELSE IF (N1 .EQ. 1 .AND. N2 .EQ. 1) THEN
            NAT2 = NAT2 + 1
            N    = NAT2
            GOTO 15
          ELSE
            WRITE (LU6, '(''Atom '', A, '' - Skipped'')')
            GOTO 30
          ENDIF
          IF (NQ1(NB:NE) .EQ. 'C') THEN
            NATC = NATC + 1
            N    = NATC
          ELSE IF (NQ1(NB:NE) .EQ. 'O') THEN
            NATO = NATO + 1
            N    = NATO
          ELSE IF (NQ1(NB:NE) .EQ. 'N') THEN
            NATN = NATN + 1
            N    = NATN
          ELSE IF (NQ1(2:2) .EQ. 'S') THEN
            NATS = NATS + 1
            N    = NATS
          ELSE IF (NQ1(2:2) .EQ. 'H') THEN
            NATH = NATH + 1
            N    = NATH
          ELSE
            NAT  = NAT + 1
            N    = NAT
          ENDIF
   15     N  = MOD (N, 1000)
          CALL GEN040 (N, NQ2, IP)
          IFL(1)   = NQ1(NB:NE)//NQ2(1:IP)
          KL       = 1
          IPR(473) = 1
          IPR(220) = KL
          IPR(221) = 3
          IF (MODE .EQ. 0) THEN
            CALL PLA079 (XNQNR)
            IF (XNQNR .EQ. 0.0) THEN
              IGBL(54) = IGBL(54) + 1
              GOTO 40
            ENDIF
          ELSE
            CALL PLUT03 (IER)
          ENDIF
C * ANISOU
        ELSE IF (ICL(1:6) .EQ. 'ANISOU') THEN
          READ (ICL(29:70), 99996)
     1    FN(1), FN(2), FN(3), FN(6), FN(5), FN(4)
          DO 20 I = 1, 6
            FN(I) = FN(I) / 10000.0
   20     CONTINUE
          FN(7) = 0.0
          FN(8) = 0.0
          IPR(32) = MAX (IPR(32), 1)
          WRITE (LU4) 2, XNQNR, (FN(K), K = 1, 8)
          GOTO 10
        ELSE IF (ICL(1:3) .EQ. 'ADD') THEN
          XADD = FN(1)
        ELSE IF (ICL(1:5) .EQ. 'CRYST') THEN
          NCRY = NCRY + 1
          IF (NCRY .EQ. 2) ADD = XADD
        ELSE IF (ICL(1:3) .EQ. 'END') THEN
          IFL(1)  = 'ENDS'
          ICL     = 'ENDS'
          KL      = 1
          IGBL(8) = - IABS(IGBL(8))
          KN      = 0
          GOTO 30
        ELSE IF (ICL(1:5) .EQ. 'CONECT') THEN
        ELSE IF (ICL(1:5) .EQ. 'MASTER') THEN
        ENDIF
        GOTO 10
      ELSE IF (LRETN .EQ. -1) THEN
C * CHECK FOR PDB-FILE-STRUCTURE (TRIGGERED BY KEYWORD HEADER ON LINE 1)
        IF (ICL(1:6) .EQ. 'HEADER' .OR.
     1      ICL(1:6) .EQ. 'REMARK' .OR.
     2      ICL(1:6) .EQ. 'COMPND') THEN
          IGBL(8) = 5
          IF (ICL(63:66) .NE. '    ') THEN
            JID(1:72) = ICL(63:66)
          ELSE
            JID(1:72) = ICL(8:50)
          ENDIF
          WRITE (LU6, 99999)
          IPR(220) = 1
          IPR(221) = 0
          IF (IGBL(25) .NE. 0) THEN
            CALL PLA011
          ELSE
            CALL GEN108 (LU1, 0)
          ENDIF
          GOTO 30
        ENDIF
        IF (ICL(1:5) .EQ. 'CRYST') THEN
          IGBL(8) = 5
          WRITE (LU6, 99999)
          GOTO 30
        ENDIF
      ENDIF
   30 RETURN
   40 LRETN = 4
      RETURN
   50 LRETN = 6
      RETURN
99999 FORMAT (/, ':: PDB Type File Format Assumed (HEADER/CRYST)', /)
99998 FORMAT (12X, A, 11X, 3F8.0)
99997 FORMAT (A)
99996 FORMAT (6F7.0)
      END
      SUBROUTINE PLA010 (MODE, LRETN)
      PARAMETER (NP4=9,NP10=16,NP12=600,NP13=500,NP17=99,NP22=256,
     1 NP38=125,NP39=30,NP45=2048)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /Q/ ICL, IFL(NP17)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7, ICL*(NP45),
     1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4, TKST*10,
     2 JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5, KRSYST*12,
     3 LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80, ZSPG*7, SPGRNM(4)*26,
     4 CHSG*6
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
C * CHEM3D
      IF (LRETN .EQ. 1) THEN
   10   READ (IGBL(5), 99997, ERR = 50, END = 40) ICL(1:80)
        READ (ICL, 99996, ERR = 50) NQ1(1:6), FN(1), FN(2), FN(3)
        IFL(1) = ' '
        K = 0
        DO 20 I = 1, 6
          IF (NQ1(I:I) .NE. CHAR(32)) THEN
            K = K + 1
            IFL(1)(K:K) = NQ1(I:I)
          ENDIF
   20   CONTINUE
        IPR(473) = 1
        IPR(220) = 1
        IPR(221) = 3
        IF (MODE .EQ. 0) THEN
          CALL PLA079 (XNQNR)
        ELSE
          CALL PLUT03 (IER)
        ENDIF
        GOTO 10
      ELSE IF (LRETN .EQ. -1) THEN
C * CHECK FOR CHEM-3D - FORMAT TRIGGERED BY NUMBER IN FIRST THREE POSITIO
        READ (ICL(1:3), 99998, ERR = 30) NRAT
        IF (NRAT .NE. 0) THEN
          IGBL(8) = 6
          WRITE (LU6, 99999)
          GOTO 30
        ENDIF
      ENDIF
   30 RETURN
   40 LRETN = 4
      RETURN
   50 LRETN = 6
      RETURN
99999 FORMAT (/, ':: CHEM3D Type File Format Assumed', /)
99998 FORMAT (I3)
99997 FORMAT (A)
99996 FORMAT (2X, A, 3F12.0)
      END
      SUBROUTINE PLA011
      PARAMETER (NP12=600,NP13=500,NP17=99,NPVD=40000000,NP23=18000,
     1 NP38=125,NP39=30,NP45=2048)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /Q/ ICL, IFL(NP17)
      CHARACTER ICL*(NP45), IFL*7
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /CSD/ MODEF, IDC(11), IFLG(19), ICEL(6), IPRX(6),
     1 XCRD(4, 3), ISIG(6), CESD(6), IXJX(60), IFDAT(16)
      COMMON /CCSD/ RCODE, SPGP, CNAME(4), MFDAT, ITXT(30), TFDAT(16)
      CHARACTER RCODE*8, SPGP*8, CNAME*5,  MFDAT*1, ITXT*80, TFDAT*2
      COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0
      COMMON // JNSC(2, NP23), VOID(NPVD)
      COMMON /TIMER/ TIMT, TIMEZ, TIMEA, ISAVEMOD
      COMMON /CGGT/ IGGT
      CHARACTER IGGT*80
      COMMON /MENTRY/ XENTRY(100)
      CHARACTER CYN*1, REFCOD*8, LIN*14, PRBUF*80, CDATA*8
      PRBUF = ' '
      IF (LU1 .EQ. LU5) THEN
        WRITE (LU6, 99999)
        GOTO 80
      ENDIF
      IF (IPR(220) .GT. 1) THEN
        IF (IABS(IGBL(8)) .EQ. 4) CALL GEN020 (1, IFL(2), 1, 7)
        REFCOD = IFL(2)
        NENTRY = 0
      ELSE
        REFCOD = ' '
        IF (IPR(221) .GT. 0) THEN
          NENTRY = NINT(FN(1))
          IF (IGBL(100) .NE. 0) GOTO 60
        ELSE
          NENTRY   = 0
          IF (IGBL(100) .NE. 0) IPR(462) = 1
        ENDIF
      ENDIF
      IF (NENTRY .EQ. 0 .OR. IGBL(100) .EQ. 0) THEN
        IF (IGBL(8) .NE. 0 .AND. IABS(IGBL(8)) .LE. 5) THEN
          NCARD     = 0
          NDATA     = 0
          IGBL(100) = 0
          IGBL(86)  = NPVD - 6
          ILST      = 1
          XH        = 0.0
          XV        = VERT
          IF (IGBL(25) * IGBL(32) .EQ. 1)
     1        CALL GGIP (HORS, VERT, 0.0, 1)
          CALL GEN108 (LU1, 0)
   10     READ (LU1, 99994, END = 40) ICL(1:80)
          NCARD = NCARD + 1
          NCRD  = 1
C * SPF - SEQUENCE
          IF ((IGBL(8) .EQ. 1 .OR. IGBL(8) .EQ. 2) .AND.
     1      ICL(1:4) .EQ. 'TITL') THEN
          ELSE IF (IABS(IGBL(8)) .EQ. 5 .AND.
     1             ICL(1:6) .EQ. 'HEADER') THEN
C * CIF - SEQUENCE
          ELSE IF (ABS(IGBL(8)) .EQ. 3) THEN
            NPD = INDEX (ICL(1:80), '#')
            IF (NPD .EQ. 0) NPD = 80
            NPC = INDEX (ICL(1:NPD), '_publ_requested_category')
            IF (NPC .NE. 0) THEN
              IF (INDEX (ICL(NPC + 24: NPD), 'I') .NE. 0) THEN
                IGBL(99) = 1
              ELSE IF (INDEX (ICL(NPC + 24: NPD), 'M') .NE. 0) THEN
                IGBL(99) = 2
              ELSE IF (INDEX (ICL(NPC + 24: NPD), 'O') .NE. 0) THEN
                IGBL(99) = 3
              ENDIF
            ELSE IF (INDEX(ICL(1:40), 'data_') .NE. 0 .AND.
     1               INDEX(ICL(1:40), '_data_') .EQ. 0) THEN
              N = INDEX(ICL(1:40), 'data')
              CDATA = ICL(N + 5:N + 12)
              IF (CDATA(1:7) .EQ. 'CSD_CIF') THEN
                IF (ICL(N + 13:N + 16) .EQ. 'MIF_') THEN
                  CDATA = ICL(N + 17:N + 24)
                ELSE
                  CDATA = ICL(N + 13:N + 20)
                ENDIF
              ENDIF
              NDATA = NCARD - 1
            ELSE IF (INDEX(ICL(1:80), '_cell_length_a') .NE. 0) THEN
              GOTO 20
            ENDIF
            GOTO 10
C * FDAT - SEQUENCE
          ELSE IF (IABS(IGBL(8)) .EQ. 4 .AND. ICL(1:1) .EQ. '#') THEN
            READ (ICL, 99993, ERR = 10) MFDAT, RCODE, IDC, IFLG
            IF (IFLG(1) .EQ. 0 .OR. IDC(6) .EQ. 0 .OR.
     1          IDC(8) .EQ. 0) THEN
              WRITE (LU6, 99992) RCODE
              GOTO 10
            ENDIF
            READ (LU1, 99994, END = 40) ICL(1:80)
            NCARD  = NCARD + 1
            NCRD   = 2
            READ (ICL, 99991, ERR = 10) ICEL, IPRX, ISIG, SPGP
            IF (ICEL(1) .EQ. 0) THEN
              WRITE (LU6, 99992) RCODE
              GOTO 10
            ENDIF
          ELSE
            GOTO 10
          ENDIF
   20     IF (IGBL(86) .GT. 1) THEN
            IGBL(100) = IGBL(100) + 1
            IF (MOD (IGBL(100), 1000) .EQ. 0) THEN
              IF (IGBL(25) * IGBL(32) .EQ. 1) THEN
                CALL GGIP20 (0.0, PRBUF, 80, 0.35, 0, 2, 0.5, 0.5)
                WRITE (PRBUF, 99995) IGBL(100)
                CALL GGIP20 (0.0, PRBUF, 80, 0.35, 1, 2, 0.5, 0.5)
                CALL GGIP (0.0, 0.0, 0.0, 6)
              ENDIF
            ENDIF
            IGBL(86) = IGBL(86) - 1
            IF (ABS(IGBL(8)) .EQ. 3) THEN
              VOID(NPVD - 6 - IGBL(100)) = NDATA
              IF (IGBL(100) .LE. 100) XENTRY(IGBL(100)) = NDATA
            ELSE
              VOID(NPVD - 6 - IGBL(100)) = NCARD - NCRD
              IF (IGBL(100) .LE. 100) XENTRY(IGBL(100)) = NCARD - NCRD
            ENDIF
            IF (IPR(220) .EQ. 1 .AND. IPR(221) .EQ. 0) THEN
              IF (ILST * IPR(462) .EQ. 1) THEN
                IF (ILST .EQ. 1) THEN
                  IF (IABS(IGBL(8)) .EQ. 5) THEN
                    IF (ICL(63:66) .NE. '    ') THEN
                      WRITE (LIN, 99997) IGBL(100), ICL(63:70)
                    ELSE
                      WRITE (LIN, 99997) IGBL(100), ICL(11:18)
                    ENDIF
                  ELSE IF (IABS(IGBL(8)) .EQ. 4) THEN
                    WRITE (LIN, 99997) IGBL(100), RCODE
                  ELSE IF (IABS(IGBL(8)) .EQ. 3) THEN
                    WRITE (LIN, 99997) IGBL(100), CDATA
                  ELSE IF (IGBL(8) .EQ. 1 .OR. IGBL(8) .EQ. 2) THEN
                    WRITE (LIN, 99997) IGBL(100), ICL(6:13)
                  ENDIF
                  XV = XV - 0.45
                  CALL GGIP20 (0.0, LIN, 14, 0.34, 1, 2, XH, XV)
                ENDIF
                IF (MOD(IGBL(100), 43) .EQ. 0) THEN
                  XH = XH + 4.3
                  XV = VERT
                  IF (XH + 4.3 .GE. HORS) THEN
                    IF (IGBL(25) * IGBL(32) .EQ. 1) THEN
   30                 CALL PLA013 (3, 1)
                      IF (IGGT(1:4) .EQ. 'PLOT') THEN
                        GOTO 30
                      ELSE IF (IGGT(1:4) .EQ. 'EXIT') THEN
                        CALL GEN038 (IGGT, 1, 80)
                        GOTO 80
                      ELSE IF (IGGT(1:1) .EQ. 'N') THEN
                        CALL GEN038 (IGGT, 1, 80)
                        GOTO 80
                      ENDIF
                      CALL GEN072 (IGGT, IFL, FN, IPR(220),
     1                   IPR(221), 0, LU6, 1, 1, 80, 7, NP17)
                      CALL GEN038 (IGGT, 1, 80)
                      IF (IPR(221) .GT. 0) THEN
                        NENTRY = NINT(FN(1))
                        GOTO 60
                      ENDIF
                    ELSE
                      CALL PLA285 (1, LU6, 'Continue Listing (Y/N[Y])')
                      READ  (LU5, '(A)') CYN
                    ENDIF
                    CALL GEN020 (1, CYN, 1, 1)
                    IF (CYN .EQ. 'N') THEN
                      ILST = 0
                    ELSE
                      CALL GGIP (HORS, VERT, 0.0, 1)
                      XH = 0.0
                      XV = VERT
                    ENDIF
                  ENDIF
                ENDIF
              ENDIF
            ELSE
              IF (IABS(IGBL(8)) .EQ. 5) THEN
                IF (RCODE .EQ. REFCOD) THEN
                  NENTRY   = IGBL(100)
                  IPR(221) = 1
                ENDIF
              ELSEIF (IABS(IGBL(8)) .EQ. 4) THEN
                IF (RCODE .EQ. REFCOD) THEN
                  NENTRY   = IGBL(100)
                  IPR(221) = 1
                ENDIF
              ELSE IF (IABS(IGBL(8)) .EQ. 3) THEN
                IF (ICL(6:13) .EQ. REFCOD) THEN
                  NENTRY   = IGBL(100)
                  IPR(221) = 1
                ENDIF
              ELSE IF (IGBL(8) .EQ. 1) THEN
                IF (ICL(6:13) .EQ. REFCOD) THEN
                  NENTRY   = IGBL(100)
                  IPR(221) = 1
                ENDIF
              ENDIF
            ENDIF
          ENDIF
          GOTO 10
   40     IF (IABS(IGBL(8)) .EQ. 4) ICL = 'END '
          IF (IPR(462) .EQ. 1) THEN
   50       CALL PLA013 (3, 1)
            IF (IGGT(1:4) .EQ. 'PLOT') GOTO 50
            CALL GEN072 (IGGT, IFL, FN, IPR(220), IPR(221), 0, LU6, 1,
     1                   1, 80, 7, NP17)
            CYN = IGGT(1:1)
            CALL GEN038 (IGGT, 1, 80)
            IF (IPR(221) .GT. 0) NENTRY = NINT(FN(1))
          ENDIF
          IPR(462) = 0
          IF (ICL(1:1) .EQ. ';') CALL GEN038 (ICL, 1, 80)
          CALL GEN108 (LU1, 0)
        ENDIF
      ENDIF
   60 IF (NENTRY .GT. 0) THEN
        TIMEZ = CPUTIM()
        IF (IABS(IGBL(8)) .LE. 5) THEN
          IF (NENTRY .LE. IGBL(100)) THEN
            IGBL(54) = NENTRY - 1
            IF (NENTRY .LE. 100) THEN
              NCARD = NINT(XENTRY(NENTRY))
            ELSE
              NCARD = NINT(VOID(NPVD - 6 - NENTRY))
            ENDIF
            CALL GEN108 (LU1, 0)
            IF (NCARD .GT. 0) THEN
              DO 70 I = 1, NCARD
                READ (LU1, 99994) ICL(1:1)
   70         CONTINUE
            ENDIF
            ICL    = 'END'
            IPR(3) = 1
          ELSE
            WRITE (LU6, 99998) REFCOD, NENTRY, IGBL(100)
            CALL PLA015 (427, 50)
          ENDIF
        ENDIF
      ELSE
        IF (IPR(220) .GT. 1) THEN
          WRITE (LU6, 99998) REFCOD, NENTRY, IGBL(100)
          CALL PLA015 (427, 50)
        ENDIF
      ENDIF
   80 RETURN
99999 FORMAT (':: No Entries on File (Instruction Ignored)')
99998 FORMAT (/, ':: Entry not found (', A, 2I10,')')
99997 FORMAT (I5, 1X, A)
99995 FORMAT ('Count Number of Entries on Input:', I6)
99994 FORMAT (A)
99993 FORMAT (2A, 14X, 11I3, 19I1)
99992 FORMAT ('W: FDAT-Entry = ', A, ' Incomplete/skipped')
99991 FORMAT (6I6, 6I1, 6I2, 9X, A, 3X, I2)
      END
      SUBROUTINE PLA012
      PARAMETER (NP9=118,NP10=16,NP12=600,NP13=500,NP17=99,NP31=30,
     1 NP35=110,NP38=125,NP39=30,NP40=380)
      COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9),
     1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10),
     2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10),
     3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /MEN/ MENA(25, NP31), MENS(25, NP31), MENU(50, NP31),
     1             MNH(NP35)
      COMMON /CGG11/ BCD, SBCD
      CHARACTER BCD*132, SBCD*132
      COMMON /XMENU/ MENX, CMEN
      CHARACTER MENX(NP31)*11, CMEN(NP40)*11
      YGGIP = 0.0
      ZGGIP = 0.0
      CALL GGIP (-999.0, YGGIP, ZGGIP, 8)
      MNH(12) = NINT(ZGGIP)
      CALL PLA293 (PAR(17), 0)
      IF (MNH(12) .EQ. 1) THEN
        CMEN(24)(1:3)  = 'EPS'
        CMEN(44)(1:3)  = 'EPS'
        CMEN(104)(1:3) = 'EPS'
        CMEN(148)(5:7) = 'EPS'
      ELSE IF (MNH(12) .EQ. 2) THEN
        CMEN(24)(1:3)  = 'HGL'
        CMEN(44)(1:3)  = 'HGL'
        CMEN(104)(1:3) = 'HGL'
        CMEN(148)(5:7) = 'HGL'
      ELSE IF (MNH(12) .EQ. 3) THEN
        CMEN(24)(1:3)  = 'TEK'
        CMEN(44)(1:3)  = 'TEK'
        CMEN(104)(1:3) = 'TEK'
        CMEN(148)(5:7) = 'TEK'
      ENDIF
      MODE = IGBL(23)
      IF (MODE .EQ. 15) THEN
        MNH(27) = MAX (1, IPR(424) + 1)
        MNH(28) = MAX (1, IPR(425) + 1)
        MNH(29) = IPR(426) + 1
        MNH(47) = IPR(446) + 1
      ELSE IF (MODE .EQ. 17) THEN
        MNH(40) = IABS(IGBL(23)) - 16
      ELSE IF (MODE .EQ. 21) THEN
        MNH(45) = 3 - NINT(LOG(PAR(371)) / LOG(10.0))
        IF (PAR(372) .GE. 1.0) THEN
          MNH(46) = NINT (LOG(PAR(372)) / LOG(2.0)) + 1
        ENDIF
      ELSE
        MNH(1)  = IPR(140) + 1
        IF (IPR(478) .EQ. 0) THEN
          MNH(2) = 1
        ELSE IF (IPR(478) .EQ. -1) THEN
          MNH(2) = 2
        ELSE
          MNH(2) = 3
        ENDIF
        IF (IPR(477) .EQ. 0) THEN
          MNH(3) = 1
        ELSE IF (IPR(477) .EQ. -1) THEN
          MNH(3) = 2
        ELSE
          MNH(3) = 3
        ENDIF
        MNH(5)  = NINT(PAR(349) / 0.05) - 4
        MNH(8)  = IPR(139) + 1
        IF (IPR(111) .NE. 0)
     1    MNH(9) = INT(4 - (LOG(FLOAT(IPR(111))) / LOG(2.0)))
        MNH(10) = NINT (PAR(36) / 0.05) + 1
        MNH(11) = MAX (0, IABS(IGBL(23)) - 1)
        MNH(13) = NINT (PAR(284) / 0.5) + 1
        MNH(14) = NINT ((PAR(350) - 0.20) / 0.05)
        MNH(15) = IPR(232) + 1
        MNH(17) = NINT (PAR(273) / 5.0)
        MNH(18) = NINT (PAR(278) * 10.0)
        IF (IPR(419) .EQ. 0) IPR(419) = 5
        MNH(19) = NINT (LOG(IPR(419) / 2.5) / LOG(2.0))
        MNH(20) = NINT (PAR(279) + 1.5)
        MNH(21) = IGBL(63) + 1
        MNH(22) = NINT ((PAR(325) - 1.0) / 0.25) + 1
        MNH(23) = IPR(346) + 1
        MNH(24) = 6 - NINT(PAR(351) * 10.0)
        MNH(25) = INT((SIN (PAR(166) / GL(5)) * 20.0 / PAR(17)) - 0.1)
        MNH(25) = MAX (1, MIN (MNH(25) - 8, 7))
        MNH(26) = MIN (4, IPR(68) + 1)
        MNH(28) = NINT (PAR(86) * 100.0)
        MNH(29) = NINT (PAR(90) * 100.0)
        MNH(30) = NINT (PAR(88) * 100.0)
        MNH(31) = IPR(94) - 1
        MNH(32) = NINT (PAR(441) * 10.0) + 1
        IF (MNH(28) .EQ. MNH(29) .AND. MNH(29) .EQ. MNH(30)) THEN
          MNH(27) = MNH(28)
        ELSE
          MNH(27) = 0
        ENDIF
        IF (PAR(44) .GT. 0.0) THEN
          MNH(33) = MIN (NINT(LOG(PAR(44) * 2.0) / LOG(2.0) + 4), 6)
        ELSE
          MNH(33) = 1
        ENDIF
        MNH(34) = NINT(PAR(48) / 0.125) + 1
        IF (IPR(341) .GT. 1 .AND. IPR(341) .LT. 5) THEN
          MNH(35) = IPR(341) - 1
        ELSE
          MNH(35) = 0
        ENDIF
        MNH(36) = IPR(311)
        MNH(37) = IPR(33)  + 1
        MNH(38) = IPR(177) + 1
        MNH(39) = IPR(460)
        MNH(40) = IABS(IGBL(23)) - 16
        IF (IPR(389) .EQ. 1) THEN
          MNH(41) = 1
        ELSE IF (IPR(389) .EQ. -1) THEN
          MNH(41) = 2
        ELSE
          MNH(41) = 0
        ENDIF
        MNH(42) = NINT(PAR(58) / 0.05) + 1
        IF (PAR(439) .GT. 0.0) THEN
          MNH(43) = NINT(LOG(PAR(439) / 0.125) / LOG(2.0)) + 1
        ENDIF
        MNH(44) = IPR(117)
        IF (IABS(IGBL(23)) .EQ. 1) THEN
          MNH(48) = 1
        ELSE
          MNH(48) = MAX (0, IABS(IGBL(23)) - 6)
        ENDIF
      ENDIF
      MNH(49) = IPR(493)
      MNH(50) = IPR(500)
      MNH(51) = IPR(461) + 1
      MNH(52) = IPR(41)  + 1
      MNH(53) = IPR(148) + 1
      MNH(54) = IGBL(62)
      IF (IPR(182) .EQ. 0) THEN
        MNH(55) = IPR(515) + 1
      ELSE
        MNH(55) = IPR(505)
      ENDIF
      MNH(56) = IPR(507)
      IF (IPR(132) .GE. 0) MNH(57) = IPR(132) + 1
      MNH(58) = NINT (PAR(85))
      MNH(59) = NINT (PAR(89))
      MNH(60) = MIN (NINT(PAR(48) / 10.0) + 1, 7)
      MNH(61) = NINT (PAR(411) * 100.0)
      MNH(62) = (IPR(514) + 1) / 2
      MNH(63) = MIN (NINT(PAR(412) * 5.0), 4)
      MNH(64) = MIN (4, MAX (1, NINT(PAR(2) / 0.2) + 1))
      MNH(65) = MIN (4, MAX (1, NINT(PAR(27) / 0.2) + 3))
      MNH(66) = IGBL(88) + 1
      MNH(67) = IPR(531) + 1
      MNH(68) = IPR(533)
      MNH(69) = IPR(534)
      MNH(70) = MIN (5, 1 + MAX (0, NINT(GL(25) / 0.25)))
      MNH(71) = MIN (4, MAX (1, NINT (PAR(7)) - 2))
      MNH(72) = MAX (1, IPR(536))
      MNH(73) = MIN (8, MAX (1, NINT ((PAR(13) - 0.4) * 2.0)))
      MNH(75) = IPR(551)
      IF (PAR(440) .NE. 0.0) THEN
        MNH(74) = NINT(LOG(PAR(440)) / LOG(10.0))
      ENDIF
      MNH(76) = IGBL(101) + 1
      MNH(77) = NINT (PAR(249) / 10.0) + 1
      MNH(78) = NINT (PAR(43) / 0.2)
      MNH(79) = NINT ((PAR(407) + 0.05) / 0.1)
      MNH(80) = NINT ((PAR(408) + 0.05) / 0.1)
      MNH(81) = NINT ((PAR(409) + 0.05) / 0.1)
      IF (MODE .EQ. 25) THEN
        MNH(82) = NINT (LOG(PAR(413)) / LOG(2.0) - 0.01) + 1
        MNH(83) = NINT (PAR(414) / 0.05)
        MNH(84) = NINT (FLOAT(IPR(550)) / 25)
        MNH(85) = NINT (PAR(415) / 0.1)
        MNH(94) = IPR(567) / 5
      ENDIF
      MNH(86) = MAX (0, IGBL(23) - 9)
      MNH(87) = MIN (4, MAX (1, NINT(GL(26) / 0.20)))
      MNH(88) = MIN (5, 1 + MAX (0, NINT(GL(27) / 0.25)))
      MNH(89) = IPR(206) + 1
      IF (IPR(332) .EQ. 1) THEN
        MNH(90) = 1
      ELSE IF (IPR(352) .EQ. 1) THEN
        MNH(90) = 2
      ELSE
        MNH(90) = 0
      ENDIF
      IF (MODE .EQ. 7) THEN
        IF (ABS(PAR(18)) .GT. 1.0) THEN
          MNH(91) = 2
        ELSE
          MNH(91) = 1
        ENDIF
      ENDIF
      MNH(92) = NINT (PAR(449) / 0.1)
      MNH(93) = NINT (PAR(420) / 0.05)
      MNH(95) = MIN (5, NINT (PAR(262) / 2.5))
      MNH(96) = MIN (6, NINT (PAR(451) / 2.5))
      MNH(97) = MIN (6, (IPR(577) + 1) / 2)
      MNH(98) = MIN (6, (IPR(578) + 1) / 2)
      MNH(99) = IGBL(123) + 1
      IF (PAR(453) .LE. 0.54) THEN
        MNH(100) = 1
      ELSE IF (PAR(453) .LE. 0.60) THEN
        MNH(100) = 2
      ELSE IF (PAR(453) .LE. 0.65) THEN
        MNH(100) = 3
      ELSE
        MNH(100) = 4
      ENDIF
      MNH(101) = IPR(394)
      MNH(102) = IGBL(124) + 1
      MNH(103) = IPR(354)  + 1
      IF (MODE .EQ. 29) THEN
        IF (PAR(452) .LT. 0.01) THEN
          MNH(100) = 1
        ELSE
          MNH(100) = NINT(LOG(PAR(452) / 0.25) / LOG(2.0)) + 2
        ENDIF
      ENDIF
      MENS(12, 24) = INT(MENS(12, 24) / 100) * 100 + IPR(530) + 1
      IF (MODE .EQ. 1 .OR. MODE .EQ. 8 .OR. MODE .EQ. 9) THEN
        MENS(17, MODE) = INT(MENS(17, MODE) / 100) * 100 + IPR(75) + 1
        MNH(4)      = IPR(45)
      ELSE IF (MODE .EQ. 2 .OR. MODE .EQ. 3 .OR. MODE .EQ. 5 .OR.
     1         MODE .EQ. 6) THEN
        MENS(14, MODE) = INT(MENS(14, MODE) / 100) * 100 + IPR(75) + 1
      ELSE IF (MODE .EQ. 24) THEN
        MENS(10, MODE) = INT(MENS(10, MODE) / 100) * 100 + IPR(75) + 1
      ELSE IF (MODE .EQ. 26) THEN
        MENS(21, MODE) = INT(MENS(21, MODE) / 100) * 100 + IAN + 1
      ELSE IF (MODE .EQ. 10) THEN
        IF (IPR(44) .EQ. 0) IGBL(59) = 1
      ENDIF
      IF (IPR(116) .EQ. 0) THEN
        MENS(2, 2) = 4
        MENS(2, 1) = 2
      ELSE
        MENS(2, 2) = 1
        MENS(2, 1) = 1
      ENDIF
      IF (MODE .EQ. 0) THEN
        BCD(1:12) = '           '//CHAR(0)
      ELSE
        BCD(1:12) = MENX(IABS(MODE))//CHAR(0)
      ENDIF
      COLR = 5.0 + IGBL(68)
      CALL GGIP (-999.0, COLR, 1.0, 10)
      DO 5 I = 1, 25
        BCD(1:12) = '           '//CHAR(0)
        CALL GGIP (-999.0, 0.0, 1.0, 10 + I)
    5 CONTINUE
      IF (IPR(37) .NE. 0 .OR. IPR(367) .NE. 0 .OR.
     1    PAR(101) .GT. 1.0 .OR. MODE .EQ. 15 .OR.
     2    MODE .EQ. 17 .OR. MODE .EQ. 18 .OR. MODE .EQ. 19) THEN
        DO 10 I = 1, 25
          IF (MODE .NE. 0) THEN
            J = MENA(I, IABS(MODE))
            IF (J .GT. 0) THEN
              JJ = J / 1000
              J  = MOD(J, 1000)
              IF (JJ .GT. 0) THEN
                K = I
                IF (IABS(IPR(J)) .EQ. JJ) K = K + 25
              ELSE
                KK = 0
                IF (IPR(J) .NE. 0) KK = 25
                K  = KK + I
              ENDIF
            ELSE IF (J .LT. 0) THEN
              K = MAX (MIN (IABS(IGBL(IABS(J))), 1), 0) * 25 + I
            ELSE
              K = I
            ENDIF
            BCD(1:12) = CMEN(MOD(MENU(K, IABS(MODE)), 500))//CHAR(0)
            IF (MENU(K, IABS(MODE)) .GT. 500) THEN
              COLR = 2.0
            ELSE
              COLR = 1.0
            ENDIF
            MNS1 = MENS(I, IABS(MODE)) / 100
            MNS2 = MOD(MENS(I, IABS(MODE)), 100)
            IF (MNS1 .GT. 0) THEN
              XMNS = MNH(MNS1) * 100 + MNS2
            ELSE
              XMNS = MNS2
            ENDIF
            IF (IABS(MODE) .EQ. 16) THEN
              IF (IPR(78) .NE. -2) THEN
                IF (I .LT. 5) THEN
                  BCD(1:12) = '           '//CHAR(0)
                ENDIF
              ENDIF
            ENDIF
            CALL GGIP (-999.0, COLR, XMNS, 10 + I)
          ENDIF
   10   CONTINUE
      ENDIF
      IF (IPR(182) .EQ. 0) THEN
        BCD = SBCD
      ELSE
        BCD = 'Click on Unique Atoms to be Omitted'//CHAR(0)
      ENDIF
      CALL GGIP (-999.0, 5.0 + FLOAT(IGBL(68) * IGBL(82)), 70.0, 110)
      RETURN
      END
      SUBROUTINE PLA013 (MSBCD, MUPCASE)
      PARAMETER (NP12=600,NP13=500,NP17=99,NP38=125,NP39=30)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0
      COMMON /CGG11/ BCD, SBCD
      CHARACTER BCD*132, SBCD*132
      COMMON /GGT/ MEDIUM
      COMMON /CGGT/ IGGT
      CHARACTER IGGT*80
      COMMON /CTRLC/ CC
      COMMON /KEYS/ STRING
      CHARACTER STRING*100
      COMMON /NKEYS/ NCNT
      COMMON /LABMOD/ LMOD
      LOGICAL CC
      MMODE = 0
      LRET  = 0
      IF (IGBL(25) .EQ. 1) THEN
        IF (MSBCD .EQ. 1) THEN
          SBCD = 'Continue (Y/N[Y])'//CHAR(0)
        ELSE IF (MSBCD .EQ. 2) THEN
          SBCD = 'Hit RETURN to Continue'//CHAR(0)
        ELSE IF (MSBCD .EQ. 3) THEN
          SBCD = 'Enter # of ENTRY or Continue (Y/N[Y])'//CHAR(0)
        ELSE IF (MSBCD .EQ. 4) THEN
          SBCD = '[NEXT]'//CHAR(0)
        ELSE IF (MSBCD .EQ. 5) THEN
          SBCD = '[CALC]'//CHAR(0)
        ENDIF
        IF (IPR(308) .EQ.  1 .AND. IPR(332) .EQ.  0 .AND.
     1      IPR(335) .EQ.  0 .AND. IPR(351) .EQ.  0 .AND.
     2      IPR(352) .EQ.  0 .AND. IGBL(3)  .NE. 12 .AND.
     3      IGBL(3)  .NE. 13 .AND. IGBL(3)  .NE. 26) THEN
          SBCD = '[END]'//CHAR(0)
        ELSE IF (IPR(308) .EQ. 2) THEN
          SBCD = '[EXIT]'//CHAR(0)
        ENDIF
      ENDIF
      ZZ   = 0.0
      LRET = 3
      IF (CC) THEN
        ZZ    = 1.0
        IVENT = 5
      ELSE
        IF (IPR(460) .EQ. 3 .AND. IPR(551) .EQ. 3) THEN
          LMOD  = 0
          CALL PLA015 (-1, 0)
        ENDIF
   10   X     = 0.0
        Y     = 0.0
        Z     = 0.0
        IF (IGBL(25) * IGBL(32) .EQ. 1) THEN
          MMODE = IGBL(23)
          CALL PLA012
          IF (IGBL(48) .EQ. 0) THEN
            IVENT = 5
            CALL GGIP (X, Y, Z, IVENT)
          ELSE
            X     = 1
            IF (IGBL(3) .EQ. 12) THEN
              Y = 9
            ELSE IF (IGBL(3) .EQ. 13) THEN
              Y = 15
            ELSE IF (IGBL(3) .EQ. 26) THEN
              Y = 16
            ENDIF
            Z        = 1
            IVENT    = 2
            IGBL(48) = 0
          ENDIF
        ELSE
          IVENT = -1
        ENDIF
        LRET = 1
        IF (IVENT .GE. 0) THEN
          IF (IGBL(81) .EQ. 0) THEN
            MEDIUM      = 2
            IGGT(16:22) = 'OFF    '
            CALL GGIP (-999.0, 0.0, 0.0, 6)
          ENDIF
          IF (IVENT .EQ. 0) IVENT = 2
          IF (IVENT .EQ. 5) THEN
   20       IF (BCD(1:1) .EQ. CHAR(13)) THEN
              IF (NCNT .EQ. 0) THEN
                IF (IPR(335) .NE. 0) THEN
                  STRING = 'RENAME'
                  NCNT = 6
                ELSE IF (IPR(332) .NE. 0) THEN
                  STRING = 'HFIX'
                  NCNT = 4
                ELSE IF (IPR(352) .NE. 0) THEN
                  STRING = 'ANIS'
                  NCNT = 4
                ELSE IF (IPR(308) .EQ. 1) THEN
                  STRING = 'END '
                  NCNT = 4
                ELSE IF (IPR(308) .EQ. 2) THEN
                  STRING = 'EXIT'
                  NCNT = 4
                ELSE IF (IPR(209) .GT. 0) THEN
                  STRING = 'CALC GEOM EUCLID'
                  NCNT = 16
                ELSE
                  STRING(1:1) = '!'
                  NCNT = 1
                ENDIF
              ENDIF
              IGBL(5) = LU5
              IF (IPR(308) .EQ. 2) THEN
                CALL GEN020 (1, STRING, 1, 4)
                IF (STRING(1:3) .EQ. 'END') THEN
                  STRING(1:4) = 'EXIT'
                  NCNT = 4
                ENDIF
                IF (STRING(1:4) .EQ. 'EXIT') LRET = 7
              ENDIF
              CALL PLA280 (STRING(1:NCNT))
              NCNT     = 0
              IGBL(24) = 1
              IF (STRING(1:1) .NE. '!') THEN
                IF (MMODE .EQ. 10 .OR. MMODE .EQ. 11 .OR.
     1              MMODE .EQ. 12) LRET = 2
              ELSE
                IF (MMODE .EQ. 1) LRET = 3
              ENDIF
            ELSE IF (BCD(1:1) .EQ. CHAR(8) .OR.
     1               BCD(1:1) .EQ. CHAR(127)) THEN
              IF (NCNT .GT. 0) THEN
                NCNT = NCNT - 1
                IF (NCNT .EQ. 0) THEN
                  BCD = CHAR(0)
                ELSE
                  BCD = STRING(1:NCNT)//CHAR(0)
                ENDIF
                SBCD = BCD
              ENDIF
              LRET = -1
            ELSE IF (BCD(1:1) .EQ. CHAR(12)) THEN
              IF (MMODE .EQ. 1) THEN
                CALL PLA280 ('PLOT')
              ELSE
                IF (MMODE .EQ. 3 .OR. MMODE .EQ. 22
     1             .OR. MMODE .EQ. 15 .OR. MMODE .EQ. 17) LRET = 2
                BCD(1:1) = CHAR(13)
                GOTO 20
              ENDIF
            ELSE IF (BCD(1:1) .EQ. CHAR(0)) THEN
              LRET = -1
            ELSE
              IF (NCNT .LT. 80) THEN
                NCNT = NCNT + 1
                IF (NCNT .GE. 75)
     1            WRITE (LU6, '(''Position'', I3, A)') NCNT, CHAR(7)
                STRING(NCNT:NCNT) = BCD(1:1)
                BCD = STRING(1:NCNT)//CHAR(0)
                SBCD = BCD
              ENDIF
              LRET = -1
            ENDIF
          ELSE IF (IVENT .EQ. 4) THEN
            CALL PLA280 ('EXIT')
            IF (IGBL(3) .EQ. 4) IGBL(3) = 0
            IF (IGBL(45) .EQ. 0 .OR. IGBL(3) .EQ. 3) THEN
              IF (MMODE .EQ. 1 .OR. MMODE .EQ. 8 .OR.
     1            MMODE .EQ. 9) LRET = 7
            ELSE
              IGBL(45) = 0
              CALL PLA280 ('REM')
              IGBL(23) = 10
              CALL GEN108 (LU3, 0)
              WRITE (LU3, 99998)
              ENDFILE LU3
            ENDIF
            IF (MMODE .EQ. 22) LRET = 1
            IF (MMODE .EQ. 10 .OR. MMODE .EQ. 11 .OR.
     1          MMODE .EQ. 14) LRET = 2
          ELSE IF (IVENT .EQ. 3) THEN
            IF (NINT(Z) .EQ. 3) CALL PLA300 (3, 0, 0)
            LRET = -1
          ELSE IF (IVENT .EQ. 2) THEN
            IF (NINT(Z) .EQ. 3) THEN
              CALL PLA300 (2, 1, NINT(Y))
              LRET = -1
            ELSE
              IGBL(5) = LU5
              CALL PLA016 (NINT(Y), NINT(X))
            ENDIF
          ELSE IF (IVENT .EQ. 1) THEN
            CALL PLA020 (X, Y, Z)
          ENDIF
        ELSE IF (IVENT .EQ. -1) THEN
          IGBL(25) = 0
          IF (IGBL(3) .EQ. 28) THEN
            CALL PLA280 ('END')
            LRET = 7
          ENDIF
        ENDIF
        IF (LRET .EQ. -1) GOTO 10
      ENDIF
      SBCD = CHAR(0)
      XGGIP = 0.0
      YGGIP = 0.0
      CALL GGIP (XGGIP, YGGIP, ZZ, -1)
      IF (IGBL(74) .EQ. 1) WRITE (LU6, 99999) LRET, IGGT(1:65)
      IF (MUPCASE .GT. 0) CALL GEN020 (1, IGGT, 1, MUPCASE)
      RETURN
99999 FORMAT ('>> LRET =', I2, ', >>', A)
99998 FORMAT (80X, /)
      END
      SUBROUTINE PLA014 (MODE, NTYP, X, Y, ITEM, IASU)
      PARAMETER (NP0=6,NP12=600,NP13=500,NP17=99,NPVD=40000000,
     1 NP23=18000,NP38=125,NP39=30)
      COMMON // YXMOL(2, NP23), RA(NPVD)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /TPOS/ XTK(250, 3), NTK(25), KMX, IMIN
      IBEG = 0
      IEND = 0
      IF (NTYP .EQ. 1) THEN
        X1 =   X + PAR(61)
        Y1 = - Y - PAR(62)
      ELSE
        X1 = X
        Y1 = PAR(38) - Y
      ENDIF
      ITEM   = 0
      DELMIN = 1000.0
      IMIN   = 0
      IASU   = 0
      IF (IABS(MODE) .LE. 2) THEN
        IB = IPR(158)
        IF (MODE .GT. 0) THEN
          IB = IB + IPR(69) * NP0
          IBEG = IPR(69) + 1
          IF (IPR(341) .EQ. 2) THEN
            IEND = IPR(62)
          ELSE
            IEND = IPR(37)
          ENDIF
        ELSE IF (MODE .EQ. -1) THEN
          IB   = IB + IPR(62) * NP0
          IBEG = IPR(62) + 1
          IEND = IPR(62) + IPR(37)
        ELSE IF (MODE .EQ. -2) THEN
          IB   = IB + (IPR(62) + IPR(37)) * NP0
          IBEG = IPR(62) + IPR(37) + 1
          IEND = IPR(62) + IPR(37) + IPR(42)
        ENDIF
        DO 10 I = IBEG, IEND
          IB = IB + NP0
          DEL = (RA(IB - 3) - X1)**2
     1        + (RA(IB - 2) - Y1)**2
          IF (DEL .LT. DELMIN - 0.001) THEN
            IASU   = NINT (RA(IB - 5))
            IMIN   = I
            DELMIN = DEL
          ENDIF
   10   CONTINUE
      ELSE IF (MODE .EQ. 3) THEN
        DO 20 I = 1, IPR(447)
          DIST = SQRT ((XTK(I, 1) - X1)**2 +
     1        (XTK(I, 2) - Y1)**2)
          IF (DIST .LT. DELMIN) THEN
            DELMIN = DIST
            IMIN = I
          ENDIF
   20   CONTINUE
      ENDIF
      IF (DELMIN .LT. PAR(24) / 4) THEN
        ITEM = IMIN
        IF (MODE .EQ. 1) THEN
          IB = IPR(158) + (IMIN - 1) * NP0
          CALL PLUT31 (IB, 2.0)
          IF (IASU .NE. 0) THEN
            ITEM = IASU / 1000
            IASU = MOD (IASU, 1000)
          ENDIF
        ENDIF
      ENDIF
      RETURN
      END
      SUBROUTINE PLA015 (NR, IVAL)
      PARAMETER (NP10=16,NP12=600,NP13=500,NP17=99,NP37=175,NP38=125,
     1           NP39=30)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /CHDAT/ CRD(NP37), LABP(16), COLR(NP10 + 1), BWCT(NP10 + 1)
      CHARACTER CRD*4, LABP*2, COLR*10, BWCT*10
      COMMON /NOTE/ TXT
      COMMON /CGG11/ BCD, SBCD
      CHARACTER BCD*132, SBCD*132
      CHARACTER TXT*79
      IF (IGBL(50) .EQ. 2) GOTO 10
      MODE = IABS(IGBL(23))
      IF (IPR(427) .NE. 0) THEN
        IF (IGBL(23) .GT. 0) THEN
          CALL GEN038 (TXT, 1, 79)
          BCD = TXT//CHAR(0)
          CALL GGIP (-999.0, 0.0, 80.0, 111)
        ENDIF
        IPR(427) = 0
      ENDIF
      IF (NR .EQ. 0) THEN
C * ONE LINE NOTIFICATION MESSAGES
        IF (IVAL .EQ. 1) THEN
          TXT = 'No Classic Hydrogen Bonds Found'
        ELSE IF (IVAL .EQ. 2) THEN
          TXT =
     1    'Classic Hydrogen Bonds Found (See Listing for Details)'
        ELSE IF (IVAL .EQ. 3) THEN
          TXT = 'No Solvent Accessible Void Found'
        ELSE IF (IVAL .EQ. 4) THEN
          TXT =
     1    'Solvent Accessible Void Found (See Listing for Details)'
        ELSE IF (IVAL .EQ. 5) THEN
          TXT = 'No Obvious Additional Symmetry'
        ELSE IF (IVAL .EQ. 6) THEN
          TXT =
     1    'Additional (Pseudo)Symmetry Found (See Listing for details)'
        ELSE IF (IVAL .EQ. 7) THEN
          TXT = 'No Proper Reflection Data Available !'
        ELSE IF (IVAL .EQ. 8) THEN
          TXT = 'Label Conflict, No Substitution !'
        ELSE IF (IVAL .EQ. 9) THEN
          TXT = 'Requested Program not Accessible !'
        ELSE IF (IVAL .EQ. 10) THEN
          TXT = 'Instruction Ignored'
        ELSE IF (IVAL .EQ. 11) THEN
          TXT = 'DIRDIF PATTY for HEAVY ATOM STRUCTURES ONLY !'
        ELSE IF (IVAL .EQ. 12) THEN
          TXT = 'No Model-data found for DIRDIF/ORIENT-run'
        ELSE IF (IVAL .EQ. 13) THEN
          TXT =
     1    'Problem in DIRDIF (See tm/sg/dirdif/*.lis1 for details)'
        ELSE IF (IVAL .EQ. 14) THEN
          TXT = 'DIRDIF not Available (or accessible) !'
        ELSE IF (IVAL .EQ. 15) THEN
          TXT = '                                      '
        ELSE IF (IVAL .EQ. 16) THEN
          TXT = 'SIR nor Available (or accessible) !'
        ELSE IF (IVAL .EQ. 17) THEN
          TXT = 'SHELXS   not Available (or accessible) !'
        ELSE IF (IVAL .EQ. 18) THEN
          TXT = 'No (more) NEWMAN, RING or PLANE data (Rewind)? '
        ELSE IF (IVAL .EQ. 19) THEN
          TXT = 'No Crystal Description Available !'
        ELSE IF (IVAL .EQ. 20) THEN
          TXT = 'No Cell data yet !'
        ELSE IF (IVAL .EQ. 21) THEN
          TXT = 'Automatic Invert to enantiomeric space group'
        ELSE IF (IVAL .EQ. 22) THEN
          TXT = 'Spacegroup not acceptable, try again'
        ELSE IF (IVAL .EQ. 23) THEN
          TXT = 'SPGR # Out of Range [0:NP42], try again'
        ELSE IF (IVAL .EQ. 24) THEN
          TXT = 'TRMX nor acceptable, try again'
        ELSE IF (IVAL .EQ. 25) THEN
          TXT =
     1    'SPGR-Routine cannot identify appropriate space group'
        ELSE IF (IVAL .EQ. 26) THEN
          TXT = 'Formula Requires more Element-number pairs - retry'
        ELSE IF (IVAL .EQ. 27) THEN
          TXT = 'No Quest for Polymeric structures'
        ELSE IF (IVAL .EQ. 28) THEN
          TXT = 'Unsuitable Instruction. Ignored'
        ELSE IF (IVAL .EQ. 29) THEN
          TXT = 'SHELXL97 not Available (or accessible) !'
        ELSE IF (IVAL .EQ. 30) THEN
          TXT = 'HFIX-Instruction Valid for RES-files ONLY'
        ELSE IF (IVAL .EQ. 31) THEN
          TXT = 'AutoMolFit not possible for this residue pair'
        ELSE IF (IVAL .EQ. 32) THEN
          TXT =
     1    'Unresolved problem in SIR97 (see tm/sg/sir for details)'
        ELSE IF (IVAL .EQ. 33) THEN
          TXT = 'Missing Element(s) in Formula (Enter New Formula)'
        ELSE IF (IVAL .EQ. 34) THEN
          TXT = 'No Coordinate Data found in Current Input File'
        ELSE IF (IVAL .EQ. 35) THEN
          TXT = 'No Direction Cosines found'
        ELSE IF (IVAL .EQ. 36) THEN
          TXT = 'An Editor will be invoked prior to the SHELX launch'
        ELSE IF (IVAL .EQ. 37) THEN
          TXT = 'Twin[Matrix NOT Acceptable (Determinant = 0)'
        ELSE IF (IVAL .EQ. 38) THEN
          TXT = 'SHELXL-Problem, No Suitable Res-file '
        ELSE IF (IVAL .EQ. 39) THEN
          TXT = 'Result of Calculation on .lis & .lps Files'
        ELSE IF (IVAL .EQ. 40) THEN
          TXT = 'RENAME-function valid for RES-files Only !!'
        ELSE IF (IVAL .EQ. 41) THEN
          TXT = '                        '
        ELSE IF (IVAL .EQ. 42) THEN
          TXT = 'Incorrect Plane Definition. Try Again.'
        ELSE IF (IVAL .EQ. 43) THEN
          TXT =
     1    'No TLS-Analysis for Polymeric or Disordered Structures'
        ELSE IF (IVAL .EQ. 44) THEN
          TXT = 'ANIS-Instruction Valid for RES-files ONLY'
        ELSE IF (IVAL .EQ. 45) THEN
          TXT = 'Click on ARU-Code to ADD ARU to ORTEP PLOT'
        ELSE IF (IVAL .EQ. 46) THEN
          TXT = 'No Mu-value given !!'
        ELSE IF (IVAL .EQ. 47) THEN
          TXT = 'Validation requires NOMOVE mode !!'
        ELSE IF (IVAL .EQ. 48) THEN
          TXT = 'Problem/Error in JOIN Instruction !!'
        ELSE IF (IVAL .EQ. 49) THEN
          TXT = 'Error - Not Enough Data Items on Input Line !!'
        ELSE IF (IVAL .EQ. 50) THEN
          TXT = 'Error: Requested Data Entry not Found. Try Again.'
        ELSE IF (IVAL .EQ. 51) THEN
          TXT =
     1    'No Matching Reflection Data Set Found on Reflection FCF'
        ELSE IF (IVAL .EQ. 52) THEN
          TXT = 'No CAVITY''S Found in this Structure'
        ELSE IF (IVAL .EQ. 53) THEN
          TXT = 'Label Conflict, Special Substitution !'
        ELSE IF (IVAL .EQ. 54) THEN
          TXT = 'SIR2002 nor Available (or accessible) !'
        ELSE IF (IVAL .EQ. 55) THEN
          TXT = 'SHELXD nor Available (or accessible) !'
        ELSE IF (IVAL .EQ. 56) THEN
          TXT = 'Insufficient Space for Coordinate Expansion'
        ELSE IF (IVAL .EQ. 57) THEN
          TXT = 'Requested SIR version not found !'
        ENDIF
      ELSE IF (NR .GT. 0) THEN
        IF (IPR(341) .EQ. 1) CALL PLUT24 (-3, IDUM, IDUM)
        IPRNR    = IPR(NR)
        IPR(329) = 0
        IPR(332) = 0
        IPR(334) = 0
        IPR(338) = 0
        IPR(341) = 0
        IPR(343) = 0
        IPR(344) = 0
        IPR(348) = 0
        IPR(352) = 0
        IPR(448) = 0
        IPR(440) = 0
        IF (IPRNR .EQ. 0 .OR. IPRNR .NE. IVAL) THEN
          IPR(NR) = IVAL
        ELSE
          IPR(NR) = 0
        ENDIF
        IF (IPR(311) .EQ. 1) THEN
          TXT = 'Click on 2 ATOMS to JOIN'
        ELSE IF (IPR(311) .EQ. 2) THEN
          TXT = 'Click on 2 ATOMS to JOIN DASH'
        ELSE IF (IPR(311) .EQ. 3) THEN
          TXT = 'Click on 2 ATOMS to DETACH '
        ELSE IF (IPR(312) .EQ. 1) THEN
          TXT = 'Click on at least 5 Atom Pairs to FIT'
        ELSE IF (IPR(348) .EQ. 1) THEN
          TXT = 'Click on Atom to SELECT Pattern'
        ELSE IF (IPR(327) .EQ. 1) THEN
          IF (MODE .EQ. 1) THEN
            TXT = 'Click on LABEL [Lower Left Corner] to be DELETED'
          ENDIF
        ELSE IF (IPR(328) .EQ. 1) THEN
          IF (MODE .EQ. 1) THEN
            TXT = 'Click on (RED) LABEL to INCLUDE LABEL again'
          ENDIF
        ELSE IF (IPR(349) .EQ. 1) THEN
          IF (MODE .EQ. 1) THEN
            TXT = 'Click on LABEL [Lower Left Corner] to REPOSITION'
          ELSE
            TXT = 'Click on LABEL [Center] to REPOSITION'
          ENDIF
        ELSE IF (IPR(335) .EQ. 1) THEN
          TXT = 'Click on ATOM to be RENAMED (or RETURN for ATOM loop)'
        ELSE IF (IPR(351) .EQ. 1) THEN
          TXT = 'Click on ATOM to be DELETED [or enter instruction]'
        ELSE IF (IPR(448) .EQ. 1) THEN
          TXT = 'Click on TEXT [Lower Left Corner] to REPOSITION'
        ELSE IF (IPR(344) .EQ. 1) THEN
          TXT = 'Click on Text [Lower Left Corner] to be DELETED'
        ELSE IF (IPR(343) .EQ. 1) THEN
          TXT = 'Click on ATOM as ZOOM CENTRE'
        ELSE IF (IPR(341) .EQ. 1) THEN
          TXT = 'Click on Atom for GEOM Calculation'
        ELSE IF (IPR(341) .EQ. 2) THEN
          TXT = 'Click on 2 ATOMS for DISTANCE'
        ELSE IF (IPR(341) .EQ. 3) THEN
          TXT = 'Click on 3 ATOMS for ANGLE'
        ELSE IF (IPR(341) .EQ. 4) THEN
          TXT = 'Click on 4 ATOMS for TORSION ANGLE'
        ELSE IF (IPR(341) .EQ. 5) THEN
          TXT = 'Click on 2 ATOMS for LINE 1 and 2 ATOMS FOR LINE 2'
        ELSE IF (IPR(329) .EQ. 1) THEN
          TXT = 'Click on 2 ATOMS for VIEW LINE'
        ELSE IF (IPR(329) .EQ. 2) THEN
          TXT = 'Click on 3 ATOMS for VIEW PERP'
        ELSE IF (IPR(329) .EQ. 3) THEN
          TXT = 'Click on 3 ATOMS for VIEW BISECT'
        ELSE IF (IPR(476) .NE. 0) THEN
          TXT = 'Click on Atoms Defining Plane (or Dist/End)'
        ELSE IF (IPR(552) .NE. 0) THEN
          TXT = 'Click on Atoms Defining Planes (or With/End)'
        ELSE IF (IPR(508) .EQ. 1) THEN
          TXT = 'Click on FROM Atom Followed by TO Atoms and END'
        ELSE IF (IPR(508) .EQ. 2) THEN
          TXT = 'Click on Atoms Defining Cg Terminated with END'
        ELSE IF (IPR(338) .EQ. 1) THEN
          TXT = 'Click on ATOM to Select Color'
        ELSE IF (IPR(334) .EQ. 1) THEN
          WRITE (TXT, '(A, ''['', F4.2, '']'')')
     1         'Click on TEXT [Lower Left Corner] to Change Size',
     2          PAR(350)
        ELSE IF (IPR(352) .EQ. 1) THEN
          TXT = 'Click on ATOM for ANIS [or EXIT] '
        ELSE IF (IPR(332) .EQ. 1) THEN
          TXT =
     1    'Click on ATOM for HFIX (or RETURN for loop over ATOMs)'
        ELSE IF (IPR(440) .EQ. 1) THEN
          TXT = 'Click on ATOM for ''CALC COORDINATION atom'''
        ELSE IF (IPR(213) .EQ. 1) THEN
          TXT = 'Click on ARU-Label for ARU to be Excluded'
        ELSE IF (IPR(536) .GT. 0) THEN
          TXT = 'Click on ATOM to change Atom-Type-Color to '//
     1          COLR(IPR(536))
        ENDIF
        IF (IGBL(45) .NE. 0 .AND. IGBL(3) .NE. 1) THEN
          IF (IPR(20) .EQ. 0) THEN
            IF (IGBL(3) .EQ. 3) THEN
              BCD = 'Click EXIT to Terminate ORTEP/ADP'//CHAR(0)
            ELSE
              BCD =
     1'SAVE-mode Loop (Click on PREV, NEXT or EXIT to escape)'//CHAR(0)
            ENDIF
          ELSE
            BCD = 'Click on END to return to System-S'//CHAR(0)
          ENDIF
          CALL GGIP (-999.0, 3.0, 80.0, 112)
        ENDIF
      ENDIF
      IF (IGBL(23) .GT. 0) THEN
        BCD = TXT//CHAR(0)
        CALL GGIP (-999.0, 2.0, 80.0, 111)
      ENDIF
      IF (NR .NE. 0) IPR(427) = 1
      IGBL(23) = IABS (IGBL(23))
   10 RETURN
      END
      SUBROUTINE PLA016 (MENUV, MENUH)
      PARAMETER (NP4=9,NP10=16,NP12=600,NP13=500,NP17=99,NP22=256,
     1 NP31=30,NP35=110,NP38=125,NP39=30,NP45=2048)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 DID*9, TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0
      COMMON /Q/ ICL, IFL(NP17)
      CHARACTER ICL*(NP45), IFL*7
      COMMON /MEN/ MENA(25, NP31), MENS(25, NP31), MENU(50, NP31),
     1             MNH(NP35)
      COMMON /TIMER/ TIMT, TIMEZ, TIMEA, ISAVEMOD
      COMMON /CGG11/ BCD, SBCD
      CHARACTER BCD*132, SBCD*132
      COMMON /GGT/ MEDIUM
      COMMON /CGGT/ IGGT
      CHARACTER IGGT*80
      COMMON /KEYS/ STRING
      CHARACTER STRING*100
      COMMON /NKEYS/ NCNT
      CHARACTER BWC*5, COLOR*5
      COMMON /LABMOD/ LMOD
      DX = 0.0
      LRET = 1
      IGBL(24) = 1
      IF (IGBL(35) .EQ. 1) THEN
        IF (IPR(504) .EQ. 0) CALL PLA280 ('PLOT')
      ELSE
        CALL GEN038 (IGGT, 1, 80)
      ENDIF
      IF (IPR(346) .GT. 0) THEN
        COLOR = 'COLOR'
      ELSE
        COLOR = ' '
      ENDIF
      IF (IPR(345) .GT. 0) THEN
        BWC   = 'BWC'
      ELSE
        BWC   = ' '
      ENDIF
      MMODE = IGBL(23)
      IF (MMODE .EQ. 1 .OR. MMODE .EQ. 9 .OR. MMODE .EQ. 16) THEN
        PAR(389) = 0.0
        IPR(478) = 0
        ANGC     = 2.0 ** (MENUH - 5)
      ENDIF
      IF (MMODE .EQ. 2 .OR. MMODE .EQ. 3) THEN
        ANGC = 2.0 ** (MENUH - 5)
        DX   = (MENUH - 1) * 0.25
      ENDIF
C * MENU BOX # 0 & EXPOSE EVENT
      IF (MENUV .EQ. 0) THEN
        IF (MMODE .EQ. 1 .OR. MMODE .EQ. 8 .OR. MMODE .EQ. 9) THEN
          IPR(201) = 1
          LRET     = 3
        ELSE IF (MMODE .EQ. 10) THEN
          LRET = 1
        ELSE IF (MMODE .EQ. 12) THEN
          CALL PLA280 ('REF')
        ELSE IF (MMODE .EQ. 22) THEN
          LRET = 2
        ENDIF
C * MENU BOX # 1
      ELSE IF (MENUV .EQ. 1) THEN
        IF (MMODE .EQ. 1) THEN
          IF (MENUH .EQ. 1) THEN
            IGBL(23) = 1
          ELSE
            IGBL(23) = MENUH + 6
          ENDIF
          LRET = -1
        ELSE IF (MMODE .EQ. 2) THEN
          IGBL(23) = MENUH + 1
          LRET     = -1
        ELSE IF (MMODE .EQ. 3) THEN
          IGBL(23) = MENUH + 1
          LRET     = -1
        ELSE IF (MMODE .EQ. 4) THEN
          IGBL(23) = MENUH + 1
          LRET     = -1
        ELSE IF (MMODE .EQ. 5) THEN
          IGBL(23) = MENUH + 1
          LRET     = -1
        ELSE IF (MMODE .EQ. 6) THEN
          IGBL(23) = MENUH + 1
          LRET     = -1
        ELSE IF (MMODE .EQ. 7) THEN
          IGBL(23) = MENUH + 1
          LRET     = -1
        ELSE IF (MMODE .EQ. 8) THEN
          IF (MENUH .EQ. 1) THEN
            IGBL(23) = 1
          ELSE
            IGBL(23) = MENUH + 6
          ENDIF
          IPR(453) = 0
          IPR(448) = 0
          LRET     = -1
        ELSE IF (MMODE .EQ. 9) THEN
          IF (MENUH .EQ. 1) THEN
            IGBL(23) = 1
          ELSE
            IGBL(23) = MENUH + 6
          ENDIF
          IPR(453) = 0
          IPR(448) = 0
          LRET     = -1
        ELSE IF (MMODE .EQ. 10) THEN
          IGBL(23) = MENUH + 9
          LRET     = -1
        ELSE IF (MMODE .EQ. 11) THEN
          IGBL(23) = MENUH + 9
          LRET     = -1
        ELSE IF (MMODE .EQ. 12) THEN
          IGBL(23) = MENUH + 9
          LRET     = -1
        ELSE IF (MMODE .EQ. 15) THEN
        ELSE IF (MMODE .EQ. 16) THEN
          STRING(1:6) = 'L0MAX '
          NCNT        = 6
          SBCD        = STRING(1:NCNT)//CHAR(0)
          CALL PLA015 (539, 1)
          IPR(441) = 0
          IPR(442) = 0
          IPR(443) = 0
          IPR(444) = 0
          IPR(451) = 0
          IPR(540) = 0
          IPR(541) = 0
          IPR(542) = 0
          LRET = -1
        ELSE IF (MMODE .EQ. 17) THEN
          IGBL(23) = 16 + MENUH
          LRET     = -1
        ELSE IF (MMODE .EQ. 18) THEN
          IGBL(23) = 16 + MENUH
          LRET     = -1
        ELSE IF (MMODE .EQ. 19) THEN
          IGBL(23) = 16 + MENUH
          LRET     = -1
        ELSE IF (MMODE .EQ. 20) THEN
          IPR(94) = MENUH + 1
          CALL PLA280 ('RESTART')
        ELSE IF (MMODE .EQ. 21) THEN
          IF (MENUH .EQ. 4) THEN
            WL = PAR(16)
          ELSE IF (MENUH .EQ. 3) THEN
            WL = 1.54178
          ELSE IF (MENUH .EQ. 2) THEN
            WL = 0.71073
          ELSE IF (MENUH .EQ. 1) THEN
            WL = 0.56086
          ENDIF
          CALL PLA293 (WL, 0)
          IPR(500) = 0
          LRET = 4
        ELSE IF (MMODE .EQ. 22) THEN
          IGBL(23) = 23
          LRET     = -1
        ELSE IF (MMODE .EQ. 23) THEN
          IGBL(23) = 22
          LRET     = -1
        ELSE IF (MMODE .EQ. 25) THEN
          IPR(550) = MENUH * 25
          PAR(413) = 32.0
          CALL PLA280 ('CALC')
        ELSE IF (MMODE .EQ. 26) THEN
          PAR(249) = (MENUH - 1) * 10.0
          CALL PLA280 ('CALC ADDSYM')
        ELSE IF (MMODE .EQ. 28) THEN
          IPR(581) = MOD (IPR(581) + 1, 2)
          LRET = 2
        ELSE IF (MMODE .EQ. 29) THEN
          IF (MENUH .EQ. 1) THEN
            PAR(452) = 0.0
          ELSE
            PAR(452) = 0.25 * 2 ** (MENUH - 2)
          ENDIF
          CALL PLA280 ('SIGMA')
        ELSE
          LRET = -1
        ENDIF
C * MENU BOX # 2
      ELSE IF (MENUV .EQ. 2) THEN
        IF (MMODE .EQ. 1) THEN
          IPR(116) = MOD(IPR(116) + 1, 2)
          IF (IPR(116) .EQ. 1) THEN
            IPR(479) = 2
            IF (IGBL(75) .EQ. 1) IPR(201) = 0
            IF (MENUH .EQ. 1) THEN
              IPR(144) = 3
            ELSE
              IPR(144) = 4
            ENDIF
          ELSE
            IPR(479) = 2
            PAR(389) = 0.0
            IPR(201) = 0
          ENDIF
          LRET = 2
        ELSE IF (MMODE .EQ. 2) THEN
          IF (IPR(116) .EQ. 0) THEN
            IF (MENUH .EQ. 1) THEN
              CALL PLA280 ('STEREO RG')
            ELSE IF (MENUH .EQ. 2) THEN
              CALL PLA280 ('STEREO RB')
            ELSE IF (MENUH .EQ. 3) THEN
              CALL PLA280 ('STEREO')
            ELSE
              CALL PLA280 ('STEREO  S')
            ENDIF
          ELSE
            CALL PLA280 ('MONO')
          ENDIF
        ELSE IF (MMODE .EQ. 3) THEN
          IPR(173) = MOD(IPR(173) + 1, 2)
          CALL PLA280 ('PLOT')
        ELSE IF (MMODE .EQ. 4) THEN
          CALL PLA015 (348, 1)
          IF (IPR(348) .EQ. 1) IPR(345) = 1
          IPR(461) = MENUH - 1
          LRET = -1
        ELSE IF (MMODE .EQ. 5) THEN
          CALL PLA280 ('VIEW UNIT')
        ELSE IF (MMODE .EQ. 6) THEN
          CALL PLA015 (341, 2)
          LRET = -1
        ELSE IF (MMODE .EQ. 7) THEN
          CALL PLA280 ('MENU OFF')
        ELSE IF (MMODE .EQ. 8) THEN
          IPR(173) = MOD(IPR(173) + 1, 2)
          LRET     =  4
        ELSE IF (MMODE .EQ. 9) THEN
          IGBL(69) = MOD(IGBL(69) + 1, 2)
          YGGIP    = - 100 * (IGBL(69) + 1)
          CALL GGIP (0.0, YGGIP, 0.0, 0)
        ELSE IF (MMODE .EQ. 10) THEN
          IF (IPR(30) .EQ. 0) IGBL(30) = MOD(IGBL(30) + 1, 2)
          LRET = -1
        ELSE IF (MMODE .EQ. 11) THEN
          IPR(29)  = MOD(IPR(29) + 1, 2)
          IF (IPR(29) .EQ. 0) THEN
            IPR(579) = IPR(219)
          ELSE
            IPR(579) = IPR(216)
          ENDIF
          LRET     = -1
        ELSE IF (MMODE .EQ. 14) THEN
          IPR(394) = 1
          LRET     = 3
        ELSE IF (MMODE .EQ. 16) THEN
          STRING(1:6) = 'L1MAX '
          NCNT        = 6
          SBCD = STRING(1:NCNT)//CHAR(0)
          CALL PLA015 (540, 1)
          IPR(441) = 0
          IPR(442) = 0
          IPR(443) = 0
          IPR(444) = 0
          IPR(451) = 0
          IPR(539) = 0
          IPR(541) = 0
          IPR(542) = 0
          LRET = -1
        ELSE IF (MMODE .EQ. 17 .OR. MMODE .EQ. 18) THEN
          IF (MENUH .EQ. 1) THEN
            CALL PLA280 ('LOG')
          ELSE IF (MENUH .EQ. 2) THEN
            CALL PLA280 ('RELINK BACK')
          ELSE
            CALL PLA280 ('RELINK FORWARD')
          ENDIF
        ELSE IF (MMODE .EQ. 20) THEN
          PAR(441) = (MENUH - 1) * 0.1
          CALL PLA280 ('RESTART')
        ELSE IF (MMODE .EQ. 19) THEN
          IGBL(44) = MOD(IGBL(44) + 1, 2)
          IF (IGBL(44) .EQ. 1) CALL PLA015 (0, 36)
          LRET = -1
        ELSE IF (MMODE .EQ. 21) THEN
          CALL PLA015 (549, 1)
          IF (IPR(549) .EQ. 1) THEN
            STRING = 'RADN '
            NCNT   = 5
            SBCD   = STRING(1:NCNT)//CHAR(0)
          ELSE
            STRING = ' '
            NCNT   = 0
          ENDIF
          LRET = -1
        ELSE IF (MMODE .EQ. 22) THEN
          CALL PLA280 ('FO')
          M = MIN (NINT (PAR(412) * 5.0), 4)
          IF (MENUH .NE. M) THEN
            IF (MENUH .LT. 4) THEN
              PAR(412) = MENUH * 0.2
            ELSE
              PAR(412) = 99.0
            ENDIF
            IPR(414) = 1
            LRET     = 3
          ELSE
            IF (IPR(414) .NE. 1) THEN
              IPR(414)  = 1
            ELSE
              LRET = -1
            ENDIF
          ENDIF
        ELSE IF (MMODE .EQ. 23) THEN
          CALL PLA280 ('PT')
          M = MIN (NINT (PAR(412) * 5.0), 4)
          IF (MENUH .NE. M) THEN
            IF (MENUH .LT. 4) THEN
              PAR(412) = MENUH * 0.2
            ELSE
              PAR(412) = 99.0
            ENDIF
            IPR(414) = 5
            LRET     = 3
          ELSE
            IF (IPR(414) .NE. 5) THEN
              IPR(414) = 5
            ELSE
              LRET = -1
            ENDIF
          ENDIF
        ELSE IF (MMODE .EQ. 24) THEN
          IF (IPR(533) .EQ. MENUH) THEN
            IPR(116) = MOD(IPR(116) + 1, 2)
            IPR(533) = 1
          ELSE
            IF (MENUH .EQ. 2 .AND. IPR(116) .EQ. 0) IPR(116) = 1
            IPR(533) = MENUH
          ENDIF
        ELSE IF (MMODE .EQ. 25) THEN
          PAR(413) = 2 ** (MENUH - 1)
          CALL PLA280 ('CALC')
        ELSE IF (MMODE .EQ. 26) THEN
          PAR(43) = MENUH * 0.2
          CALL PLA280 ('CALC ADDSYM')
        ELSE IF (MMODE .EQ. 28) THEN
          PAR(450) = MENUH * 2.5
          CALL PLA280 ('CALC RDF')
        ELSE IF (MMODE .EQ. 30) THEN
          IPR(346) = MOD(IPR(346) + 1, 2)
          LRET = 3
        ELSE
          LRET = -1
        ENDIF
C * MENU BOX # 3
      ELSE IF (MENUV .EQ. 3) THEN
        IF (MMODE .EQ. 1) THEN
          IPR(212) = MOD(IPR(212) + 1, 2)
          IPR(201) = 0
          LRET = 4
        ELSE IF (MMODE .EQ. 2) THEN
          IF (IPR(212) .EQ. 1) THEN
            CALL PLA280 ('EXCLUDE H')
            IPR(212) = 0
          ELSE
            CALL PLA280 ('INCLUDE H')
            IPR(212) = 1
          ENDIF
        ELSE IF (MMODE .EQ. 3) THEN
          IPR(173) = 1
          IPR(344) = 0
          IPR(453) = MOD(IPR(453) + 1, 2)
          IF (IPR(453) .EQ. 1) THEN
            CALL PLA280 ('TEXT')
            IPR(448)  = 0
          ELSE
            IPR(448) = 1
          ENDIF
        ELSE IF (MMODE .EQ. 4) THEN
          CALL PLA015 (338, 1)
          IF (IPR(338) .EQ. 1) THEN
            IPR(346) = 1
          ENDIF
          LRET = -1
        ELSE IF (MMODE .EQ. 5) THEN
          CALL PLA280 ('VIEW MIN')
        ELSE IF (MMODE .EQ. 6) THEN
          CALL PLA015 (341, 3)
          LRET = -1
        ELSE IF (MMODE .EQ. 7) THEN
          PAR(48) = (MENUH - 1) * 10.0
        ELSE IF (MMODE .EQ. 8) THEN
          IPR(173) = 1
          IPR(453) = MOD(IPR(453) + 1, 2)
          LRET     = 5
        ELSE IF (MMODE .EQ. 9) THEN
          IF (IPR(44) .NE. 0) THEN
            IF (MENUH - 1 .NE. IGBL(88)) THEN
              IF (IGBL(59) .EQ. 1) THEN
                IGBL(88) = MENUH - 1
              ELSE
                IGBL(59) = MOD(IGBL(59) + 1, 2)
              ENDIF
            ELSE
              IGBL(59) = MOD(IGBL(59) + 1, 2)
              IGBL(88) = MENUH - 1
            ENDIF
          ENDIF
          IPR(201) = 0
          LRET = 4
        ELSE IF (MMODE .EQ. 10) THEN
          IF (IPR(44) .NE. 0) THEN
            IF (MENUH - 1 .NE. IGBL(88)) THEN
              IF (IGBL(59) .EQ. 1) THEN
                IGBL(88) = MENUH - 1
              ELSE
                IGBL(59) = MOD(IGBL(59) + 1, 2)
              ENDIF
            ELSE
              IGBL(59) = MOD(IGBL(59) + 1, 2)
              IGBL(88) = MENUH - 1
            ENDIF
          ENDIF
          LRET     = -1
        ELSE IF (MMODE .EQ. 11) THEN
          IPR(592) = MOD(IPR(592) + 1, 2)
          LRET = -1
        ELSE IF (MMODE .EQ. 14) THEN
          IPR(394) = 2
          LRET = 3
        ELSE IF (MMODE .EQ. 15) THEN
          IPR(446) = MENUH - 1
          IF (IPR(446) .EQ. 0) IPR(428) = 1
        ELSE IF (MMODE .EQ. 16) THEN
          STRING(1:5) = 'TMIN '
          NCNT = 5
          SBCD = STRING(1:NCNT)//CHAR(0)
          CALL PLA015 (541, 1)
          IPR(441) = 0
          IPR(442) = 0
          IPR(443) = 0
          IPR(444) = 0
          IPR(451) = 0
          IPR(540) = 0
          IPR(541) = 0
          IPR(542) = 0
          LRET = -1
        ELSE IF (MMODE .EQ. 17) THEN
          IF (MENUH .EQ. 1) THEN
            CALL PLA280 ('DELABS')
          ELSE IF (MENUH .EQ. 2) THEN
            CALL PLA280 ('MULABS')
          ENDIF
        ELSE IF (MMODE .EQ. 18) THEN
          IF (MENUH .EQ. 1) THEN
            CALL PLA280 ('TREE')
          ELSE
            CALL PLA280 ('LIST')
          ENDIF
        ELSE IF (MMODE .EQ. 19) THEN
          CALL PLA280 ('EDITRES')
        ELSE IF (MMODE .EQ. 20) THEN
          PAR(439) = 0.125 * 2 ** (MENUH - 1)
        ELSE IF (MMODE .EQ. 21) THEN
          PAR(372) = 2 ** (MENUH - 1)
          LRET = 3
        ELSE IF (MMODE .EQ. 22) THEN
          CALL PLA280 ('FS')
          M = MIN (NINT (PAR(412) * 5.0), 4)
          IF (MENUH .NE. M) THEN
            IF (MENUH .LT. 4) THEN
              PAR(412) = MENUH * 0.2
            ELSE
              PAR(412) = 99.0
            ENDIF
            IPR(414) = 2
            LRET     = 3
          ELSE
            IF (IPR(414) .NE. 2) THEN
              IPR(414) = 2
            ELSE
              LRET = -1
            ENDIF
          ENDIF
        ELSE IF (MMODE .EQ. 24) THEN
          IPR(534) = MENUH
        ELSE IF (MMODE .EQ. 25) THEN
          IPR(567) = MENUH * 5
          CALL PLA280 ('CALC')
        ELSE IF (MMODE .EQ. 26) THEN
          PAR(404 - IGBL(97) * 3) = MENUH * 0.1  - 0.05
          CALL PLA280 ('CALC ADDSYM')
        ELSE IF (MMODE .EQ. 28) THEN
          PAR(451) = MENUH * 2.5
          CALL PLA280 ('CALC RDF')
        ELSE IF (MMODE .EQ. 30) THEN
          IPR(355) = MOD(IPR(355) + 1, 2)
          LRET = 3
        ELSE
          LRET = -1
        ENDIF
C * MENU BOX # 4
      ELSE IF (MENUV .EQ. 4) THEN
        IF (MMODE .EQ. 1) THEN
          CALL PLA015 (351, 1)
          IPR(349) = 0
          LRET     = -1
        ELSE IF (MMODE .EQ. 2 .OR. MMODE .EQ. 4) THEN
          PAR351 = (6 - MENUH) * 0.1
          IF (IABS(IPR(4)) .NE. 1 .OR. PAR(351) .NE. PAR351) THEN
            PAR(351) = PAR351
            IPR(4)   = 0
            CALL PLA280 ('SOLID '//BWC//COLOR)
          ELSE
            CALL PLA280 ('STICK '//COLOR)
          ENDIF
        ELSE IF (MMODE .EQ. 3) THEN
          CALL PLA015 (448, 1)
          IF (IPR(448) .EQ. 1) IPR(453) = 0
          LRET = -1
        ELSE IF (MMODE .EQ. 5) THEN
          CALL PLA280 ('VIEW XO')
        ELSE IF (MMODE .EQ. 6) THEN
          CALL PLA015 (341, 4)
          LRET = -1
        ELSE IF (MMODE .EQ. 7) THEN
          IF (IPR(30) .EQ. 0) THEN
            IGBL(97) = MOD(IGBL(97) + 1, 2)
          ENDIF
          LRET = -1
        ELSE IF (MMODE .EQ. 8) THEN
          CALL PLA015 (448, 1)
          IF (IPR(448) .EQ. 1) IPR(453) = 0
          LRET = -1
        ELSE IF (MMODE .EQ. 9) THEN
          IF (IPR(431) .EQ. -2) THEN
            IGBL(104) = MOD(IGBL(104) + 1, 2)
          ELSE
            LRET = -1
          ENDIF
        ELSE IF (MMODE .EQ. 10) THEN
          IF (IPR(30) .EQ. 0) THEN
            IGBL(97) = MOD(IGBL(97) + 1, 2)
          ENDIF
          LRET = -1
        ELSE IF (MMODE .EQ. 11) THEN
          IGBL(56) = MOD(IGBL(56) + 1, 2)
          LRET     = -1
        ELSE IF (MMODE .EQ. 14) THEN
          IPR(394) = 3
          LRET     = 3
        ELSE IF (MMODE .EQ. 16) THEN
          STRING(1:5) = 'TMAX '
          NCNT        = 5
          SBCD        = STRING(1:NCNT)//CHAR(0)
          CALL PLA015 (542, 1)
          IPR(441) = 0
          IPR(442) = 0
          IPR(443) = 0
          IPR(444) = 0
          IPR(451) = 0
          IPR(539) = 0
          IPR(540) = 0
          IPR(541) = 0
          LRET     = -1
        ELSE IF (MMODE .EQ. 17) THEN
          IF (MENUH .EQ. 1) THEN
            CALL PLA280 ('ABSTOMPA')
          ELSE IF (MENUH .EQ. 2) THEN
            CALL PLA280 ('ABSPSI')
          ELSE IF (MENUH .EQ. 3) THEN
            CALL PLA280 ('ABSNONE')
          ENDIF
        ELSE IF (MMODE .EQ. 18) THEN
          CALL PLA280 ('REMOVE')
        ELSE IF (MMODE .EQ. 20) THEN
          IPR(514) = 2 * MENUH - 1
          CALL PLA280 ('RESTART')
        ELSE IF (MMODE .EQ. 21) THEN
          IPR(500) = MENUH
          LRET = 3
        ELSE IF (MMODE .EQ. 22) THEN
          CALL PLA280 ('DI')
          M = MIN (NINT (PAR(412) * 5.0), 4)
          IF (MENUH .NE. M) THEN
            IF (MENUH .LT. 4) THEN
              PAR(412) = MENUH * 0.2
            ELSE
              PAR(412) = 99.0
            ENDIF
            IPR(414) = 3
            LRET     = 3
          ELSE
            IF (IPR(414) .NE. 3) THEN
              IPR(414) =  3
            ELSE
              LRET = -1
            ENDIF
          ENDIF
        ELSE IF (MMODE .EQ. 24) THEN
          IPR(526) = 1
        ELSE IF (MMODE .EQ. 25) THEN
          PAR(414) = MENUH * 0.05
          CALL PLA280 ('CALC')
        ELSE IF (MMODE .EQ. 26) THEN
          PAR(405 - IGBL(97) * 3) = MENUH * 0.1 -0.05
          CALL PLA280 ('CALC ADDSYM')
        ELSE
          LRET = -1
        ENDIF
C * MENU BOX # 5
      ELSE IF (MENUV .EQ. 5) THEN
        IF (MMODE .EQ. 1) THEN
          IPR(45)  = MENUH
          IPR(201) = 0
          LRET     = 2
        ELSE IF (MMODE .EQ. 2 .OR. MMODE .EQ. 4) THEN
          IF (IABS(IPR(4)) .NE. 2) THEN
            CALL PLA280 ('ROD   '//BWC//COLOR)
          ELSE
            CALL PLA280 ('STICK '//COLOR)
          ENDIF
        ELSE IF (MMODE .EQ. 3 .OR. MMODE .EQ. 8) THEN
          PAR(350) =  0.20 + 0.05 * MENUH
          LRET = -1
        ELSE IF (MMODE .EQ. 4) THEN
          LRET = -1
        ELSE IF (MMODE .EQ. 5) THEN
          CALL PLA280 ('VIEW YO')
        ELSE IF (MMODE .EQ. 6) THEN
          CALL PLA015 (341, 1)
          LRET = -1
        ELSE IF (MMODE .EQ. 7) THEN
          IGBL(105) = MOD(IGBL(105) + 1, 2)
        ELSE IF (MMODE .EQ. 9) THEN
          IGBL(105) = MOD(IGBL(105) + 1, 2)
          IPR(201)  = 0
          LRET      = 2
        ELSE IF (MMODE .EQ. 10) THEN
          IPR(68) = MENUH - 1
          LRET = -1
        ELSE IF (MMODE .EQ. 11) THEN
          IF (IPR(30) .EQ. 0) THEN
            IPR(501) = MOD (IPR(501) + 1, 2)
            IPR(119) = 0
          ENDIF
          LRET = -1
        ELSE IF (MMODE .EQ. 15) THEN
          IPR(320) = MOD (IPR(320) + 1, 2)
        ELSE IF (MMODE .EQ. 16) THEN
          CALL PLA015 (441, 1)
          IPR(442) = 0
          IPR(443) = 0
          IPR(444) = 0
          IPR(451) = 0
          IPR(539) = 0
          IPR(540) = 0
          IPR(541) = 0
          IPR(542) = 0
          IF (IPR(441) .EQ. 1) THEN
            STRING = 'MU'
            NCNT = 3
            SBCD  = STRING(1:NCNT)//CHAR(0)
          ELSE
            NCNT = 0
            STRING = ' '
          ENDIF
          LRET = -1
        ELSE IF (MMODE .EQ. 17) THEN
          IF (MENUH .EQ. 1) THEN
            CALL PLA280 ('TRMX')
          ELSE
            CALL PLA280 ('SPGR')
          ENDIF
        ELSE IF (MMODE .EQ. 18) THEN
          CALL PLA280 ('XTAL')
        ELSE IF (MMODE .EQ. 20) THEN
          IPR(117) = MENUH
        ELSE IF (MMODE .EQ. 21) THEN
          PAR(411) = MENUH / 100.0
          LRET = 3
        ELSE IF (MMODE .EQ. 22) THEN
          IF (IGBL(29) .LT. 0) THEN
            CALL PLA280 ('SQ')
            M = MIN (NINT (PAR(412) * 5.0), 4)
            IF (MENUH .NE. M) THEN
              IF (MENUH .LT. 4) THEN
                PAR(412) = MENUH * 0.2
              ELSE
                PAR(412) = 99.0
              ENDIF
              IPR(414) = 4
              LRET     = 3
            ELSE
              IF (IPR(414) .NE. 4) THEN
                IPR(414)  = 4
              ELSE
                LRET = -1
              ENDIF
            ENDIF
          ELSE
            CALL PLA015 (427, 7)
            LRET = -1
          ENDIF
        ELSE IF (MMODE .EQ. 24) THEN
          IPR(526) = 2
        ELSE IF (MMODE .EQ. 25) THEN
          IPR(469) = MOD(IPR(469) + 1, 2)
          CALL PLA280 ('CALC')
        ELSE IF (MMODE .EQ. 26) THEN
          PAR(406 - IGBL(97) * 3) = MENUH * 0.1 - 0.05
          CALL PLA280 ('CALC ADDSYM')
        ELSE
          LRET = -1
        ENDIF
C * MENU BOX # 6
      ELSE IF (MENUV .EQ. 6) THEN
        IF (MMODE .EQ. 1) THEN
          CALL PLA015 (440, 1)
          IPR(351) = 0
          IPR(349) = 0
          IPR(327) = 0
          IPR(328) = 0
          LRET = -1
        ELSE IF (MMODE .EQ. 2 .OR. MMODE .EQ. 4) THEN
          IF (IABS(IPR(4)) .NE. 3) THEN
            IF (MENUH .EQ. 1) THEN
              CALL PLA280 ('CPK '//BWC//COLOR)
            ELSE IF (MENUH .EQ. 2) THEN
              CALL PLA280 ('CPK STICK '//BWC//COLOR)
            ENDIF
          ELSE
            CALL PLA280 ('STICK '//COLOR)
          ENDIF
        ELSE IF (MMODE .EQ. 3) THEN
          CALL PLA015 (344, 1)
          LRET = -1
        ELSE IF (MMODE .EQ. 5) THEN
          CALL PLA280 ('VIEW ZO')
        ELSE IF (MMODE .EQ. 6) THEN
          IPR(90) = 256
          CALL PLUT12
        ELSE IF (MMODE .EQ. 7) THEN
          IPR(14)  = MOD (IPR(14) + 1, 2)
        ELSE IF (MMODE .EQ. 8) THEN
          IPR(453) = 0
          CALL PLA015 (344, 1)
          LRET = -1
        ELSE IF (MMODE .EQ. 9) THEN
          IPR(506) = MOD(IPR(506) + 1, 2)
          IPR(201) = 0
          LRET     = 2
        ELSE IF (MMODE .EQ. 10) THEN
          IF (IGBL(71) .EQ. 0) IPR(119) = MOD (IPR(119) + 1, 2)
          LRET = -1
        ELSE IF (MMODE .EQ. 11) THEN
          IPR(502) = MOD (IPR(502) + 1, 2)
          LRET = -1
        ELSE IF (MMODE .EQ. 14) THEN
          IPR(406) = MOD (IPR(406) + 1, 2)
          IPR(389) = 0
          LRET     = 4
        ELSE IF (MMODE .EQ. 15) THEN
          IPR(428) = MOD (IPR(428) + 1, 2)
          IF (IPR(428) .EQ. 0) IPR(446) = 1
        ELSE IF (MMODE .EQ. 16) THEN
          CALL PLA015 (442, 1)
          IPR(441) = 0
          IPR(443) = 0
          IPR(444) = 0
          IPR(451) = 0
          IPR(539) = 0
          IPR(540) = 0
          IPR(541) = 0
          IPR(542) = 0
          IF (IPR(442) .EQ. 1) THEN
            STRING = 'RADIUS'
            NCNT   = 7
            SBCD   = STRING(1:NCNT)//CHAR(0)
          ELSE
            STRING = ' '
            NCNT   = 0
          ENDIF
          LRET = -1
        ELSE IF (MMODE .EQ. 17) THEN
          IF (MENUH .EQ. 1) THEN
            CALL PLA280 ('FORMULA')
          ELSE
            CALL PLA280 ('Z')
          ENDIF
        ELSE IF (MMODE .EQ. 18) THEN
          IF (MENUH .EQ. 1) THEN
            CALL PLA280 ('CELL')
          ELSE
            CALL PLA280 ('HELENA')
          ENDIF
        ELSE IF (MMODE .EQ. 19) THEN
          CALL PLA280 ('TWIN')
        ELSE IF (MMODE .EQ. 20) THEN
          PAR(440) = 10 ** MENUH
        ELSE IF (MMODE .EQ. 21) THEN
          IF (MENUH .LT. 3) THEN
            PAR(371) = 10 ** (3 - MENUH)
          ELSE
            PAR(371) = 1.0 / 10 ** (MENUH - 3)
          ENDIF
          LRET = 3
        ELSE IF (MMODE .EQ. 22) THEN
          CALL PLA280 ('PLAN')
          IPR(416)  = 0
          IPR(420)  = 0
        ELSE IF (MMODE .EQ. 24) THEN
          IPR(526) = 3
        ELSE IF (MMODE .EQ. 25) THEN
          MEDIUM      = 2
          IGGT(16:22) = 'ON     '
          CALL GGIP (-999.0, 0.0, 0.0, 6)
          CALL PLA280 ('PLOT')
        ELSE IF (MMODE .EQ. 26) THEN
          IPR(568) = MOD (IPR(568) + 1, 2)
          LRET = -1
        ELSE
          LRET = -1
        ENDIF
C * MENU BOX # 7
      ELSE IF (MENUV .EQ. 7) THEN
        IF (MMODE .EQ. 1) THEN
          CALL PLA015 (341, MENUH + 1)
          LRET = -1
        ELSE IF (MMODE .EQ. 2 .OR. MMODE .EQ. 4) THEN
          IF (IABS(IPR(4)) .NE. 4) THEN
            CALL PLA280 ('STRAW '//BWC//COLOR)
          ELSE
            CALL PLA280 ('STICK '//COLOR)
          ENDIF
        ELSE IF (MMODE .EQ. 3 .OR. MMODE .EQ. 8) THEN
          CALL PLA015 (334, 1)
          LRET = -1
        ELSE IF (MMODE .EQ. 5) THEN
          CALL PLA280 ('VIEW AFACE')
        ELSE IF (MMODE .EQ. 6) THEN
          IPR(90) =  16
          CALL PLUT12
        ELSE IF (MMODE .EQ. 7) THEN
          IF (IPR(17) .EQ. 0) IGBL(30) = MOD(IGBL(30) + 1, 2)
          LRET = -1
        ELSE IF (MMODE .EQ. 9) THEN
          IGBL(55) = MOD (IGBL(55) + 1, 2)
        ELSE IF (MMODE .EQ. 10) THEN
          IGBL(55) = MOD (IGBL(55) + 1, 2)
          LRET = -1
        ELSE IF (MMODE .EQ. 11) THEN
          IPR(497) = MOD(IPR(497) + 1, 2)
          LRET = -1
        ELSE IF (MMODE .EQ. 14) THEN
          IPR(387) = MOD (IPR(387) + 1, 2)
          IPR(389) = 0
          LRET     = 4
        ELSE IF (MMODE .EQ. 15) THEN
          IF (IPR(370) .EQ. 0) IPR(424) = MENUH - 1
        ELSE IF (MMODE .EQ. 16) THEN
          CALL PLA015 (443, 1)
          IPR(441) = 0
          IPR(442) = 0
          IPR(444) = 0
          IPR(451) = 0
          IF (IPR(443) .EQ. 1) THEN
            STRING = 'MUR'
            NCNT   = 4
            SBCD   = STRING(1:NCNT)//CHAR(0)
          ELSE
            STRING = ' '
            NCNT   = 0
          ENDIF
          LRET = -1
        ELSE IF (MMODE .EQ. 17) THEN
          IF (MENUH .EQ. 1) THEN
            CALL PLA280 ('SHELXS97 TREF')
          ELSE IF (MENUH .EQ. 2) THEN
            CALL PLA280 ('SHELXS97 PATT')
          ELSE
            CALL PLA280 ('SHELXD')
          ENDIF
        ELSE IF (MMODE .EQ. 18) THEN
          CALL PLA280 ('PLATON CSD')
        ELSE IF (MMODE .EQ. 22) THEN
          CALL PLA280 ('PLAN')
          IPR(416)  = 1
          IPR(420)  = 0
        ELSE IF (MMODE .EQ. 25) THEN
          IF (IPR(543) .EQ. 1) THEN
            IPR(543) = 0
          ELSE
            IPR(543) = 1
            CALL PLA280 ('TWIN')
            IPR(576) = 0
          ENDIF
        ELSE
          LRET = -1
        ENDIF
C * MENU BOX # 8
      ELSE IF (MENUV .EQ. 8) THEN
        IF (MMODE .EQ. 1) THEN
          CALL PLA015 (311, MENUH)
          LRET = -1
        ELSE IF (MMODE .EQ. 2 .OR. MMODE .EQ. 4) THEN
          IF (IABS(IPR(4)) .NE. 0) THEN
            CALL PLA280 ('STICK '//COLOR)
          ELSE
            CALL PLA280 ('STRAW '//BWC//COLOR)
          ENDIF
        ELSE IF (MMODE .EQ. 3) THEN
          CALL PLA015 (351, 1)
          IF (IPR(335) .EQ. 1) CALL PLA015 (335, 1)
          IF (IPR(349) .EQ. 1) CALL PLA015 (349, 1)
          IF (IGBL(75) .EQ. 0) THEN
            CALL PLA280 ('LABEL ON')
          ELSE
            LRET = -1
          ENDIF
        ELSE IF (MMODE .EQ. 5) THEN
          CALL PLA280 ('VIEW BFACE')
        ELSE IF (MMODE .EQ. 6) THEN
          IPR(90) =  32
          CALL PLUT12
        ELSE IF (MMODE .EQ. 7) THEN
          IPR(231) = MOD (IPR(231) + 1, 2)
        ELSE IF (MMODE .EQ. 8) THEN
          PAR(7) = 2.0 + MENUH
          LRET = -1
        ELSE IF (MMODE .EQ. 9) THEN
          IF (IPR(75) .GT. 1) THEN
            CALL PLA015 (312, 1)
            IFL(1)  = 'FIT'
            IPR(33) = MENUH - 1
            IF (IPR(312) .EQ. 0) THEN
              IPR(81) = - LMOD - 1
              CALL PLA035 (1)
              LMOD = 0
              IGBL(23) = IABS(IGBL(23))
            ENDIF
          ENDIF
          LRET = -1
        ELSE IF (MMODE .EQ. 10) THEN
          IPR(324) = MOD (IPR(324) + 1, 2)
          LRET = -1
        ELSE IF (MMODE .EQ. 11) THEN
          IGBL(61) = MOD (IGBL(61) + 1, 2)
          LRET = -1
        ELSE IF (MMODE .EQ. 14) THEN
          IPR(388) = MOD (IPR(388) + 1, 2)
          IPR(389) = 0
          LRET     = 4
        ELSE IF (MMODE .EQ. 15) THEN
          IF (IPR(370) .EQ. 0) IPR(425) = MENUH -1
        ELSE IF (MMODE .EQ. 16) THEN
          CALL PLA015 (444, 1)
          IPR(441) = 0
          IPR(442) = 0
          IPR(443) = 0
          IPR(451) = 0
          IF (IPR(444) .EQ. 1) THEN
            STRING = 'GRID'
            NCNT   = 5
            SBCD   = STRING(1:NCNT)//CHAR(0)
          ELSE
            STRING = ' '
            NCNT   = 0
          ENDIF
          LRET = -1
        ELSE IF (MMODE .EQ. 17) THEN
          IF (MENUH .EQ. 1) THEN
            CALL PLA280 ('DIRDIF PATTY')
          ELSE
            CALL PLA280 ('DIRDIF ORIENT')
          ENDIF
        ELSE IF (MMODE .EQ. 18) THEN
          VAL = 1.0
          IF (MENUH .EQ. 1) THEN
            VAL = 0.54
          ELSE IF (MENUH .EQ. 2) THEN
            VAL = 0.60
          ELSE IF (MENUH .EQ. 3) THEN
            VAL = 0.65
          ENDIF
          WRITE (IGGT, '(''STLM'', F10.2, 5X)') VAL
          PAR(453) = VAL
        ELSE IF (MMODE .EQ. 19) THEN
          IGBL(91) = MOD(IGBL(91) + 1, 2)
          LRET = -1
        ELSE IF (MMODE .EQ. 22) THEN
          CALL PLA280 ('PLAN')
          IPR(416)  = 2
          IPR(420)  = 0
        ELSE IF (MMODE .EQ. 23) THEN
          IPR(577) = (MENUH * 2) - 1
          LRET = -1
        ELSE IF (MMODE .EQ. 25) THEN
          IF (IPR(543) .EQ. 2) THEN
            IPR(543) = 0
          ELSE
            IPR(543) = 2
            CALL PLA280 ('TWIN')
            IPR(576) = 0
          ENDIF
        ELSE
          LRET = -1
        ENDIF
C * MENU BOX # 9
      ELSE IF (MENUV .EQ. 9) THEN
        IF (MMODE .EQ. 1) THEN
          IF (MENUH .EQ. 1) THEN
            LMOD     = 1
            IFL(1)   = 'DEFINE'
            IPR(507) = 1
            CALL PLA015 (508, 1)
            LRET     = -1
          ELSE IF (MENUH .EQ. 3) THEN
            IF (IPR(508) .EQ. 1) THEN
              IPR(507) = 3
              IPR(508) = 0
              WRITE (IGGT, 99995) (IFL(I), I = 1, LMOD)
              IGBL(23) = IABS(IGBL(23))
              LRET = 7
            ENDIF
          ENDIF
        ELSE IF (MMODE .EQ. 2 .OR. MMODE .EQ. 4) THEN
   10     IPR(345) = MOD(IPR(345) + 1, 2)
          IF (IPR(345) .EQ. 1) THEN
            IF (MENUH .EQ. 1) THEN
              IPR(478) = 0
            ELSE IF (MENUH .EQ. 2) THEN
              IPR(478) = -1
            ELSE
              IPR(478) = 1
            ENDIF
          ELSE
            IF (MENUH * IPR(478) .EQ. -2 .OR.
     1          MENUH * IPR(478) .EQ.  3 .OR.
     2          (MENUH .EQ. 1 .AND. IPR(478) .EQ. 0)) THEN
              IPR(478) = 0
            ELSE
              IPR(478) = 0
              GOTO 10
            ENDIF
          ENDIF
          IF (IGBL(35) .EQ. 1) THEN
            CALL PLA280 ('PLOT')
          ELSE
            LRET = -1
          ENDIF
        ELSE IF (MMODE .EQ. 3) THEN
          IF (IPR(351) .EQ. 1) CALL PLA015 (351, 1)
          IF (IPR(349) .EQ. 1) CALL PLA015 (349, 1)
          IF (IGBL(3) .NE. 0) THEN
            CALL PLA015 (335, 1)
            IF (IGBL(75) .EQ. 0) THEN
              CALL PLA280 ('LABEL ON')
            ELSE
              LRET = -1
            ENDIF
          ELSE
            CALL PLA015 (427, 40)
            LRET = -1
          ENDIF
        ELSE IF (MMODE .EQ. 5) THEN
          CALL PLA280 ('VIEW CFACE')
        ELSE IF (MMODE .EQ. 6) THEN
          IPR(90) = 512
          CALL PLUT12
        ELSE IF (MMODE .EQ. 8) THEN
          IGBL(52) = MOD (IGBL(52) + 1, 2)
          LRET = -1
        ELSE IF (MMODE .EQ. 9) THEN
          IF (IPR(75) .GT. 1) THEN
            IPR(33) = MENUH - 1
            CALL PLA280 ('FIT 1 2')
          ELSE
            LRET = -1
          ENDIF
        ELSE IF (MMODE .EQ. 10) THEN
          IPR(87) = MOD(IPR(87) + 1, 2)
          LRET = -1
        ELSE IF (MMODE .EQ. 11) THEN
          IF (IPR(30) .EQ. 0) IPR(181) = MOD(IPR(181) + 1, 2)
          LRET = -1
        ELSE IF (MMODE .EQ. 15) THEN
          IF (IPR(370) .EQ. 0) IPR(426) = MENUH - 1
        ELSE IF (MMODE .EQ. 16) THEN
          CALL PLA015 (451, 1)
          IPR(441) = 0
          IPR(442) = 0
          IPR(443) = 0
          IPR(444) = 0
          IF (IPR(451) .EQ. 1) THEN
            STRING = 'FACE'
            NCNT   = 5
            SBCD   = STRING(1:NCNT)//CHAR(0)
          ELSE
            STRING = ' '
            NCNT   = 0
          ENDIF
          LRET = -1
        ELSE IF (MMODE .EQ. 17) THEN
          IF (MENUH .EQ. 1) THEN
            CALL PLA280 ('SHELXS86')
          ELSE IF (MENUH .EQ. 2) THEN
            CALL PLA280 ('SIR97')
          ELSE IF (MENUH .EQ. 3) THEN
            CALL PLA280 ('SIR2002')
          ENDIF
        ELSE IF (MMODE .EQ. 18) THEN
          IGBL(97) = MOD(IGBL(97) + 1, 2)
        ELSE IF (MMODE .EQ. 19) THEN
          IGBL(51) = MOD(IGBL(51) + 1, 2)
          LRET = -1
        ELSE IF (MMODE .EQ. 22) THEN
          CALL PLA280 ('PLAN')
          IPR(416)  = 3
          IPR(420)  = 0
        ELSE IF (MMODE .EQ. 23) THEN
          IPR(578) = (MENUH * 2) - 1
          LRET = -1
        ELSE IF (MMODE .EQ. 24) THEN
          IPR(537) = MOD(IPR(537) + 1, 2)
        ELSE IF (MMODE .EQ. 25) THEN
          IF (IPR(543) .EQ. 3) THEN
            IPR(543) = 0
          ELSE
            IPR(543) = 3
            CALL PLA280 ('TWIN')
            IPR(576) = 0
          ENDIF
        ELSE IF (MMODE .EQ. 26) THEN
          IPR(503) = MOD(IPR(503) + 1, 2)
          LRET = -1
        ELSE
          LRET = -1
        ENDIF
C * MENU BOX # 10
      ELSE IF (MENUV .EQ. 10) THEN
        IF (MMODE .EQ. 1) THEN
          IF (MENUH .EQ. 1) THEN
            CALL PLA226 (0, 0.0)
          ELSE IF (MENUH .EQ. 2) THEN
            IGBL(67) = 0
            IPR(201) = 0
          ELSE IF (MENUH .EQ. 3) THEN
            CALL PLA226 (2, 90.0)
          ELSE IF (MENUH .EQ. 4) THEN
            CALL PLA226 (1, -90.0)
          ELSE IF (MENUH .EQ. 5) THEN
            CALL PLA226 (3, 90.0)
          ENDIF
          MNH(6) = MENUH
          LRET = 4
        ELSE IF (MMODE .EQ. 2) THEN
          IF (MENUH .EQ. 1) THEN
            CALL PLA280 ('VIEW UNIT')
          ELSE IF (MENUH .EQ. 2) THEN
            CALL PLA280 ('VIEW MIN')
          ELSE IF (MENUH .EQ. 3) THEN
            CALL PLA280 ('VIEW XO')
          ELSE IF (MENUH .EQ. 4) THEN
            CALL PLA280 ('VIEW YO')
          ELSE IF (MENUH .EQ. 5) THEN
            CALL PLA280 ('VIEW ZO')
          ENDIF
          MNH(6) = MENUH
        ELSE IF (MMODE .EQ. 3) THEN
          CALL PLA015 (349, 1)
          IF (IPR(351) .EQ. 1) CALL PLA015 (351, 1)
          IF (IPR(335) .EQ. 1) CALL PLA015 (335, 1)
          IF (IGBL(75) .EQ. 0) THEN
            CALL PLA280 ('LABEL ON')
          ELSE
            LRET = -1
          ENDIF
        ELSE IF (MMODE .EQ. 4) THEN
          IPR(345) = 0
          IPR(139) = MENUH - 1
        ELSE IF (MMODE .EQ. 5) THEN
          CALL PLA280 ('VIEW INVERT')
        ELSE IF (MMODE .EQ. 6) THEN
          CALL PLA280 ('LIST CELL')
        ELSE IF (MMODE .EQ. 7) THEN
          CALL PLA280 ('HELP')
        ELSE IF (MMODE .EQ. 8) THEN
          CALL PLA226 (-4, 0.0)
        ELSE IF (MMODE .EQ. 9) THEN
          IPR(41) = MENUH - 1
          LRET = -1
        ELSE IF (MMODE .EQ. 10) THEN
          IF (IPR(30) .EQ. 0) IGBL(52) = MOD (IGBL(52) + 1, 2)
          LRET = -1
        ELSE IF (MMODE .EQ. 11) THEN
          IPR(41) = MENUH - 1
          LRET = -1
        ELSE IF (MMODE .EQ. 14) THEN
          PAR(165) = ASIN((0.45 + MENUH * 0.05) * PAR(17)) * GL(5)
          LRET = 3
        ELSE IF (MMODE .EQ. 16) THEN
          STRING(1:5) = 'DELF '
          NCNT = 5
          SBCD = STRING(1:NCNT)//CHAR(0)
          LRET = -1
        ELSE IF (MMODE .EQ. 17) THEN
          IF (MENUH .EQ. 1) THEN
            CALL PLA280 ('EXOR')
          ELSE IF (MENUH .EQ. 2) THEN
            CALL PLA280 ('EXORS')
          ELSE IF (MENUH .EQ. 3) THEN
            CALL PLA280 ('EXORD')
          ELSE IF (MENUH .EQ. 4) THEN
            CALL PLA280 ('EXORC')
          ENDIF
        ELSE IF (MMODE .EQ. 18) THEN
          IGBL(40) = MOD(IGBL(40) + 1, 2)
        ELSE IF (MMODE .EQ. 19) THEN
          IGBL(96) = MOD(IGBL(96) + 1, 2)
          LRET     = -1
        ELSE IF (MMODE .EQ. 22) THEN
          CALL PLA280 ('PLAN')
          IPR(416) = 4
          IPR(420) = MENUH
          MNH(16)  = MENUH
          IF (MENUH .EQ. 1) THEN
            PAR(272) = PAR(101)
            PAR(273) = PAR(102)
          ELSE IF (MENUH .EQ. 2) THEN
            PAR(272) = PAR(101)
            PAR(273) = PAR(103)
          ELSE
            PAR(272) = PAR(102)
            PAR(273) = PAR(103)
          ENDIF
          IF (PAR(272) .LT. PAR(273)) THEN
            PAR(276) = 90.0
            CALL GEN018 (PAR(272), PAR(273))
          ELSE
            PAR(276) = 0
          ENDIF
          IF (PAR(273) * PAR(50) .LT. PAR(272)) THEN
            PAR(273) = PAR(272) / PAR(50)
          ENDIF
          PAR(273) = PAR(273) + 3.0
          PAR(272) = PAR(273) * PAR(50)
        ELSE IF (MMODE .EQ. 23) THEN
          CALL PLA280 ('F3D')
        ELSE IF (MMODE .EQ. 24) THEN
          IPR(140) = MENUH - 1
        ELSE IF (MMODE .EQ. 25) THEN
          IF (IPR(543) .EQ. 4) THEN
            IPR(543) = 0
          ELSE
            IPR(543) = 4
            CALL PLA280 ('TWIN')
            IPR(576) = 0
          ENDIF
        ELSE IF (MMODE .EQ. 26) THEN
          IGBL(106) = MOD(IGBL(106) + 1, 2)
        ELSE IF (MMODE .EQ. 30) THEN
          IF (MENUH .EQ. 1) THEN
            CALL PLA226 (0, 0.0)
          ELSE IF (MENUH .EQ. 2) THEN
            CALL PLA226 (2, 90.0 / GL(5))
          ELSE IF (MENUH .EQ. 3) THEN
            CALL PLA226 (1, -90.0 / GL(5))
          ELSE IF (MENUH .EQ. 4) THEN
            CALL PLA226 (3, 90.0 / GL(5))
          ENDIF
          MNH(6) = MENUH
          LRET = 3
        ELSE
          LRET = -1
        ENDIF
C * MENU BOX # 11
      ELSE IF (MENUV .EQ. 11) THEN
        IF (MMODE .EQ. 1) THEN
          IPR(346) = MOD(IPR(346) + 1, 2)
          IF (IPR(116) .EQ. 0) THEN
            LRET = 3
          ELSE
            IPR(116) = 0
            IPR(479) = 2
            PAR(389) = 0.0
            IPR(201) = 0
            LRET     = 2
          ENDIF
        ELSE IF (MMODE .EQ. 2) THEN
          CALL PLA015 (341, 1)
          LRET = -1
        ELSE IF (MMODE .EQ. 3) THEN
          IF (MENUH - 1 .NE. IGBL(88)) THEN
            IF (IGBL(59) .EQ. 1) THEN
              IGBL(88) = MENUH - 1
            ELSE
              IGBL(59) = MOD(IGBL(59) + 1, 2)
            ENDIF
          ELSE
            IGBL(59) = MOD(IGBL(59) + 1, 2)
            IGBL(88) = MENUH - 1
          ENDIF
        ELSE IF (MMODE .EQ. 4) THEN
          IF (MENUH .GT. 1) THEN
            PAR(44) = 0.5 * 2.0 ** (MENUH - 4)
          ELSE
            PAR(44) = 0.0
          ENDIF
        ELSE IF (MMODE .EQ. 5) THEN
          IFL(1) = 'VIEW '
          IFL(2) = 'LINE '
          CALL PLA015 (329, 1)
          LRET = -1
        ELSE IF (MMODE .EQ. 6) THEN
          CALL PLA299
          CALL PLA280 ('PLOT')
        ELSE IF (MMODE .EQ. 7) THEN
          IGBL(35) = MOD(IGBL(35) + 1, 2)
          LRET = -1
        ELSE IF (MMODE .EQ. 8) THEN
          CALL PLA015 (536, MENUH)
          LRET = -1
        ELSE IF (MMODE .EQ. 9) THEN
          CALL PLA015 (341, 5)
          LRET = -1
        ELSE IF (MMODE .EQ. 10) THEN
          IPR(110) = MOD(IPR(110) + 1, 2)
          LRET = -1
        ELSE IF (MMODE .EQ. 11) THEN
          IPR(154) = MOD(IPR(154) + 1, 2)
          LRET = -1
        ELSE IF (MMODE .EQ. 14) THEN
          PAR(284) = (MENUH - 1) * 0.5
          LRET = 3
        ELSE IF (MMODE .EQ. 15) THEN
          CALL PLA280 ('RR 1')
        ELSE IF (MMODE .EQ. 16) THEN
          IGBL(57) = MOD(IGBL(57) + 1, 2)
        ELSE IF (MMODE .EQ. 17) THEN
          WRITE(IGGT(1:14), '(''SHELXL ISO'', I3, 1X)') MENUH - 1
        ELSE IF (MMODE .EQ. 18) THEN
          IGBL(41) = MOD(IGBL(41) + 1, 2)
        ELSE IF (MMODE .EQ. 19) THEN
          IGBL(125) = MOD(IGBL(125) + 1, 2)
          LRET = -1
        ELSE IF (MMODE .EQ. 22) THEN
          PAR(279) = - 1.5 + MENUH
          LRET = 2
        ELSE IF (MMODE .EQ. 24) THEN
          IPR(535) = MOD(IPR(535) + 1, 2)
        ELSE IF (MMODE .EQ. 25) THEN
          MEDIUM      = 2
          IGGT(16:22) = 'ON     '
          CALL GGIP (-999.0, 0.0, 0.0, 6)
          CALL PLA280 ('TWIN')
        ELSE IF (MMODE .EQ. 30) THEN
          IPR(353) = MOD(IPR(353) + 1, 2)
          LRET = 3
        ELSE
          LRET = -1
        ENDIF
C * MENU BOX # 12
      ELSE IF (MENUV .EQ. 12) THEN
        IF (MMODE .EQ. 1) THEN
          IF (MENUH .EQ. IPR(232) + 1)
     1           IGBL(75) = MOD(IGBL(75) + 1, 2)
          IF (MENUH .EQ. 2) THEN
            IPR(232) = 1
            IPR(201) = 0
          ELSE
            IPR(232) = 0
          ENDIF
          IF (IGBL(75) .EQ. 1) WRITE (LU6, 99999)
          IF (IGBL(35) .EQ. 1) THEN
            LRET = 2
          ELSE
            LRET = -1
          ENDIF
        ELSE IF (MMODE .EQ. 2) THEN
          PAR(349) = 0.20 + 0.05 * MENUH
        ELSE IF (MMODE .EQ. 3) THEN
          CALL PLA015 (343, 1)
          LRET = -1
        ELSE IF (MMODE .EQ. 4) THEN
          PAR(36) = (MENUH - 1) * 0.05
        ELSE IF (MMODE .EQ. 5) THEN
          IFL(1) = 'VIEW '
          IFL(2) = 'PERP '
          CALL PLA015 (329, 2)
          LRET = -1
        ELSE IF (MMODE .EQ. 6) THEN
          IPR(90)  = 4
          IPR(220) = 2
          CALL PLUT12
        ELSE IF (MMODE .EQ. 7) THEN
          PAR(58) = (MENUH - 1) * 0.05
        ELSE IF (MMODE .EQ. 8) THEN
          IPR(108) = 1
          IPR(148) = MENUH - 1
          LRET = 2
        ELSE IF (MMODE .EQ. 9) THEN
          CALL PLA280 ('RADII BONDS')
        ELSE IF (MMODE .EQ. 10) THEN
          IF (MENUH .EQ. 1) THEN
            CALL PLA280 ('LIST ARU')
            LRET = 2
          ELSE
            WRITE (BCD, 99997) (PAR(J), J = 113, 115),
     1      (ACOS(PAR(J)) * GL(5), J = 116, 118), PAR(17), CHAR(0)
            CALL GGIP (-999.0, 5.0 + FLOAT(IGBL(68)), 80.0, 111)
            LRET = -1
          ENDIF
        ELSE IF (MMODE .EQ. 12) THEN
          IPR(594) = MOD (IPR(594) + 1, 2)
          LRET = -1
        ELSE IF (MMODE .EQ. 15) THEN
          CALL PLA280 ('RR 2')
        ELSE IF (MMODE .EQ. 11 .OR. MMODE .EQ. 16) THEN
          IPR(445) = MOD (IPR(445) + 1, 2)
          LRET = -1
        ELSE IF (MMODE .EQ. 17) THEN
          WRITE (IGGT(1:16), '(''SHELXL ANISO'', I3, 1X)') MENUH - 1
        ELSE IF (MMODE .EQ. 18) THEN
          IGBL(34) = MOD(IGBL(34) + 1, 2)
        ELSE IF (MMODE .EQ. 22) THEN
          PAR(273) = MENUH * 5.0
          PAR(272) = 4.0 * PAR(273) / 3.0
          CALL PLA280 ('SCAL')
        ELSE IF (MMODE .EQ. 24) THEN
          IPR(531) = MENUH - 1
        ELSE IF (MMODE .EQ. 25) THEN
          PAR(449) = MENUH * 0.1
          CALL PLA280 ('RESOLUTION')
        ELSE IF (MMODE .EQ. 30) THEN
          IPR(358) = MOD (IPR(358) + 1, 2)
          LRET = 3
        ELSE
          LRET = -1
        ENDIF
C * MENU BOX # 13
      ELSE IF (MENUV .EQ. 13) THEN
        IF (MMODE .EQ. 1) THEN
          CALL PLA015 (349, 1)
          IPR(327) = 0
          IPR(328) = 0
          IPR(351) = 0
          LRET     = -1
        ELSE IF (MMODE .EQ. 2) THEN
          IF (IPR(46) .EQ. 0) THEN
            CALL PLA280 ('UNIT ON')
          ELSE
            CALL PLA280 ('UNIT OFF')
          ENDIF
        ELSE IF (MMODE .EQ. 3) THEN
          IPR(130) = 0
          PAR(13)  = 0.4 + MENUH * 0.5
          CALL PLA280 ('PLOT')
        ELSE IF (MMODE .EQ. 4) THEN
          IPR(111) = 2 ** (4 - MENUH)
          PAR(5)   = 1.0 / (3.33333 ** MENUH)
        ELSE IF (MMODE .EQ. 5) THEN
          IFL(1) = 'VIEW '
          IFL(2) = 'BISECT '
          CALL PLA015 (329, 3)
          LRET = -1
        ELSE IF (MMODE .EQ. 6) THEN
          IPR(90) = 8
          CALL PLUT12
        ELSE IF (MMODE .EQ. 7) THEN
          IGBL(123) = MENUH - 1
        ELSE IF (MMODE .EQ. 8) THEN
          IPR(177) = MENUH - 1
          IPR(211) = 0
          LRET = 3
        ELSE IF (MMODE .EQ. 9) THEN
          IF (MENUH .EQ. 1) THEN
            WRITE (BCD, 99998) PAR(17), (PAR(J), J = 101, 106),
     1                          PAR(98), CHAR(0)
            CALL GGIP (-999.0, 5.0 + FLOAT(IGBL(68)), 80.0, 111)
            LRET = -1
          ELSE
            CALL PLA299
            CALL GEN038 (ICL, 1, 80)
            LRET = 4
          ENDIF
        ELSE IF (MMODE .EQ. 10) THEN
          IF (MENUH .EQ. 1) THEN
            IF (PAR(98) .EQ. 1.0) CALL PLA080
            WRITE (BCD, 99998) PAR(17), (PAR(J), J = 101, 106),
     1                         PAR(98), CHAR(0)
            CALL GGIP (-999.0, 5.0 + FLOAT(IGBL(68)), 80.0, 111)
            LRET = -1
          ELSE
            CALL PLA280 ('LIST SYMM')
            LRET = 2
          ENDIF
        ELSE IF (MMODE .EQ. 12) THEN
          IGBL(109) = MOD (IGBL(109) + 1, 2)
          LRET = -1
        ELSE IF (MMODE .EQ. 14) THEN
          IPR(369) = MOD (IPR(369) + 1, 2)
          IPR(389) = 0
          LRET     = 4
        ELSE IF (MMODE .EQ. 15) THEN
          CALL PLA280 ('RR 3')
        ELSE IF (MMODE .EQ. 11 .OR. MMODE .EQ. 16) THEN
          IPR(363) = MOD (IPR(363) + 1, 2)
          LRET = -1
        ELSE IF (MMODE .EQ. 17) THEN
          CALL PLA280 ('TWINMAT')
        ELSE IF (MMODE .EQ. 22) THEN
          IF (MENUH .GT. 3) THEN
            DELTA = (MENUH - 3) * 0.5
          ELSE
            DELTA = (MENUH - 4) * 0.5
          ENDIF
          PAR(274) = PAR(274) + DELTA * COS(PAR(276) / GL(5))
          PAR(275) = PAR(275) + DELTA * SIN(PAR(276) / GL(5))
          CALL PLA280 ('SCAL')
        ELSE IF (MMODE .EQ. 24) THEN
          IPR(527) = MOD (IPR(527) + 1, 2)
        ELSE IF (MMODE .EQ. 30) THEN
          IPR(357) = MOD (IPR(357) + 1, 2)
          LRET = 3
        ELSE
          LRET = -1
        ENDIF
C * MENU BOX # 14
      ELSE IF (MENUV .EQ. 14) THEN
        IF (MMODE .EQ. 1) THEN
          PAR(349) = 0.20 + MENUH * 0.05
          IPR(201) = 0
          LRET = 3
        ELSE IF (MMODE .EQ. 2 .OR. MMODE .EQ. 3 .OR. MMODE .EQ. 5
     1           .OR. MMODE .EQ. 6) THEN
          IF (MENUH .EQ. 1) THEN
            CALL PLA280 ('ARU RESTORE')
          ELSE
            WRITE (IGGT(1:14), '(''ARU NONE '', I5)') MENUH - 1
          ENDIF
          IPR(140) = MENUH - 1
        ELSE IF (MMODE .EQ. 4) THEN
          IF (IPR(63) .EQ. 0) THEN
            CALL PLA280 ('LABEL ARU')
          ELSE
            CALL PLA280 ('UNLABEL ARU')
          ENDIF
        ELSE IF (MMODE .EQ. 7) THEN
          IF (MENUH .EQ. 1) THEN
            PAR(18) = SIGN(1.0, PAR(18))
          ELSE
            PAR(18) = SIGN(1.333, PAR(18))
          ENDIF
        ELSE IF (MMODE .EQ. 8) THEN
          IPR(211) = 1
          LRET     = 3
        ELSE IF (MMODE .EQ. 9) THEN
          IF (MENUH .EQ. 1) THEN
            CALL PLA280 ('LIST ATOMS')
          ELSE
            CALL PLA280 ('LIST UIJ')
          ENDIF
        ELSE IF (MMODE .EQ. 10) THEN
          IF (IPR(30) .EQ. 0) CALL PLA069
          IPR(220) = 2
          IPR(221) = 0
          IPR(18)  = 1
          CALL PLA073 (1)
        ELSE IF (MMODE .EQ. 11) THEN
          IF (IPR(30) .EQ. 0) IGBL(33) = MOD(IGBL(33) + 1, 2)
          LRET = -1
        ELSE IF (MMODE .EQ. 12) THEN
          IGBL(57) = MOD(IGBL(57) + 1, 2)
          LRET = -1
        ELSE IF (MMODE .EQ. 15) THEN
          CALL PLA280 ('RR 4')
        ELSE IF (MMODE .EQ. 16) THEN
          IPR(331) = MOD (IPR(331) + 1, 2)
        ELSE IF (MMODE .EQ. 17) THEN
          IF (MENUH .EQ. 1) THEN
            CALL PLA280 ('HDIF')
          ELSE
            CALL PLA280 ('HFIX')
            IF (IPR(351) .EQ. 1) CALL PLA015 (351, 1)
          ENDIF
        ELSE IF (MMODE .EQ. 18) THEN
           CALL PLA280 ('RPLUTO')
        ELSE IF (MMODE .EQ. 22) THEN
          IF (MENUH .GT. 3) THEN
            DELTA = (MENUH - 3) * 0.5
          ELSE
            DELTA = (MENUH - 4) * 0.5
          ENDIF
          PAR(275) = PAR(275) + DELTA * COS(PAR(276) / GL(5))
          PAR(274) = PAR(274) - DELTA * SIN(PAR(276) / GL(5))
          CALL PLA280 ('SCAL')
        ELSE IF (MMODE .EQ. 24) THEN
          IPR(528) = MOD (IPR(528) + 1, 2)
        ELSE IF (MMODE .EQ. 25) THEN
        ELSE
          LRET = -1
        ENDIF
C * MENU BOX # 15
      ELSE IF (MENUV .EQ. 15) THEN
        IF (MMODE .EQ. 1) THEN
          CALL PLA015 (327, 1)
          IPR(440) = 0
          IPR(349) = 0
          IPR(328) = 0
          LRET = -1
        ELSE IF (MMODE .EQ. 2) THEN
          IF (MENUH .EQ. 1) THEN
            CALL PLA280 ('JOIN RADII INTER HBONDS')
          ELSE
            CALL PLA280 ('JOIN RADII INTER XBONDS')
          ENDIF
        ELSE IF (MMODE .EQ. 3) THEN
          IF (IABS(IGBL(8)) .EQ. 2) THEN
            IF (MENUH .EQ. 1) THEN
              IF (IPR(351) .EQ. 1) CALL PLA015 (351, 1)
              IF (IPR(335) .EQ. 1) CALL PLA015 (335, 1)
              CALL PLA015 (332, 1)
              IF (IGBL(75) .EQ. 0) THEN
                CALL PLA280 ('LABEL ON')
              ELSE
                LRET = -1
              ENDIF
            ELSE
              CALL PLA015 (352, 1)
              IF (IGBL(3) .EQ. 26) LRET = -1
            ENDIF
          ELSE
            IF (MENUH .EQ. 1) THEN
              CALL PLA015 (427, 30)
            ELSE
              CALL PLA015 (427, 44)
            ENDIF
            LRET = -1
          ENDIF
        ELSE IF (MMODE .EQ. 4) THEN
          IF (IPR(339) .EQ. 0) THEN
            CALL PLA280 ('LABEL UNIT')
            IPR(46) = 1
          ELSE
            CALL PLA280 ('UNLABEL UNIT')
          ENDIF
        ELSE IF (MMODE .EQ. 5) THEN
          CALL PLA280 ('PLOT CAL MOGLI')
        ELSE IF (MMODE .EQ. 7) THEN
          IGBL(101) = MENUH - 1
          CALL PLA280 ('PLOT POV')
          IPR (340) = 1
          IGBL(98)  = 0
        ELSE IF (MMODE .EQ. 8) THEN
          IPR(177) = MENUH - 1
          IPR(211) = 2
          LRET = 3
        ELSE IF (MMODE .EQ. 9) THEN
          IF (MENUH .EQ. 1) THEN
            CALL PLA280 ('LIST FLAGS')
          ELSE
            CALL PLA280 ('LIST RADII')
          ENDIF
        ELSE IF (MMODE .EQ. 10) THEN
          IF (IPR(30) .EQ. 0) CALL PLA069
          IPR(220) = 2
          IPR(221) = 0
          IPR(18)  = 2
          CALL PLA073 (1)
        ELSE IF (MMODE .EQ. 11) THEN
          IGBL(121) = MOD (IGBL(121) + 1, 2)
          LRET = -1
        ELSE IF (MMODE .EQ. 12) THEN
          IGBL(74) = MOD (IGBL(74) + 1, 2)
          LRET = -1
        ELSE IF (MMODE .EQ. 14) THEN
          IPR(468) = MOD (IPR(468) + 1, 2)
          LRET     = 3
        ELSE IF (MMODE .EQ. 15) THEN
          CALL PLA280 ('RR 5')
        ELSE IF (MMODE .EQ. 16) THEN
          IPR(388) = MOD (IPR(388) + 1, 2)
        ELSE IF (MMODE .EQ. 17) THEN
          WRITE (IGGT(1:16), '(''SHELXL HATOM'', I3, 1X)') MENUH - 1
        ELSE IF (MMODE .EQ. 18) THEN
          CALL PLA280 ('CONTOUR PT')
        ELSE IF (MMODE .EQ. 19) THEN
          IGBL(74) = MOD (IGBL(74) + 1, 2)
          LRET = -1
        ELSE IF (MMODE .EQ. 22) THEN
          IF (MENUH .GT. 3) THEN
            ZROT = (MENUH - 3) * 30.0
          ELSE
            ZROT = (MENUH - 4) * 30.0
          ENDIF
          WRITE (IGGT, '(''ZROT '', F10.2)') ZROT
        ELSE IF (MMODE .EQ. 24) THEN
          IPR(529) = MOD (IPR(529) + 1, 2)
          LRET = 4
        ELSE IF (MMODE .EQ. 25) THEN
          IPR(394) = MENUH
          CALL PLA280 ('ZONE')
        ELSE IF (MMODE .EQ. 29) THEN
          IPR(593) = MOD (IPR(593) + 1, 2)
          CALL PLA280 ('SLOPE')
        ELSE
          LRET = -1
        ENDIF
C * MENU BOX # 16
      ELSE IF (MENUV .EQ. 16) THEN
        IF (MMODE .EQ. 1) THEN
          CALL PLA015 (328, 1)
          IGBL(75) = 1
          IPR(440) = 0
          IPR(349) = 0
          IPR(327) = 0
        ELSE IF (MMODE .EQ. 2) THEN
          MNH(7) = MENUH
          IF (MENUH .EQ. 1) THEN
            CALL PLA280 ('ARU NONE 1555')
          ELSE IF (MENUH .EQ. 2) THEN
            CALL PLA280 ('ARU UNIQUE')
          ELSE
            WRITE (IGGT(1:46), '(''PACK RANGE'', 6F6.2)')
     1        0.45 - DX, 0.55 + DX, 0.45 - DX, 0.55 + DX,
     2        0.45 - DX, 0.55 + DX
          ENDIF
        ELSE IF (MMODE .EQ. 3) THEN
          IF (MENUH .EQ. 1) THEN
            CALL PLA280 ('VIEW UNIT')
          ELSE IF (MENUH .EQ. 2) THEN
            CALL PLA280 ('VIEW MIN')
          ELSE IF (MENUH .EQ. 3) THEN
            CALL PLA280 ('VIEW XO')
          ELSE IF (MENUH .EQ. 4) THEN
            CALL PLA280 ('VIEW YO')
          ELSE IF (MENUH .EQ. 5) THEN
            CALL PLA280 ('VIEW ZO')
          ENDIF
          MNH(6) = MENUH
        ELSE IF (MMODE .EQ. 4) THEN
          IF (IPR(452) .EQ. 0) THEN
            CALL PLA280 ('LABEL ATOM')
          ELSE
            CALL PLA280 ('UNLABEL ATOM')
          ENDIF
        ELSE IF (MMODE .EQ. 7) THEN
          IPR(71) = MOD (IPR(71) + 1, 2)
        ELSE IF (MMODE .EQ. 8) THEN
          IF (IGBL(71) .EQ. 0) THEN
            IPR(350) = MOD (IPR(350) + 1, 2)
            IPR(201) = 0
            LRET     = 4
          ELSE
            LRET = -1
          ENDIF
        ELSE IF (MMODE .EQ. 9) THEN
          LRET = 1
          CALL PLA280 ('LIST ARU')
        ELSE IF (MMODE .EQ. 10) THEN
          IF (MENUH .EQ. 1) THEN
            CALL PLA280 ('LIST FLAGS')
          ELSE
            CALL PLA280 ('LIST RADII')
          ENDIF
          LRET = 2
        ELSE IF (MMODE .EQ. 12) THEN
          IGBL(62) = MENUH
          WRITE (IGGT, '(''SET WINDOW'', F8.2)') IGBL(62) / 4.0
          LRET = 2
        ELSE IF (MMODE .EQ. 14) THEN
          IPR(132) = MENUH - 1
          LRET = 3
        ELSE IF (MMODE .EQ. 15) THEN
          CALL PLA280 ('RR 6')
        ELSE IF (MMODE .EQ. 16) THEN
          IGBL(75) = MOD (IGBL(75) + 1, 2)
        ELSE IF (MMODE .EQ. 17) THEN
          WRITE (IGGT(1:17), '(''SHELXL WEIGHT'', I3, 1X)')
     1            MENUH - 1
        ELSE IF (MMODE .EQ. 18) THEN
          CALL PLA280 ('CONTOUR DF')
        ELSE IF (MMODE .EQ. 22) THEN
          CALL PLA015 (458, 1)
          LRET = 2
        ELSE IF (MMODE .EQ. 24) THEN
          IPR(532) = MOD (IPR(532) + 1, 2)
        ELSE IF (MMODE .EQ. 25) THEN
          IF (MENUH .EQ. 1) THEN
            IPR(389) = 1
          ELSE
            IPR(389) = -1
          ENDIF
          CALL PLA280 ('NEXT')
        ELSE IF (MMODE .EQ. 30) THEN
          IF (MENUH .GT. 1) THEN
            IPR(354) = MENUH - 1
          ELSE
            IPR(354) = -1
          ENDIF
          LRET = 3
        ELSE
          LRET = -1
        ENDIF
C * MENU BOX # 17
      ELSE IF (MENUV .EQ. 17) THEN
        IF (MMODE .EQ. 1 .OR. MMODE .EQ. 8 .OR. MMODE .EQ. 9) THEN
          IPR(140) = MENUH - 1
          IPR(201) = 0
          LRET     = 4
        ELSE IF (MMODE .GE. 2 .AND. MMODE .LE. 6) THEN
          IF (IGBL(75) .EQ. 1) THEN
            IF (MENUH .NE. IPR(232) + 1) IGBL(75) = 0
          ENDIF
          IF (MENUH .EQ. 2) THEN
            IPR(232) = 1
          ELSE
            IPR(232) = 0
          ENDIF
          IF (IGBL(75) .EQ. 0) THEN
            CALL PLA280 ('LABEL ON')
          ELSE
            CALL PLA280 ('LABEL OFF')
          ENDIF
        ELSE IF (MMODE .EQ. 7) THEN
          CALL PLA280 ('PORTRAIT')
        ELSE IF (MMODE .EQ. 11) THEN
          PAR(7) = 2.0 + MENUH
          LRET = -1
        ELSE IF (MMODE .EQ. 12) THEN
          CALL PLA280 ('PORTRAIT')
          LRET = 2
        ELSE IF (MMODE .EQ. 13) THEN
          CALL PLA280 ('CANDP')
        ELSE IF (MMODE .EQ. 15) THEN
          CALL PLA280 ('RR 7')
        ELSE IF (MMODE .EQ. 16) THEN
          PAR(325) = 1.0 + (MENUH - 1) * 0.25
        ELSE IF (MMODE .EQ. 17) THEN
          IF (MENUH .EQ. 1) THEN
            CALL PLA280 ('PLUTON')
          ELSE
            CALL PLA280 ('RENAME')
          ENDIF
        ELSE IF (MMODE .EQ. 18) THEN
          CALL PLA280 ('CONTOUR FO')
        ELSE IF (MMODE .EQ. 22) THEN
          IF (MENUH .EQ. IPR(232) + 1)
     1      IGBL(75) = MOD(IGBL(75) + 1, 2)
          IF (MENUH .EQ. 2) THEN
            IPR(232) = 1
            IPR(201) = 0
          ELSE
            IPR(232) = 0
          ENDIF
          LRET = 2
        ELSE IF (MMODE .EQ. 24) THEN
          IF (MENUH .EQ. IPR(232) + 1)
     1           IGBL(75) = MOD(IGBL(75) + 1, 2)
          IF (MENUH .EQ. 2) THEN
            IPR(232) = 1
          ELSE
            IPR(232) = 0
          ENDIF
        ELSE IF (MMODE .EQ. 25) THEN
          IPR(575) = MOD (IPR(575) + 1, 2)
          LRET = -1
        ELSE IF (MMODE .EQ. 30) THEN
          IPR(356) = MOD (IPR(356) + 1, 2)
        ELSE
          LRET = -1
        ENDIF
C * MENU BOX # 18
      ELSE IF (MENUV .EQ. 18) THEN
        IF (MMODE .EQ. 1) THEN
          IPR(479) = 2
          PAR(389) = ANGC
          IPR(201) = 0
          LRET     = 6
        ELSE IF (MMODE .EQ. 2 .OR. MMODE .EQ. 3) THEN
          WRITE (IGGT(1:20), '(''CROTY COLOR'', F8.2)') ANGC
        ELSE IF (MMODE .EQ. 4) THEN
          IF (MENUH .EQ. 1) THEN
            IFL(1)   = 'DEFINE'
            IFL(2)   = 'CG'
            LMOD     = 2
            IPR(507) = 1
            CALL PLA015 (508, 2)
            LRET     = -1
          ELSE IF (MENUH .EQ. 2) THEN
            IF (IPR(508) .EQ. 2) THEN
              IPR(507) = 2
              IPR(508) = 0
              WRITE (IGGT, 99995) (IFL(I), I = 1, LMOD)
              IGBL(23) = IABS(IGBL(23))
            ENDIF
          ENDIF
        ELSE IF (MMODE .EQ. 6) THEN
          CALL PLA280 ('ENTRY')
        ELSE IF (MMODE .EQ. 7) THEN
          WRITE (IGGT, '(''SET REVERSE'')')
        ELSE IF (MMODE .EQ. 8) THEN
          PAR(85) = MENUH
          LRET    = 4
        ELSE IF (MMODE .EQ. 9) THEN
          WRITE (IGGT, '(''SET REVERSE'')')
        ELSE IF (MMODE .EQ. 10) THEN
          IF (IABS(IGBL(8)) .EQ. 2) THEN
            GL(26) = MENUH  * 0.20
          ENDIF
          LRET = -1
        ELSE IF (MMODE .EQ. 12) THEN
          IGBL(64) = MENUH - 1
          IGBL(63) = IGBL(64)
          LRET = -1
        ELSE IF (MMODE .EQ. 13) THEN
          IGBL(23) = 1
          CALL PLA280 ('PLOT ADP COLOR')
        ELSE IF (MMODE .EQ. 14) THEN
          IF (MENUH .EQ. 1) THEN
            IPR(389) = 1
          ELSE
            IPR(389) = -1
          ENDIF
          LRET = 4
        ELSE IF (MMODE .EQ. 15) THEN
          CALL PLA280 ('RR 8')
        ELSE IF (MMODE .EQ. 16) THEN
          WRITE (IGGT(1:20), '(''CROTY '', F8.2)') ANGC
        ELSE IF (MMODE .EQ. 17) THEN
          IF (MENUH .EQ. 1) THEN
            CALL PLA280 ('PLATON')
          ELSE
            CALL PLA280 ('PLATON ADP')
          ENDIF
        ELSE IF (MMODE .EQ. 18) THEN
          CALL PLA280 ('CONTOUR SQ')
        ELSE IF (MMODE .EQ. 19) THEN
          WRITE (IGGT, '(''SET REVERSE'')')
        ELSE IF (MMODE .EQ. 22) THEN
          PAR(278)  = 0.1 * MENUH
          LRET = 2
        ELSE IF (MMODE .EQ. 23) THEN
          PAR(278)  = 0.1 * MENUH
          LRET = 2
        ELSE IF (MMODE .EQ. 24) THEN
          PAR(349) = 0.20 + MENUH * 0.05
        ELSE IF (MMODE .EQ. 25) THEN
          IPR(571)  = MOD (IPR(571) + 1, 2)
          LRET = -1
        ELSE
          LRET = -1
        ENDIF
C * MENU BOX # 19
      ELSE IF (MENUV .EQ. 19) THEN
        IF (MMODE .EQ. 1 .OR. MMODE .EQ. 9) THEN
          IPR(479) = 3
          IF (MENUH .GT. 5) THEN
            PAR(389)  = 2 ** (MENUH - 6)
          ELSE
            PAR(389)  =  - 2 ** (5 - MENUH)
          ENDIF
          IPR(201) = 0
          LRET     = 2
        ELSE IF (MMODE .EQ. 7) THEN
          IGBL(69) = MOD(IGBL(69) + 1, 2)
          YGGIP    = - 100 * (IGBL(69) + 1)
          CALL GGIP (0.0, YGGIP, 0.0, 0)
        ELSE IF (MMODE .EQ. 8) THEN
          PAR(89) = MENUH
          LRET    = 4
        ELSE IF (MMODE .EQ. 10) THEN
          IF (IABS(IGBL(8)) .EQ. 2) THEN
            GL(27) = (MENUH - 1) * 0.25
          ENDIF
          LRET   = -1
        ELSE IF (MMODE .EQ. 12) THEN
          IGBL(70) = MOD(IGBL(70) + 1, 2)
          LRET = -1
        ELSE IF (MMODE .EQ. 13) THEN
          IPR(55) = -1
          CALL PLA280 ('YES')
        ELSE IF (MMODE .EQ. 15) THEN
          CALL PLA280 ('RR 9')
        ELSE IF (MMODE .EQ. 16) THEN
          IF (MENUH .GT. 5) THEN
            IANG  = 2 ** (MENUH - 6)
          ELSE
            IANG  =  - 2 ** (5 - MENUH)
          ENDIF
          WRITE (IGGT(1:9), 99996) 'Z', IANG
        ELSE IF (MMODE .EQ. 17) THEN
          IF (MENUH .EQ. 1) THEN
            CALL PLA280 ('INVERT')
          ELSE
            CALL PLA280 ('HFREE')
          ENDIF
        ELSE IF (MMODE .EQ. 19) THEN
          IF (MENUH .EQ. 1) THEN
            CALL PLA280 ('ANIS')
          ELSE IF (MENUH .EQ. 2) THEN
          ENDIF
        ELSE IF (MMODE .EQ. 22) THEN
          IPR(419)  = NINT(2.5 * 2 ** MENUH)
          LRET = 2
        ELSE IF (MMODE .EQ. 24) THEN
          IPR(479) = 3
          IF (MENUH .GT. 5) THEN
            PAR(389) = 2 ** (MENUH - 6)
          ELSE
            PAR(389) =  - 2 ** (5 - MENUH)
          ENDIF
          LRET = 3
        ELSE IF (MMODE .EQ. 25) THEN
          IPR(572)  = MOD (IPR(572) + 1, 2)
          LRET      = -1
        ELSE IF (MMODE .EQ. 26) THEN
          IPR(566) = MOD (IPR(566) + 1, 2)
          LRET     = -1
        ELSE IF (MMODE .EQ. 30) THEN
          IF (MENUH .GT. 5) THEN
            IANG  = 2 ** (MENUH - 6)
          ELSE
            IANG  =  - 2 ** (5 - MENUH)
          ENDIF
          WRITE (IGGT(1:9), 99996) 'Z', IANG
        ELSE
          IF (MENUH .GT. 5) THEN
            IANG  = 2 ** (MENUH - 6)
          ELSE
            IANG  =  - 2 ** (5 - MENUH)
          ENDIF
          WRITE (IGGT(1:18), '(''VIEW CUR ZROT'', I5)') IANG
        ENDIF
C * MENU BOX # 20
      ELSE IF (MENUV .EQ. 20) THEN
        IF (MMODE .EQ. 1 .OR. MMODE .EQ. 9) THEN
          IPR(479) = 2
          IF (MENUH .GT. 5) THEN
            PAR(389)  = 2 ** (MENUH - 6)
          ELSE
            PAR(389)  =  - 2 ** (5 - MENUH)
          ENDIF
          IPR(201) = 0
          LRET     = 2
        ELSE IF (MMODE .EQ. 7) THEN
          GL(25) = (MENUH - 1) * 0.25
          CALL PLA280 ('RESET')
        ELSE IF (MMODE .EQ. 8) THEN
          PAR(86) = MENUH * 0.01
          PAR(88) = MENUH * 0.01
          PAR(90) = MENUH * 0.01
          LRET = 4
        ELSE IF (MMODE .EQ. 10) THEN
          IF (MENUH .EQ. 1) THEN
            IGBL(95) = MOD (IGBL(95) + 1, 2)
          ELSE IF (MENUH .EQ. 2) THEN
            IGBL(95) = 1
          ENDIF
          CALL PLA280 ('RESTART')
          LRET = 2
        ELSE IF (MMODE .EQ. 12) THEN
          MNH(12) = MENUH
          IF (MENUH .EQ. 1) THEN
            CALL PLA280 ('SET META PS')
          ELSE IF (MENUH .EQ. 2) THEN
            CALL PLA280 ('SET META HPGL')
          ELSE IF (MENUH .EQ. 3) THEN
            CALL PLA280 ('SET META TEK4014')
          ENDIF
          LRET = 2
        ELSE IF (MMODE .EQ. 11) THEN
          IF (IABS(IGBL(8)) .EQ. 2) THEN
            GL(25) = (MENUH - 1) * 0.25
            CALL PLA280 ('RESTART')
            LRET = 2
          ELSE
            LRET = -1
          ENDIF
        ELSE IF (MMODE .EQ. 13) THEN
          IPR(55) = 2
          CALL PLA280 ('YES')
        ELSE IF (MMODE .EQ. 16) THEN
          IF (MENUH .GT. 5) THEN
            IANG  = 2 ** (MENUH - 6)
          ELSE
            IANG  =  - 2 ** (5 - MENUH)
          ENDIF
          WRITE (IGGT(1:9), 99996) 'Y', IANG
        ELSE IF (MMODE .EQ. 17) THEN
          IF (MENUH .EQ. 1) THEN
            CALL PLA280 ('ASYM')
          ELSE
            CALL PLA280 ('ASYM VIEW')
          ENDIF
        ELSE IF (MMODE .EQ. 18) THEN
          CALL PLA280 ('BROWSE PS')
        ELSE IF (MMODE .EQ. 19) THEN
          LRET = -1
        ELSE IF (MMODE .EQ. 22) THEN
          STRING(1:3) = 'CL '
          NCNT = 3
          SBCD = STRING(1:NCNT)//CHAR(0)
          LRET = -1
        ELSE IF (MMODE .EQ. 24) THEN
          IPR(479) = 2
          IF (MENUH .GT. 5) THEN
            PAR(389) = 2 ** (MENUH - 6)
          ELSE
            PAR(389) =  - 2 ** (5 - MENUH)
          ENDIF
          LRET = 3
        ELSE IF (MMODE .EQ. 25) THEN
          IPR(573)  = MOD (IPR(573) + 1, 2)
          LRET = -1
        ELSE IF (MMODE .EQ. 26) THEN
          CALL PLA280 ('CALC ADDSYM EQUAL')
        ELSE IF (MMODE .EQ. 30) THEN
          IF (MENUH .GT. 5) THEN
            IANG  = 2 ** (MENUH - 6)
          ELSE
            IANG  =  - 2 ** (5 - MENUH)
          ENDIF
          WRITE (IGGT(1:9), 99996) 'Y', IANG
        ELSE
          IF (MENUH .GT. 5) THEN
            IANG  = 2 ** (MENUH - 6)
          ELSE
            IANG  =  - 2 ** (5 - MENUH)
          ENDIF
          WRITE (IGGT(1:18), '(''VIEW CUR YROT'', I5)') IANG
        ENDIF
C * MENU BOX # 21
      ELSE IF (MENUV .EQ. 21) THEN
        IF (MMODE .EQ. 1 .OR. MMODE .EQ. 9) THEN
          IPR(479) = 1
          IF (MENUH .GT. 5) THEN
            PAR(389)  = 2 ** (MENUH - 6)
          ELSE
            PAR(389)  =  - 2 ** (5 - MENUH)
          ENDIF
          IPR(201) = 0
          LRET     = 2
        ELSE IF (MMODE .EQ. 7) THEN
          IPR(166) = MOD(IPR(166) + 1, 2)
          IPR(130) = 0
          CALL PLA280 ('PLOT')
        ELSE IF (MMODE .EQ. 8) THEN
          PAR(86) = MENUH * 0.01
          LRET = 4
        ELSE IF (MMODE .EQ. 10) THEN
          CALL PLA280 ('HELP')
          LRET = 2
        ELSE IF (MMODE .EQ. 12) THEN
          IGBL(35) = MOD(IGBL(35) + 1, 2)
          LRET = -1
        ELSE IF (MMODE .EQ. 13) THEN
          IPR(55) = 1
          CALL PLA280 ('YES')
        ELSE IF (MMODE .EQ. 16) THEN
          IF (MENUH .GT. 5) THEN
            IANG =   2 ** (MENUH - 6)
          ELSE
            IANG = - 2 ** (5 - MENUH)
          ENDIF
          WRITE (IGGT(1:9), 99996) 'X', IANG
        ELSE IF (MMODE .EQ. 17) THEN
          IF (MENUH .EQ. 1) THEN
            CALL PLA280 ('SQUEEZE')
          ELSE
            CALL PLA280 ('FCF')
          ENDIF
        ELSE IF (MMODE .EQ. 18) THEN
          CALL PLA280 ('LASER')
        ELSE IF (MMODE .EQ. 19) THEN
          IGBL(124) = MENUH - 1
        ELSE IF (MMODE .EQ. 22) THEN
          IF (IPR(182) .EQ. 0) THEN
            CALL PLA280 ('OMIT')
            IPR(515) = MENUH - 1
          ELSE
            IPR(505) = MENUH
            IF (MENUH .EQ. 1) THEN
              CALL PLA280 ('XROT 10')
            ELSE IF (MENUH .EQ. 2) THEN
              CALL PLA280 ('YROT 10')
            ELSE
              CALL PLA280 ('ZROT 10')
            ENDIF
          ENDIF
        ELSE IF (MMODE .EQ. 21) THEN
          IPR(569) = MOD (IPR(569) + 1, 2)
          IPR(570) = 0
          LRET     = 3
        ELSE IF (MMODE .EQ. 24) THEN
          IPR(479) = 1
          IF (MENUH .GT. 5) THEN
            PAR(389) = 2 ** (MENUH - 6)
          ELSE
            PAR(389) =  - 2 ** (5 - MENUH)
          ENDIF
          LRET = 3
        ELSE IF (MMODE .EQ. 25) THEN
          IPR(574)  = MOD (IPR(574) + 1, 2)
          LRET = -1
        ELSE IF (MMODE .EQ. 26) THEN
          IF (MENUH .EQ. 1) THEN
            NQ1 = ' '
          ELSE
            NQ1 = LMT(MENUH - 1, 1)
          ENDIF
          CALL PLA280 ('CALC ADDSYM '//NQ1)
        ELSE IF (MMODE .EQ. 30) THEN
          IF (MENUH .GT. 5) THEN
            IANG =   2 ** (MENUH - 6)
          ELSE
            IANG = - 2 ** (5 - MENUH)
          ENDIF
          WRITE (IGGT(1:9), 99996) 'X', IANG
        ELSE
          IF (MENUH .GT. 5) THEN
            IANG  =   2 ** (MENUH - 6)
          ELSE
            IANG  =  - 2 ** (5 - MENUH)
          ENDIF
          WRITE (IGGT(1:18), '(''VIEW CUR XROT'', I5)') IANG
        ENDIF
C * MENU BOX # 22
      ELSE IF (MENUV .EQ. 22) THEN
        IF (MMODE .EQ. 1 .OR. MMODE .EQ. 9) THEN
          IGBL(58) = 0
          REWIND LU2
          IF (MENUH .EQ. 1) THEN
            IGBL(54) = MAX (1, IGBL(54) - 1)
            IF (IGBL(54) .GT. 1) IGBL(58) = 1
            WRITE (IGGT, '(''ENTRY'', I6)') IGBL(54)
          ELSE
            IF (IGBL(54) .LT. IGBL(100)) THEN
              IGBL(54) = MAX (1, MIN (IGBL(54) + 1, IGBL(100)))
              WRITE (IGGT, '(''ENTRY'', I6)') IGBL(54)
            ELSE
              IGBL(45) = 0
              CALL PLA280 ('REM')
              IGBL(23) = 10
              CALL GEN108 (LU3, 0)
              WRITE (LU3, '(80X, /)')
              ENDFILE LU3
            ENDIF
          ENDIF
        ELSE IF (MMODE .EQ. 3) THEN
          CALL PLA015 (213, 1)
          IF (IPR(213) .EQ. 1) THEN
            IF (IPR(63) .EQ. 0) THEN
              CALL PLA280 ('LABEL ARU')
            ELSE
              LRET = -1
            ENDIF
          ELSE
            CALL PLA280 ('UNLABEL ARU')
          ENDIF
          IF (IGBL(35) .EQ. 0) LRET = -1
        ELSE IF (MMODE .EQ. 2 .OR.
     1          (MMODE .GE. 4 .AND. MMODE .LE. 6)) THEN
   20     IPR(346) = MOD(IPR(346) + 1, 2)
          IF (IPR(346) .EQ. 1) THEN
            IF (MENUH .EQ. 1) THEN
              IPR(477) = 0
            ELSE IF (MENUH .EQ. 2) THEN
              IPR(477) = -1
            ELSE
              IPR(477) = 1
            ENDIF
          ELSE
            IF (MENUH * IPR(477) .EQ. -2 .OR.
     1          MENUH * IPR(477) .EQ. 3 .OR.
     2         (MENUH  .EQ. 1 .AND. IPR(477) .EQ. 0)) THEN
              IPR(477) = 0
            ELSE
              GOTO 20
            ENDIF
          ENDIF
          IF (IGBL(35) .EQ. 1) THEN
            CALL PLA280 ('PLOT')
          ELSE
            LRET = -1
          ENDIF
        ELSE IF (MMODE .EQ. 7) THEN
          IPR(73) = MOD(IPR(73) + 1, 2)
        ELSE IF (MMODE .EQ. 8) THEN
          PAR(90) = MENUH * 0.01
          LRET = 4
        ELSE IF (MMODE .EQ. 10) THEN
          IGBL(58) = 0
          IF (MENUH .EQ. 1) THEN
            IGBL(54) = MAX (1, IGBL(54) - 1)
            IF (IGBL(54) .GT. 1) IGBL(58) = 1
          ELSE IF (MENUH .EQ. 2) THEN
            IGBL(54) = MAX (1, MIN (IGBL(54) + 1, IGBL(100)))
          ENDIF
          IPR(220) = 0
          IPR(221) = 1
          FN(1) = IGBL(54)
          CALL PLA011
          IF (IABS(IGBL(8)) .NE. 4) IGBL(24) = 0
          CALL PLA280 ('END')
          LRET = 3
        ELSE IF (MMODE .EQ. 11) THEN
          IF (IPR(30) .EQ. 0) PAR(27) = (MENUH - 3) * 0.2
          LRET = -1
        ELSE IF (MMODE .EQ. 12) THEN
          IGBL(69) = MOD(IGBL(69) + 1, 2)
          YGGIP = - 100 * (IGBL(69) + 1)
          CALL GGIP (0.0, YGGIP, 0.0, 0)
        ELSE IF (MMODE .EQ. 13) THEN
          IPR(346) = MOD(IPR(346) + 1, 2)
          CALL PLA280 ('REF')
        ELSE IF (MMODE .EQ. 16) THEN
          CALL PLA280 ('NEXT')
        ELSE IF (MMODE .EQ. 17) THEN
          IF (MENUH .EQ. 1) THEN
            CALL PLA280 ('PLATON ADDSYM')
          ELSE
            CALL PLA280 ('PLATON SOLV')
          ENDIF
        ELSE IF (MMODE .EQ. 18) THEN
          IF (IGBL(43) .EQ. 1) IGBL(42) = 1
          IGBL(42) = MOD(IGBL(42) + 1, 2)
          IGBL(43) = 0
          CALL PLA280 ('BROWSE LPS')
        ELSE IF (MMODE .EQ. 19) THEN
          CALL PLA280 ('CGLS')
        ELSE IF (MMODE .EQ. 21) THEN
          IPR(570) = MOD (IPR(570) + 1, 2)
          IPR(569) = 0
          LRET     = 3
        ELSE IF (MMODE .EQ. 22) THEN
          IF (IPR(415) .GT. 0) THEN
            IPR(182) = MOD(IPR(182) + 1, 2)
            IF (IGBL(25) * IGBL(32) .EQ. 1) THEN
              IF (IPR(182) .NE. 0) THEN
                BCD = 'Click on Unique Atoms to be Omitted'//CHAR(0)
                CALL GGIP (-999.0, 5.0 + FLOAT(IGBL(68) * IGBL(82)),
     1                     30.0, 110)
                CALL GGIP (0.0, 0.0, 0.0, 6)
                LRET = -1
              ELSE
                LRET = 2
              ENDIF
            ENDIF
          ELSE
            LRET = -1
          ENDIF
        ELSE IF (MMODE .EQ. 24) THEN
          IPR(346) = MOD(IPR(346) + 1, 2)
        ELSE IF (MMODE .EQ. 25) THEN
          PAR(415) = MENUH * 0.1
          CALL PLA280 ('CALC')
        ELSE IF (MMODE .EQ. 26) THEN
          CALL PLA280 ('CALC ADDSYM EXACT')
        ELSE
          LRET = -1
        ENDIF
C * MENU BOX # 23
      ELSE IF (MENUV .EQ. 23) THEN
        IF (MMODE .EQ. 1) THEN
          IGBL(103) = MOD(IGBL(103) + 1, 2)
          LRET = 3
        ELSE IF (MMODE .EQ. 2  .OR.
     1          (MMODE .GT. 4 .AND. MMODE .LE. 6)) THEN
          IF (IGBL(103) .EQ. 1) THEN
            CALL PLA280 ('BOX OFF')
          ELSE
            CALL PLA280 ('BOX ON')
          ENDIF
        ELSE IF (MMODE .EQ. 3) THEN
          CALL GEN038 (IGGT, 1, 80)
          IPR(141) = MOD(IPR(141) + 1, 2)
          IF (IPR(141) .EQ. 1) THEN
            CALL PLA280 (
     1           'OMIT OUTSIDE -0.1 1.1 -0.1 1.1 -0.1 1.1')
          ELSE
            CALL PLA280 ('OMIT OUTSIDE 0')
          ENDIF
        ELSE IF (MMODE .EQ. 4) THEN
          IF (MENUH .EQ. 1) THEN
            LMOD     = 1
            IFL(1)   = 'DEFINE'
            IPR(507) = 1
            CALL PLA015 (508, 1)
            LRET     = -1
          ELSE IF (MENUH .EQ. 3) THEN
            IF (IPR(508) .NE. 0) THEN
              IPR(507) = 3
              IPR(508) = 0
              WRITE (IGGT, 99995) (IFL(I), I = 1, LMOD)
              IGBL(23) = IABS(IGBL(23))
            ENDIF
          ENDIF
        ELSE IF (MMODE .EQ. 7) THEN
          IGBL(58) = 0
          IF (MENUH .EQ. 1) THEN
            IGBL(54) = MAX (1, IGBL(54))
            IF (IGBL(54) .GT. 1) IGBL(58) = 1
          ELSE
            IGBL(54) = IGBL(54) + 1
            IF (IGBL(54) .LT. IGBL(100)) THEN
              IGBL(54) = MAX (1, MIN (IGBL(54) + 1, IGBL(100)))
            ENDIF
          ENDIF
          WRITE (IGGT, '(''ENTRY'', I6)') IGBL(54)
          IGBL(67) = 0
          LRET = 3
        ELSE IF (MMODE .EQ. 8) THEN
          PAR(88) = MENUH * 0.01
          LRET = 4
        ELSE IF (MMODE .EQ. 9) THEN
          IF (MENUH .EQ. 1) THEN
            LMOD     = 1
            IFL(1)   = 'LSPL'
            IPR(551) = 1
            CALL PLA015 (552, 1)
            IPR(453) = 0
            IPR(448) = 0
            IPR(460) = 3
            IPR(476) = 0
            LRET     = -1
          ELSE IF (MENUH .EQ. 2) THEN
            IF (IPR(552) .NE. 0 .AND. LMOD .GT. 3) THEN
              LMOD      = LMOD + 1
              IPR(551)  = 2
              IFL(LMOD) = 'WITH'
            ENDIF
            LRET = -1
          ELSE IF (MENUH .EQ. 3) THEN
            IF (IPR(552) .NE. 0) THEN
              IPR(551) = 3
              CALL PLA015 (552, 1)
              IPR(81)  = - LMOD
              CALL PLA035 (1)
              LMOD     = 0
              IGBL(23) = IABS(IGBL(23))
            ELSE
              IGBL(23) = 10
              IF (IABS(IGBL(45)) .NE. 0) THEN
                CALL PLA280 ('END')
              ELSE
                CALL PLA280 ('REM')
              ENDIF
            ENDIF
          ENDIF
        ELSE IF (MMODE .EQ. 10) THEN
          IGBL(45) = MOD(IGBL(45) + 1, 2)
          ISAVEMOD = 1
          CALL GEN108 (LU3, 0)
          LRET = -1
        ELSE IF (MMODE .EQ. 11) THEN
          IF (IPR(30) .EQ. 0) PAR(2) = (MENUH - 1) * 0.2
          LRET = -1
        ELSE IF (MMODE .EQ. 12) THEN
          CALL PLA280 ('SET REVERSE')
          LRET = 2
        ELSE IF (MMODE .EQ. 13) THEN
          IGBL(103) = MOD(IGBL(103) + 1, 2)
          CALL PLA280 ('REF')
        ELSE IF (MMODE .EQ. 14) THEN
          IGBL(103) = MOD(IGBL(103) + 1, 2)
          IPR(389) = 0
          LRET     = 4
        ELSE IF (MMODE .EQ. 16) THEN
          IGBL(103) = MOD(IGBL(103) + 1, 2)
        ELSE IF (MMODE .EQ. 17) THEN
          IF (MENUH .EQ. 1) THEN
            CALL PLA280 ('VALID')
          ELSE
            CALL PLA280 ('REPORT')
          ENDIF
        ELSE IF (MMODE .EQ. 18) THEN
          IF (IGBL(42) .EQ. 1) IGBL(43) = 1
          IGBL(43) = MOD(IGBL(43) + 1, 2)
          IGBL(42) = 0
          CALL PLA280 ('BROWSE LIS')
        ELSE IF (MMODE .EQ. 19) THEN
          CALL PLA280 ('SHELXL')
        ELSE IF (MMODE .EQ. 21) THEN
          IGBL(103) = MOD(IGBL(103) + 1, 2)
        ELSE IF (MMODE .EQ. 22) THEN
          IGBL(103) = MOD(IGBL(103) + 1, 2)
          LRET = 2
        ELSE IF (MMODE .EQ. 24) THEN
          IGBL(103) = MOD(IGBL(103) + 1, 2)
        ELSE IF (MMODE .EQ. 25) THEN
          PAR(420) = MENUH * 0.05
          CALL PLA280 ('CALC')
        ELSE IF (MMODE .EQ. 26) THEN
          CALL PLA280 ('CALC ADDSYM PLOT')
        ELSE IF (MMODE .EQ. 28) THEN
          IGBL(103) = MOD(IGBL(103) + 1, 2)
        ELSE IF (MMODE .EQ. 30) THEN
          IGBL(103) = MOD(IGBL(103) + 1, 2)
          LRET = 3
        ELSE
          LRET = -1
        ENDIF
C * MENU BOX # 24
      ELSE IF (MENUV .EQ. 24) THEN
        IF (MMODE .EQ. 1) THEN
          IPR(346) = MENUH - 1
          CALL PLA015 (0, 0)
          MEDIUM      = 2
          IGGT(16:22) = 'ON     '
          CALL GGIP (-999.0, 0.0, 0.0, 6)
          LRET = 3
        ELSE IF (MMODE .EQ. 3) THEN
          IPR(105) = MOD(IPR(105) + 1, 2)
          IPR(130) = 0
          CALL PLA280 ('PLOT')
        ELSE IF (MMODE .EQ. 2 .OR. (MMODE .GE. 5
     1        .AND. MMODE .LE. 6)) THEN
          IF (MENUH .EQ. 1) THEN
            CALL PLA015 (0, 0)
            MEDIUM      = 2
            IGGT(16:22) = 'ON     '
            CALL GGIP (-999.0, 0.0, 0.0, 6)
            CALL PLA280 ('PLOT')
          ELSE IF (MENUH .EQ. 2) THEN
            CALL PLA280 ('PLOT POV')
            IPR (340) = 1
            IGBL(98)  = 0
          ELSE IF (MENUH .EQ. 3) THEN
            IPR (340) = 1
            CALL PLA280 ('PLOT PDB')
          ENDIF
        ELSE IF (MMODE .EQ. 4) THEN
          CALL PLA015 (311, MENUH)
          LRET = -1
        ELSE IF (MMODE .EQ. 7) THEN
          CALL PLA015 (462, 1)
          IF (IPR(462) .EQ. 1) THEN
            CALL PLA280 ('ENTRY')
          ELSE
            WRITE (IGGT, '(''ENTRY'', I6)') IGBL(54)
          ENDIF
        ELSE IF (MMODE .EQ. 8) THEN
          PAR(48) = (MENUH - 1) * 0.125
          LRET    = 4
        ELSE IF (MMODE .EQ. 9) THEN
          IF (MENUH .EQ. 1) THEN
            LMOD     = 1
            IFL(1)   = 'LSPL'
            IPR(460) = 1
            CALL PLA015 (476, 1)
            IPR(453) = 0
            IPR(448) = 0
            IPR(551) = 3
            IPR(552) = 0
            LRET     = -1
          ELSE IF (MENUH .EQ. 2) THEN
            IF (IPR(476) .NE. 0 .AND. LMOD .GT. 3) THEN
              LMOD      = LMOD + 1
              IPR(460)  = 2
              IFL(LMOD) = 'DIST'
            ENDIF
            LRET = -1
          ELSE IF (MENUH .EQ. 3) THEN
            IF (IPR(476) .NE. 0) THEN
              IPR(460) = 3
              CALL PLA015 (476, 1)
              IPR(81)  = - LMOD
              CALL PLA035 (1)
              LMOD     = 0
              IGBL(23) = IABS(IGBL(23))
            ELSE
              IGBL(23) = 10
              IF (IABS(IGBL(45)) .NE. 0) THEN
                CALL PLA280 ('END')
              ELSE
                CALL PLA280 ('REM')
              ENDIF
            ENDIF
          ENDIF
        ELSE IF (MMODE .EQ. 13) THEN
          IPR(346) = MENUH - 1
          CALL PLA015 (0, 0)
          MEDIUM = 2
          IGGT(16:22) = 'ON     '
          CALL GGIP (-999.0, 0.0, 0.0, 6)
          CALL PLA280 ('REF')
        ELSE IF (MMODE .EQ. 10) THEN
          CALL PLA015 (462, 1)
          IF (IPR(462) .EQ. 1) THEN
            CALL PLA280 ('ENTRY')
          ELSE
            WRITE (IGGT, '(''ENTRY'', I6)') IGBL(54)
          ENDIF
          LRET = 2
        ELSE IF (MMODE .EQ. 12) THEN
          IGBL(47) = - IGBL(47)
          IPR(590) = MOD (IPR(590) + 1, 2)
          CALL PLA280 ('REM')
          IGBL(23) = 10
          LRET = 2
        ELSE IF (MMODE .EQ. 16) THEN
          CALL PLA280 ('CALC')
        ELSE IF (MMODE .EQ. 17) THEN
          CALL PLA280 ('RENUM')
        ELSE IF (MMODE .EQ. 18) THEN
          CALL PLA280 ('PRUNE')
        ELSE IF (MMODE .EQ. 19) THEN
          IF (MENUH .EQ. 1) THEN
            CALL PLA280 ('LRES')
          ELSE
            CALL PLA280 ('SHXLPS')
          ENDIF
        ELSE IF (MMODE .EQ. 20) THEN
          CALL PLA280 ('NEXT')
        ELSE IF (MMODE .EQ. 21) THEN
          MEDIUM = 2
          IGGT(16:22) = 'ON     '
          CALL GGIP (-999.0, 0.0, 0.0, 6)
        ELSE IF (MMODE .EQ. 22) THEN
          IF (MENUH .EQ. 1) THEN
            CALL PLA280 ('UP')
          ELSE
            CALL PLA280 ('DOWN')
          ENDIF
        ELSE IF (MMODE .EQ. 24) THEN
          MEDIUM      = 2
          IGGT(16:22) = 'ON     '
          CALL GGIP (-999.0, 0.0, 0.0, 6)
        ELSE IF (MMODE .EQ. 25) THEN
          CALL PLA280 ('HKLF')
        ELSE IF (MMODE .EQ. 26) THEN
          CALL PLA280 ('CALC ADDSYM SHELX')
        ELSE IF (MMODE .EQ. 28) THEN
          MEDIUM = 2
          IGGT(16:22) = 'ON     '
          CALL GGIP (-999.0, 0.0, 0.0, 6)
        ELSE IF (MMODE .EQ. 29) THEN
          MEDIUM = 2
          IGGT(16:22) = 'ON     '
          CALL GGIP (-999.0, 0.0, 0.0, 6)
        ELSE IF (MMODE .EQ. 30) THEN
          IPR(346) = MENUH - 1
          CALL PLA015 (0, 0)
          MEDIUM      = 2
          IGGT(16:22) = 'ON     '
          CALL GGIP (-999.0, 0.0, 0.0, 6)
          LRET = 3
        ELSE
          LRET = -1
        ENDIF
C * MENU BOX # 25
      ELSE IF (MENUV .EQ. 25) THEN
        IF (MMODE .EQ. 1 .OR. MMODE .EQ. 8 .OR. MMODE .EQ. 9) THEN
          IF (MENUH .EQ. 1) THEN
            LRET = 1
            CALL PLA280 ('PLUTON')
            IPR(327) = 0
            IPR(328) = 0
            IPR(349) = 0
            IPR(440) = 0
          ELSE IF (MENUH .EQ. 2) THEN
            LRET = 1
            IF (IABS(IGBL(45)) .NE. 0) THEN
              IF (IPR(308) .EQ. 2) THEN
                CALL PLA280 ('EXIT')
                LRET = 7
              ELSE
                CALL PLA280 ('END')
              ENDIF
              IPR(351) = 0
            ELSE
              CALL PLA280 ('REM')
            ENDIF
          ENDIF
        ELSE IF (MMODE .GE. 2 .AND. MMODE .LE. 7) THEN
          IF (MENUH .EQ. 1) THEN
            CALL PLA280 ('RESET')
          ELSE IF (MENUH .EQ. 2) THEN
            IF (IABS(IGBL(8)) .NE. 4) IGBL(24) = 0
            CALL PLA280 ('END')
            IGBL(67) = 0
            LRET     = 3
          ENDIF
        ELSE IF (MMODE .GE. 10 .AND. MMODE .LE. 12) THEN
          IF (MENUH .EQ. 1) THEN
            CALL PLA281 (0)
            LRET = 2
          ELSE IF (MENUH .EQ. 2) THEN
            IF (IABS(IGBL(8)) .NE. 4) IGBL(24) = 0
            CALL PLA280 ('END')
            LRET = 3
          ENDIF
        ELSE IF (MMODE .EQ. 13) THEN
          IF (MENUH .EQ. 1) THEN
            CALL PLA280 ('PLUTON')
          ELSE IF (MENUH .EQ. 2) THEN
            CALL PLA280 ('NO')
          ENDIF
        ELSE IF (MMODE .EQ. 14) THEN
          IF (MENUH .EQ. 1) THEN
            MEDIUM      = 2
            IGGT(16:22) = 'ON     '
            CALL GGIP (-999.0, 0.0, 0.0, 6)
            IPR(389) = 0
          ELSE
            CALL PLA280 ('END')
            LRET = 2
          ENDIF
        ELSE IF (MMODE .EQ. 15) THEN
          CALL PLA280 ('CALC')
        ELSE IF (MMODE .EQ. 16) THEN
          IF (MENUH .EQ. 1) THEN
            MEDIUM      = 2
            IGGT(16:22) = 'ON     '
            CALL GGIP (-999.0, 0.0, 0.0, 6)
            CALL PLA280 ('PLOT')
          ELSE
            CALL PLA280 ('END')
          ENDIF
        ELSE IF (MMODE .GE. 17 .AND. MMODE .LE. 19) THEN
          IF (MENUH .EQ. 1) THEN
            CALL PLA280 ('SKIP')
          ELSE
            CALL PLA280 ('!')
          ENDIF
        ELSE IF (MMODE .EQ. 20) THEN
          CALL PLA280 ('END')
        ELSE IF (MMODE .EQ. 21) THEN
          IGBL(23) = 10
          CALL PLA281 (0)
          LRET     = 2
        ELSE IF (MMODE .EQ. 22) THEN
          IF (MENUH .EQ. 1) THEN
            MEDIUM      = 2
            IGGT(16:22) = 'ON     '
            CALL GGIP (-999.0, 0.0, 0.0, 6)
            CALL PLA280 ('EPS')
            LRET = 2
          ELSE
            CALL PLA280 ('QUIT')
          ENDIF
        ELSE IF (MMODE .EQ. 24) THEN
          LRET = 2
        ELSE IF (MMODE .EQ. 25) THEN
          CALL PLA280 ('END')
        ELSE IF (MMODE .EQ. 26) THEN
          CALL PLA280 ('END')
        ELSE IF (MMODE .EQ. 27) THEN
          IF (MENUH .EQ. 1) THEN
            CALL PLA280 ('SKIP')
          ELSE
            CALL PLA280 ('!')
          ENDIF
        ELSE IF (MMODE .EQ. 28) THEN
          CALL PLA280 ('END')
        ELSE IF (MMODE .EQ. 29) THEN
          CALL PLA280 ('END')
        ELSE IF (MMODE .EQ. 30) THEN
          CALL PLA280 ('END')
        ELSE
          LRET = -1
        ENDIF
      ENDIF
      RETURN
99999 FORMAT ('>> Labels may be moved by ''clicking'' on them',
     1        ' (When in LabPosOn-Mode)', //)
99998 FORMAT ('CELL', F9.5, 3F9.4, 3F8.2, F12.2, A)
99997 FORMAT ('RCELL ', 3F10.6, 3F9.2, F10.5, A)
99996 FORMAT (A, 'ROT', I5)
99995 FORMAT (10(A, 1X))
      END
      SUBROUTINE PLA017
      PARAMETER (NP12=600,NP13=500,NP17=99,NP38=125,NP39=30)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /FNAME/ KNM(8), KXT, KNM16
      COMMON /NAMES/ NAME(8), EXTENS, PROGNM, FNLU1, FNLU16, RDTYPE
      CHARACTER NAME*80, EXTENS*9, PROGNM*28, FNLU1*80, FNLU16*80,
     1          RDTYPE*7
      COMMON /GGT/ MEDIUM
      COMMON /CGGT/ IGGT
      CHARACTER IGGT*80
      IF ((IGBL(3) .NE. 1 .AND. IGBL(3) .NE. 33 .AND. IGBL(3) .NE. 34)
     1  .AND. (IGBL(50) .GT. -1 .AND. IGBL(50) .LT. 2))  THEN
        IGGT(2:80) = NAME(1)(1:79)
        PAR1 = -999.0
        PAR2 = FLOAT(-KNM(1))
        CALL GGIP (PAR1, PAR2, 0.0, 5)
        IF (IGBL(3) .EQ. 28) THEN
          MEDIUM   = 1
          IGGT(16:22) = 'OFF    '
          CALL GGIP (-999.0, 0.0, 0.0, 6)
        ENDIF
        YGGIP = 0.0
        ZGGIP = 0.0
        CALL GGIP (-999.0, YGGIP, ZGGIP, 8)
        IGBL(32) = NINT(YGGIP)
      ENDIF
      RETURN
      END
      SUBROUTINE PLA018 (MODE, X, Y, NQ)
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16,
     1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31, NP25=99, NP29=63,
     2 NP38=125,NP39=30,NP41=200,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      CHARACTER NQ*7, NQ1*7
      DELMIN = 100000.0
      IMIN   = 1
      NQ     = '*******'
      NAT    = IPR(39) + IPR(64)
      DO 10 I = 1, NAT
        II = IATC(I)
        IF (II .EQ. 0) GOTO 10
        CALL GEN048 (-1, JFG(II), 27, ISKP)
        IF (ISKP .EQ. 0) THEN
          CALL PLA047 (XLAB(IATC(I)), NQ1, IDUM, JDUM, 1, IGBL(55),
     1                 0, 0)
          IF (NQ1(1:2) .NE. 'Cg' .OR. IPR(506) .EQ. 1) THEN
            DEL = (XXO(I, 1) - X) ** 2 + (XXO(I, 2) - Y) ** 2
            IF (DEL .LT. DELMIN) THEN
              DELMIN = DEL
              IMIN   = I
            ENDIF
          ENDIF
        ENDIF
   10 CONTINUE
      IF (DELMIN .LT. 0.5) THEN
        IF (MODE .LE. 0) THEN
          IMN = IATC(IMIN)
          CALL PLA047 (XLAB(IMN), NQ, IDUM, JDUM, 1, IGBL(55), 0, 0)
          IF (MODE .EQ. -1 ) THEN
            IF (IMN .LE. IPR(37)) THEN
              CALL GEN048 (1, IFG(IMN), 30, 1)
            ELSE
              CALL PLA015 (427, 28)
              GOTO 20
            ENDIF
          ENDIF
          DSH = 0.15
          XX  = XXO(IMIN, 1)
          YY  = XXO(IMIN, 2)
          CALL GGIP (0.0, 2.0, 0.0, 0)
          CALL GGIP (XX,       YY + DSH, 0.0, 3)
          CALL GGIP (XX + DSH, YY,       0.0, 2)
          CALL GGIP (XX,       YY - DSH, 0.0, 2)
          CALL GGIP (XX - DSH, YY,       0.0, 2)
          CALL GGIP (XX,       YY + DSH, 0.0, 2)
          CALL GGIP (0.0, 0.0, 0.0, 6)
        ELSE
          IMIN = IATC(IMIN)
          CALL GEN048 (1, JFG(IMIN), 27, 1)
          IPR(201) = 0
        ENDIF
      ENDIF
   20 RETURN
      END
      SUBROUTINE PLA019 (MODE, IER)
      PARAMETER (NP4=9,NP10=16,NP12=600,NP13=500,NP17=99,NPVD=40000000,
     1 NP22=256,NP38=125,NP39=30,NP45=2048,NP46=15)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0
      COMMON /Q/ ICL, IFL(NP17)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /FNAME/ KNM(8), KXT, KNM16
      COMMON /NAMES/ NAME(8), EXTENS, PROGNM, FNLU1, FNLU16, RDTYPE
      CHARACTER NAME*80, EXTENS*9, PROGNM*28, FNLU1*80, FNLU16*80,
     1          RDTYPE*7
      CHARACTER DIRC*7
      CHARACTER OPTS*10
      COMMON /CMEN/ OPTS(NP46, 7)
      COMMON /IMEN/ IOPT(NP46, 7)
      COMMON /CGGT/ IGGT
      CHARACTER IGGT*80
      COMMON /CGG11/ BCD, SBCD
      CHARACTER BCD*132, SBCD*132
      LU = 0
      IF (MODE .EQ. 0) THEN
        LU = IGBL(5)
        IF (LU .EQ. LU5) THEN
          IF (IGBL(3) .EQ. 0 .AND. IGBL(25) * IGBL(32) .EQ. 1) THEN
            IF (IABS(IGBL(23)) .GE. 10 .AND.
     1          IABS(IGBL(23)) .LE. 12) THEN
              IF (IGBL(23) .LT. 0) GOTO 50
              WRITE (LU6, 99996)
C * OPEN MAIN X-WINDOW, GET INPUT FROM MENU/KEYPRESS
              IGBL(72) = 1
   10         BCD(1:12) = 'P.L.A.T.O.N'//CHAR(0)
              VERT = GL(1)
              HORS = VERT * GL(2)
              CALL GGIP (HORS, VERT, 0.0, 1)
              SIZ  = HORS / 63.0
              LINE = 'P L A T O N'
              CALL GGIP20 (0.0,  LINE, 11, 2.0, 4, 15, 3.7, VERT - 2.4)
              CALL GGIP20 (0.0,  LINE, 11, 2.0, 2, 15, 3.5, VERT - 2.5)
              LINE = 'A Multipurpose Crystallographic Tool'
              CALL GGIP20 (0.0,  LINE, 36, 0.6, 1, 3, 3.9, VERT - 3.5)
              CALL GEN040 (IGBL(9), NQ1, IP)
              MW = NPVD / 1000000
              CALL GEN040 (MW, NQ2, IP)
              LINE =
     1       '(C) 1980-2006 A.L.Spek - '//NQ2(1:IP)//'M-Version: '//NQ1
              CALL GGIP20 (0.0,  LINE, 50, 0.4, 3, 2, 5.0, VERT - 4.5)
              IF (IPR(37) .NE. 0 .OR. IPR(367) .NE. 0 .OR.
     1          PAR(101) .GT. 1.0) THEN
                FNLU1  = NAME(3)(1:KNM(3))//'.'//EXTENS(1:KXT)
                KNMXT  = KNM(3) + KXT + 1
                NKNMXT = MIN (KNMXT, 25)
                WRITE (LINE, 99999) DTYPE(IABS(IGBL(8))),
     1            FNLU1(1:NKNMXT), IGBL(54), MAX (1, IGBL(100)),
     2            JID(1:8)
                CALL GGIP20 (0.0,  LINE, 80, SIZ, 3, 2,
     1                 0.1, VERT - 17.5)
                NKNM16 = MIN (KNM16, 25)
                IF (IGBL(15) .GE. 0) THEN
                  IF (IGBL(37) .EQ. 1) THEN
                    DIRC = 'DIR-COS'
                  ELSE IF (IGBL(37) .EQ. 2) THEN
                    DIRC = 'ABS-PSI'
                  ELSE
                    DIRC = 'NO-DIRC'
                  ENDIF
                  CALL GGIP (0.0, 3.0, 0.0, 0)
                  WRITE (LINE, 99998) RDTYPE, FNLU16(1:NKNM16), DIRC,
     1                                DID
                  KNMXT = KNM16 + 60
                ELSE
                  CALL GGIP (0.0, 4.0, 0.0, 0)
                  WRITE (LINE, 99997) FNLU16(1:NKNM16)
                  KNMXT = KNM16 + 30
                ENDIF
                CALL GGIP20 (0.0,  LINE, KNMXT, SIZ, -1, 2, 0.1,
     1               VERT - 18.2)
                IF (IGBL(19) .EQ. 0 .AND. IABS(IGBL(8)) .EQ. 3) THEN
                  LINE = 'No check.def file found for CIF-Validation'
                  CALL GGIP20 (0.0,  LINE, 42, SIZ, 4, 2, 0.1,
     1                         VERT - 18.6)
                ENDIF
                CALL GGIP (0.0,  1.0, 0.0, 0)
                CALL GGIP (0.0, -2.0, 0.0, 0)
                XB = 0.0
                YB = VERT - 5.0
                CALL GGIP (XB, YB, 0.0, 3)
                XB = HORS
                CALL GGIP (XB, YB, 0.0, 2)
                XB = HORS
                YB = 0.0
                CALL GGIP (XB, YB, 0.0, 3)
                XB = HORS
                YB = VERT
                CALL GGIP (XB, YB, 0.0, 2)
                LINE(1:41)  =
     1              ' GRAPHICS  GEOM-CALC VOIDS TWIN SYMMETRY '
                LINE(42:73) = ' ABSORPTION   REPORT  MISC-TOOLS'
                CALL GGIP20 (0.0,  LINE, 73, SIZ, 5 + IGBL(68), 2, 0.1,
     1               VERT - 5.6)
                DO 30 I = 1, NP46
                  DO 20 J = 1, 7
                    IF ((IGBL(15) .LT. 0 .AND. IOPT(I, J) .GT. 1) .OR.
     1               (IOPT(I, J) .EQ. 5 .AND. IGBL(29) .NE. 1)) THEN
                      CALL GGIP (0.0, 4.0, 0.0, 0)
                    ELSE IF (IGBL(15) .GE. 0 .AND. IGBL(29) .EQ. 0
     1                   .AND. IOPT(I, J) .EQ. 3) THEN
                    ELSE IF (IOPT(I, J) .EQ. -2 .AND. (IPR(30) .NE. 0
     1                .OR. IPR(37) .EQ. 0))
     1                THEN
                      CALL GGIP (0.0, 4.0, 0.0, 0)
                    ELSE IF (IOPT(I, J) .EQ. -3 .AND. IPR(17) .NE. 0)
     1                THEN
                      CALL GGIP (0.0, 4.0, 0.0, 0)
                    ELSE IF (IOPT(I, J) .EQ. -4 .AND. IPR(30) .NE. 0
     1                                 .AND.  IPR(136) .EQ. 0) THEN
                      CALL GGIP (0.0, 4.0, 0.0, 0)
                    ELSE IF (IOPT(I, J) .EQ. -5 .AND. IPR(37) .EQ. 0)
     1                THEN
                      CALL GGIP (0.0, 4.0, 0.0, 0)
                    ELSE IF (IOPT(I, J) .EQ. -9) THEN
                      CALL GGIP (0.0, 4.0, 0.0, 0)
                    ELSE
                      CALL GGIP (0.0, 1.0, 0.0, 0)
                    ENDIF
                    IF (IOPT(I, J) .EQ. -1) THEN
                      IF (IPR(30) .NE. 0 .OR. IGBL(19) .EQ. 0 .OR.
     1                    IABS(IGBL(8)) .LT. 3 .OR.
     2                    IABS(IGBL(8)) .GT. 4) THEN
                        CALL GGIP (0.0, 4.0, 0.0, 0)
                      ELSE
                        CALL GGIP (0.0, 1.0, 0.0, 0)
                      ENDIF
                    ENDIF
                    IF (IGBL(76) .EQ. 0) THEN
                      IF ((I .EQ. 11 .AND. J .EQ. 6) .OR.
     1                    (I .EQ. 12 .AND. J .EQ. 6))
     2                     CALL GGIP (0.0, 4.0, 0.0, 0)
                    ENDIF
                    IF (IPR(75) .EQ. 1) THEN
                      IF (J .EQ. 1 .AND. I .EQ. 9)
     1                     CALL GGIP (0.0, 4.0, 0.0, 0)
                    ENDIF
                    YVERT = VERT - I * 11.0 / NP46 - 5.6
                    XHORS = 9 * SIZ * (J - 1) + 0.1
                    CALL GGIP20 (0.0,  OPTS(I, J), 10, SIZ, -1, 2,
     1                           XHORS, YVERT)
   20             CONTINUE
   30           CONTINUE
                CALL GGIP (0.0, -2.0, 0.0, 0)
                CALL GGIP (0.0, 1.0, 0.0, 0)
                XB = 0.0
                YB = VERT - 5.8
                CALL GGIP (XB, YB, 0.0, 3)
                XB = HORS
                CALL GGIP (XB, YB, 0.0, 2)
                XB = 0.0
                YB = VERT - 16.8
                CALL GGIP (XB, YB, 0.0, 3)
                XB = HORS
                CALL GGIP (XB, YB, 0.0, 2)
                XB = 0.0
                XBS = HORS / 7.0
                DO 40 I = 1, 7
                  XB = XB + XBS
                  YB = VERT - 16.8
                  CALL GGIP (XB, YB, 0.0, 3)
                  YB = VERT - 5.0
                  CALL GGIP (XB, YB, 0.0, 2)
   40           CONTINUE
                CALL GGIP (0.0, -1.0, 0.0, 0)
              ELSE
                LINE(1:26)  = 'NO PROPER INPUT FILE FOUND'
                CALL GGIP20 (0.0,  LINE, 26, 0.7, 2, 3, 4.8, VERT - 7.0)
                LINE(1:33)  = 'NO ATOM DATA, FACES OR CELL FOUND'
                CALL GGIP20 (0.0,  LINE, 33, 0.7, 2, 3, 2.7, VERT - 8.5)
                LINE(1:34)  = 'TO PROCEED'
                CALL GGIP20 (0.0,  LINE, 34, 0.7, 1, 3, 2.7, VERT - 11.)
                LINE(1:35)  = 'Enter ''FILE filename'' via Keyboard'
                CALL GGIP20 (0.0,  LINE, 35, 0.5, 1, 2, 2.7,
     1                       VERT - 12.5)
                LINE(1:26)  = 'or Enter Data via Keyboard'
                CALL GGIP20 (0.0,  LINE, 26, 0.5, 1, 2, 2.7,
     1                       VERT - 14.0)
                LINE(1:25)  = 'or Click on HELP for INFO'
                CALL GGIP20 (0.0,  LINE, 25, 0.5, 1, 2, 2.7,
     1                       VERT - 15.5)
              ENDIF
              IF (IGBL(47) .GT. 0) THEN
                LINE = 'Browser STARTUP'
                CALL GGIP20 (0.0,  LINE, 15, 0.7, 0, 3, HORS - 9.8, 0.3)
                LINE = 'Browser -'
                CALL GGIP20 (0.0,  LINE, 9, 0.7, 1, 3, HORS - 9.8, 0.3)
                LINE = 'HELP'
                CALL GGIP20 (0.0,  LINE,  4, 1.0, 1, 4, HORS - 3.5, 0.3)
                CALL GGIP (0.0, 0.0, 0.0, 6)
              ENDIF
   50         CALL PLA013 (0, 1)
              IF (LRET .EQ. 1) THEN
                GOTO 10
              ELSE IF (LRET .EQ. 2 .OR. LRET .EQ. 3) THEN
                GOTO 60
              ELSE IF (LRET .EQ. 4) THEN
                GOTO 70
              ENDIF
   60         ICL = IGGT
   70         CALL GEN038 (IGGT, 1, 80)
              GOTO 100
            ENDIF
          ELSE
            IF (IGBL(50) .EQ. 0) THEN
              CALL PLA285 (0, LU6, '>>')
            ELSE
              ICL = 'END'
              CALL GEN038 (IGGT, 1, 80)
              GOTO 100
            ENDIF
          ENDIF
        ENDIF
      ELSE IF (MODE .EQ. 1) THEN
        LU = LU5
C * CHECK FOR CONTINUE
        CALL PLA285 (1, LU6, ' ..... more (Y/N[Y])?')
      ENDIF
C * ACTUAL FILE READ
      IF (MODE .EQ. 1) THEN
        READ (LU, 99995, END = 110, ERR = 110) ICL(1:80)
        IF (ICL(1:1) .EQ. 'N' .OR. ICL(1:1) .EQ. 'n') GOTO 120
      ELSE
        READ (LU, 99995, END = 110, ERR = 110) ICL
      ENDIF
  100 IER = 0
      RETURN
C * READ FAILURE
  110 IER = -1
      RETURN
  120 IER =  1
      RETURN
99999 FORMAT ('Xtal Data (', A, '  ) ', A, '- Set', I5, '(', I5, '): ',
     1        A)
99998 FORMAT ('Refl Data (', A, ') ', A,  ' [ ', A, ']', ' :', A)
99997 FORMAT ('No Refl_Data on     ', A, ' or .hkl')
99996 FORMAT (/, ':: PLATON may be run without opening-window ',
     1        'with ''platon -o xxxx.yyy'' ', /)
99995 FORMAT (A)
      END
      SUBROUTINE PLA020 (X, Y, Z)
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118,
     1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NPVD=40000000,
     2 NP22=256,NP23=18000,NP25=99,NP29=63,NP37=175,NP38=125,NP39=30,
     3 NP41=200,NP45=2048,NP46=15,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON // YXMOL(2, NP23), VOID(NPVD)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /Q/ ICL, IFL(NP17)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9),
     1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10),
     2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10),
     3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770)
      COMMON /CHDAT/ CRD(NP37), LABP(16), COLR(NP10 + 1), BWCT(NP10 + 1)
      CHARACTER CRD*4, LABP*2, COLR*10, BWCT*10
      COMMON /CGG11/ BCD, SBCD
      CHARACTER BCD*132, SBCD*132
      COMMON /TPOS/ XTK(250, 3), NTK(25), KMX, IMIN
      COMMON /CGGT/ IGGT
      CHARACTER IGGT*80
      COMMON /KEYS/ STRING
      CHARACTER STRING*100
      COMMON /NKEYS/ NCNT
      CHARACTER NTYP*4, TADD*7
      COMMON /IMEN/ IOPT(NP46, 7)
      CHARACTER OPTS*10
      COMMON /CMEN/ OPTS(NP46, 7)
      COMMON /IITEM/ ITEM
      COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0
      COMMON /SIAT/ IAT, IATK
      COMMON /LABMOD/ LMOD
      YY    = VERT - Y
      SIZ   = HORS / 63.0
      MMODE = IGBL(23)
      JATK  = 0
      IASU  = 0
      LRET  = 1
      IF (IPR(344) .EQ. 1) THEN
        IF (IPR(447) .GT. 0) THEN
          IF (MMODE .EQ. 3) THEN
            CALL PLA115 (3, 1, X, Y, 0)
          ELSE IF (MMODE .EQ. 8) THEN
            CALL PLA115 (3, 0, X, Y, 0)
          ENDIF
          GOTO 10
        ENDIF
      ELSE IF (IPR(334) .EQ. 1) THEN
        IF (IPR(447) .GT. 0) THEN
          IF (MMODE .EQ. 3) THEN
            CALL PLA115 (4, 1, X, Y, 0)
          ELSE
            CALL PLA115 (4, 0, X, Y, 0)
          ENDIF
        ENDIF
        GOTO 10
      ELSE IF (IPR(343) .EQ. 1) THEN
        CALL PLA014 (1, 1, X, Y, ITEM, IASU)
        IPR(342) = ITEM
      ELSE IF (IPR(329) .GT. 0) THEN
        CALL PLA014 (1, 1, X, Y, ITEM, IASU)
        IF (ITEM .EQ. 0) GOTO 10
        LMOD = LMOD + 1
        CALL PLUT25 (1, ITEM, IDUM)
        IFL(LMOD + 2) = NQ1
        IF (IPR(329) .EQ. 1) THEN
          IF (LMOD .LT. 2) GOTO 10
        ELSE
          IF (LMOD .LT. 3) GOTO 10
        ENDIF
        IPR(220) = LMOD + 2
        CALL PLUT06
        IPR(329) = 0
        LMOD     = 0
        GOTO 100
      ELSE IF (IPR(182) .EQ. 1) THEN
        CALL PLA018 (-1, X, YY, NQ1)
        GOTO 10
      ELSE IF (IPR(415) .GT. 0) THEN
        CALL PLA018 (0, X, YY, NQ1)
        CALL PLA280 (NQ1)
        GOTO 100
      ELSE IF (IPR(312) .GT. 0) THEN
        CALL PLA018 (0, X, YY, NQ1)
        IF (NQ1(1:1) .NE. '*') THEN
          LMOD = LMOD + 1
          IF (MOD(LMOD, 2) .EQ. 1) THEN
            XHORS = HORS - 4.0
            YHORS = VERT - 0.5 - (LMOD + 1) * 0.25
          ELSE
            XHORS = HORS - 2.0
            YHORS = VERT - 0.5 - LMOD * 0.25
          ENDIF
          CALL GGIP20 (0.0, NQ1, 6, 0.3, 5 + IGBL(68), 1,
     1                 XHORS, YHORS)
          IFL(LMOD + 1) = NQ1
          WRITE (LU6,'(I5, 1X, A)') LMOD, NQ1
        ENDIF
        GOTO 10
      ELSE IF (IPR(536) .GT. 0) THEN
        CALL PLA018 (0, X, YY, NQ1)
        CALL PLA046 (3, NQ1, IENM, LBB, LBC, LBD, XNQNR, YNQNR, N1)
        CALL PLA280 ('COLOR TYPE '//LMT(IENM, 1)//' '//COLR(IPR(536)))
        IPR(536) = 0
        GOTO 100
      ELSE IF (IPR(341) .GT. 0) THEN
        IF (IABS(MMODE) .EQ. 1 .OR. IABS(MMODE) .EQ. 8 .OR.
     1      IABS(MMODE) .EQ. 9) THEN
          CALL PLA018 (0, X, YY, NQ1)
          LMOD = LMOD + 1
          IFL(LMOD + 1) = NQ1
          WRITE (SBCD, 99999) (IFL(I), I = 1, LMOD + 1)
          IF (LMOD .GE. MIN(4,IPR(341))) THEN
            IPR(81) = LMOD + 1
            CALL PLA035 (1)
            LMOD = 0
            IGBL(23) = IABS(IGBL(23))
          ENDIF
          GOTO 10
        ELSE
          CALL PLA014 (1, 1, X, Y, ITEM, IASU)
          IF (ITEM .EQ. 0) GOTO 10
          IF (IPR(341) .EQ. 1) THEN
            IFL(1) = 'GEOM'
          ELSE IF (IPR(341) .EQ. 2) THEN
            IFL(1) = 'DIST '
            IF (IASU .GT. 1) THEN
              IF (LMOD .EQ. 0) THEN
                GOTO 10
              ELSE IF (LMOD .EQ. 1) THEN
                FN(1)    = - IASU
                IPR(221) = 1
              ENDIF
            ENDIF
          ELSE IF (IPR(341) .EQ. 3) THEN
            IFL(1) = 'ANGLE'
          ELSE IF (IPR(341) .EQ. 4) THEN
            IFL(1) = 'TORSION'
          ENDIF
          LMOD = LMOD + 1
          CALL PLUT25 (1, ITEM, IDUM)
          IFL(LMOD + 1) = NQ1
          WRITE (SBCD, 99999) (IFL(I), I = 1, LMOD + 1), CHAR(0)
          IF (LMOD .LT. IPR(341)) GOTO 10
          IPR(220) = LMOD + 1
          IPR(163) = 0
          CALL PLUT24 (LMOD, IPR(38), IDUM)
          LMOD = 0
          IF (IPR(130) .EQ. 0) GOTO 100
        ENDIF
      ELSE IF ((IPR(476) .NE. 0 .OR. IPR(552) .NE. 0)
     1         .AND. MMODE .EQ. 9) THEN
        CALL PLA018 (0, X, YY, NQ1)
        LMOD      = LMOD + 1
        IFL(LMOD) = NQ1
        GOTO 10
      ELSE IF (IPR(508) .NE. 0 .AND. MMODE .EQ. 1) THEN
        CALL PLA018 (0, X, YY, NQ1)
        LMOD      = LMOD + 1
        IFL(LMOD) = NQ1
        IF (LMOD .EQ. 2) THEN
          LMOD      = LMOD + 1
          IFL(LMOD) = 'TO'
          IPR(507)  = 2
        ENDIF
        GOTO 10
      ELSE IF (IPR(508) .NE. 0 .AND. MMODE .EQ. 4) THEN
        CALL PLA014 (1, 1, X, Y, ITEM, IASU)
        IF (ITEM .EQ. 0) THEN
          LMOD = 0
          GOTO 10
        ENDIF
        CALL PLUT25 (1, ITEM, IDUM)
        LMOD = LMOD + 1
        IFL(LMOD) = NQ1
        IF (LMOD .EQ. 2) THEN
          LMOD      = LMOD + 1
          IFL(LMOD) = 'TO'
          IPR(507)  = 2
        ENDIF
        GOTO 10
      ELSE IF (IPR(311) .NE. 0) THEN
        IF (IABS(MMODE) .EQ. 1 .OR. IABS(MMODE) .EQ. 8) THEN
          LMOD = LMOD + 1
          IF (LMOD .EQ. 1) THEN
            CALL PLA018 (0, X, YY, NQ1)
            GOTO 10
          ELSE
            CALL PLA018 (0, X, YY, NQ2)
            IF (IPR(311) .EQ. 1) THEN
              CALL PLA280 ('JOIN '//NQ1//NQ2)
            ELSE IF (IPR(311) .EQ. 2) THEN
              CALL PLA280 ('JOIN DASH '//NQ1//NQ2)
            ELSE
              CALL PLA280 ('DETACH '//NQ1//NQ2)
            ENDIF
            GOTO 100
          ENDIF
        ELSE IF (MMODE .EQ. 4) THEN
          CALL PLA014 (1, 1, X, Y, ITEM, IASU)
          IF (ITEM .EQ. 0) THEN
            LMOD = 0
            GOTO 10
          ENDIF
          LMOD = LMOD + 1
          CALL PLUT25 (LMOD, ITEM, IDUM)
          IF (LMOD .EQ. 1) THEN
            IAT  = ITEM
            IATK = IDUM
          ELSE
            JAT  = ITEM
            JATK = IDUM
          ENDIF
          IF (LMOD .LT. 2) GOTO 10
          IF (IPR(221) .EQ. 0) THEN
            CALL PLUT22 (IAT, JAT, DIST)
            IF (DIST .GT. RADR(IATK, 3) + RADR(JATK, 3) + 0.8) THEN
              TADD = ' 0.05 2'
            ELSE
              TADD = '       '
            ENDIF
          ENDIF
          IF (IPR(311) .EQ. 1) THEN
            CALL PLA280 ('JOIN '//NQ1//NQ2//TADD)
          ELSE IF (IPR(311) .EQ. 2) THEN
            CALL PLA280 ('JOIN DASH '//NQ1//NQ2//TADD)
          ELSE
            CALL PLA280 ('DETACH '//NQ1//NQ2)
          ENDIF
          GOTO 100
        ENDIF
      ELSE IF (IPR(439) .EQ. 1) THEN
        WRITE (IGGT, '(''CPS'', 2F10.3)') X, PAR(38) - Y
        GOTO 100
      ENDIF
      IF (MMODE .EQ. 1) THEN
        IPR(478) = 0
        IF (IPR(351) .EQ. 1) THEN
          CALL PLA018 (1, X, YY, NQ1)
        ELSE IF (IPR(440) .EQ. 1) THEN
          CALL PLA018 (0, X, YY, NQ1)
          CALL GEN020 (1, NQ1, 1, 7)
          IF (NQ1(2:2) .EQ. ' ') THEN
            NQ1(2:3) = '()'
          ELSE
            DO 30 III = ICHAR('A'), ICHAR('Z')
              IF (NQ1(2:2) .EQ. CHAR(III)) THEN
                IF (NQ1(3:3) .EQ. ' ') THEN
                  NQ1(3:4) = '()'
                ENDIF
              ENDIF
   30       CONTINUE
          ENDIF
          CALL PLA280 ('CALC COORDN '//NQ1)
        ELSE IF (IPR(440) .EQ. -1) THEN
          IF (X .LT. PAR(37) / 2) THEN
            IMIN = 0
            DISM = 1000.0
            DO 40 III = 1, 100
              DIS = ABS(YY - YMOL(1, III))
              IF (DIS .LT. DISM) THEN
                IMIN = III
                DISM = DIS
              ENDIF
   40       CONTINUE
            IF (IMIN .NE. 0) THEN
              FN(1)    = YMOL(2, IMIN)
              IPR(221) = 1
              CALL PLA295
            ENDIF
          ENDIF
        ELSE IF (IPR(349) .NE. 0 .OR. IPR(327) .NE. 0
     1               .OR. IPR(328) .NE. 0) THEN
          IF (LMOD .EQ. 0) THEN
            DELMIN = 1000.0
            IMIN = 1
            DO 50 I = 1, IPR(39) + IPR(64)
              III = I * (NP4 + 15)
              DEL = (VOID(III - 2) - X)**2 + (VOID(III - 1) - YY)**2
              IF (IPR(328) .EQ. 1) THEN
                IVAL = 1
              ELSE
                CALL GEN048 (-1, JFG(I), 11, IVAL)
              ENDIF
              IF (IVAL .EQ. 1 .AND. DEL .LT. DELMIN) THEN
                CALL GEN048 (-1, IFG(I), 7, IHAT)
                IF (IHAT .NE. 1 .OR. IPR(212) * IPR(232) .NE. 0)
     1             THEN
                  IMIN   = I
                  DELMIN = DEL
                ENDIF
              ENDIF
   50       CONTINUE
            CALL PLA047 (XLAB(IMIN), NQ1, IDUM, JDUM,
     1                   IPR(350) * 2 - 1, IGBL(55), 0, 0)
            LMOD = 1
            X    = VOID (IMIN * (NP4 + 15) - 2)
            YY   = VOID (IMIN * (NP4 + 15) - 1)
          ELSE
            LMOD = 0
            VOID (IMIN * (NP4 + 15) - 2) = X
            VOID (IMIN * (NP4 + 15) - 1) = YY
          ENDIF
          IF (IPR(328) .EQ. 1) THEN
            CALL GEN048 (1, JFG(IMIN), 11, 1)
            LMOD = 0
          ENDIF
          YGGIP = FLOAT(1 - LMOD)
          CALL GGIP20 (0.0, NQ1, 6, PAR(349), NINT(YGGIP), 1, X, YY)
          IF (IPR(327) .EQ. 1) THEN
            CALL GEN048 (1, JFG(IMIN), 11, 0)
            LMOD = 0
          ENDIF
          GOTO 10
        ELSE
          GOTO 10
        ENDIF
      ELSE IF (MMODE .EQ. 2) THEN
        GOTO 10
      ELSE IF (MMODE .EQ. 3) THEN
        IF (IPR(349) .EQ. 1) THEN
          IF (LMOD .EQ. 0) THEN
            CALL PLA014 (-1, 1, X, Y, ITEM, IASU)
            NRCOL = 0
            CALL PLUT14 (-1, ITEM, IASU, NRCOL, XL, YL, ZL, RL)
            IF (ITEM .NE. 0) THEN
              CALL GGIP (0.0, 0.0, 0.0, 0)
              CALL PLUT25 (1, ITEM - IPR(62), IATK)
              CALL PLUT04 (1, ITEM - IPR(62))
              IPR(117) = 0
              CALL GGIP (0.0, 1.0, 0.0, 0)
              LMOD = 1
            ENDIF
          ELSE
            XL    =   X + PAR(61)
            YL    = - Y - PAR(62)
            NRCOL = 0
            CALL PLUT14 (1, ITEM, IASU, NRCOL, XL, YL, ZL, RL)
            CALL PLUT15 (4, ITEM - IPR(62), 37, 15)
            LMOD = 0
            CALL PLUT04 (1, ITEM - IPR(62))
            IPR(117) = 0
          ENDIF
          GOTO 10
        ELSE IF (IPR(213) .EQ. 1) THEN
          CALL PLA014 (-2, 1, X, Y, ITEM, IASU)
          ITEM = ITEM - IPR(62) - IPR(37)
          IF (ITEM .GT. 0) THEN
            CALL PLUT17 (FLOAT(ITEM), 1005, M, LU6)
          ELSE
            GOTO 10
          ENDIF
        ELSE IF (IPR(332) .EQ. 1 .OR. IPR(335) .EQ. 1 .OR.
     1    IPR(351) .EQ. 1 .OR. IPR(352) .EQ. 1) THEN
          CALL PLA014 (1, 1, X, Y, ITEM, IASU)
          IF (ITEM .NE. 0) THEN
            CALL PLUT25 (1, ITEM, IATK)
            IF (IPR(351) .EQ. 1) THEN
              WRITE (IGGT(1:), '(''DELETE '', A)') NQ1
            ELSE IF (IPR(352) .EQ. 1) THEN
              WRITE (IGGT(1:), '(''ANIS '', A)') NQ1
              CALL PLUT15 (1, ITEM, 41, 1)
            ELSE IF (IPR(332) .EQ. 1) THEN
              IF (IGBL(25) .EQ. 0) THEN
                WRITE (LU6, '(''HFIX '', A, 1X, $)') NQ1
                READ (LU5, '(A)') NQ2
                WRITE (IGGT(1:), '(''HFIX '', A, A)') NQ1, NQ2
              ELSE
                IF (NCNT .EQ. 0) THEN
                  STRING(1:4) = 'HFIX'
                  NCNT = 4
                ENDIF
                CALL GEN039 (1, NQ1, 1, 7, NB, NE)
                STRING(NCNT + 1:) = ' '//NQ1(1:NE)//' '
                NCNT = NCNT + NE + 2
                SBCD = STRING(1:NCNT)//CHAR(0)
                CALL GEN038 (IGGT, 1, 80)
                CALL PLA280 (STRING(1:NCNT))
                NCNT = 0
                GOTO 100
              ENDIF
            ELSE IF (IPR(335) .EQ. 1) THEN
              IF (IGBL(25) .EQ. 0) THEN
                READ (LU5, '(A)') NQ2
                WRITE (IGGT(1:), '(''REN '', A, A)') NQ1, NQ2
              ELSE
                IF (NCNT .EQ. 0) THEN
                  STRING(1:6) = 'RENAME'
                  NCNT = 6
                  CALL GEN039 (1, NQ1, 1, 7, NB, NE)
                  STRING(NCNT + 1:) = ' '//NQ1(1:NE)//' '
                  NCNT = NCNT + NE + 2
                ENDIF
                CALL GGIP( 0.0,  1.0,  0.0, 0)
                SBCD = STRING(1:NCNT)//CHAR(0)
                CALL GEN038 (IGGT, 1, 80)
                CALL PLA280 (STRING(1:NCNT))
                NCNT = 0
                GOTO 100
              ENDIF
            ELSE
              GOTO 10
            ENDIF
          ELSE
            GOTO 10
          ENDIF
        ELSE
          CALL PLA115 (5, 1, X, Y, LMOD)
          GOTO 10
        ENDIF
      ELSE IF (MMODE .EQ. 4) THEN
        CALL PLA014 (1, 1, X, Y, ITEM, IASU)
        IF (ITEM .NE. 0) THEN
          CALL PLUT25 (1, ITEM, IATK)
          NET = IEL(IEN(IATK))
          N1 = NET / 100
          N2 = NET - N1 * 100
          NTYP = ' '//CHAR(ICHAR('A') + N1 - 1)//'  '
          IF (N2 .NE. 0) NTYP(3:3) = CHAR(ICHAR('a') + N2 - 1)
          IF (IPR(348) .EQ. 1) THEN
            IF (IPR(461) .EQ. 0) THEN
              IF (IPR(478) .EQ. 0) THEN
                IPR(340) = IPR(340) + 1
                IF (IPR(340) .GT. 17) IPR(340) = 1
                CALL PLA280 ('BWC TYPE'//NTYP//BWCT(IPR(340)))
              ENDIF
            ELSE
              IPR(139) = IPR(139) + 1
              IF (IPR(139) .GT. 17) IPR(139) = 1
              CALL PLA280 ('PLOT')
            ENDIF
          ELSE IF (IPR(338) .EQ. 1) THEN
            IPR(337) = IPR(337) + 1
            IF (IPR(337) .GT. 9) IPR(337) = 1
            CALL PLA280 ('COLOR TYPE'//NTYP//COLR(IPR(337)))
          ENDIF
        ELSE
          GOTO 10
        ENDIF
      ELSE IF (MMODE .EQ. 5) THEN
        GOTO 10
      ELSE IF (MMODE .EQ. 6) THEN
        GOTO 10
      ELSE IF (MMODE .EQ. 8 .OR. MMODE .EQ. 9) THEN
        CALL PLA115 (5, 0, X, Y, LMOD)
        GOTO 10
      ELSE IF (MMODE .EQ. 22) THEN
        GOTO 10
      ELSE IF (MMODE .EQ. 19) THEN
        GOTO 10
      ELSE IF (MMODE .EQ. 7  .OR. MMODE .EQ. 10 .OR.
     1         MMODE .EQ. 11 .OR. MMODE .EQ. 12) THEN
        IF (IPR(462) .EQ. 0) THEN
          IF (IPR(37) .NE. 0 .OR. IPR(367) .NE. 0 .OR.
     1        PAR(101) .GT. 1.0) THEN
            NH = INT(7.0 * X / HORS) + 1
            IF (NH .LT. 1 .OR. NH .GT. 7) GOTO 10
            NV = INT((Y - 4.8) * NP46 / 11.0)
            IF (NV .LT. 0 .OR. NV .GT. NP46) THEN
              NH = 7
              NV = NP46 + 1
            ENDIF
          ELSE
            NH = 7
            NV = NP46 + 1
          ENDIF
          IF (NH .EQ. 7 .AND. (NV .EQ. NP46 + 1)) THEN
            CALL PLA300 (1, 0, 0)
            GOTO 10
          ELSE IF (NINT(Z) .EQ. 3) THEN
            CALL PLA300 (1, NH, NV)
            GOTO 10
          ENDIF
          IF (NV .GT. 0 .AND. NV .LE. NP46) THEN
            IF ((IOPT(NV, NH) .GT. 1 .AND. IGBL(15) .LT. 0) .OR.
     1        (IOPT(NV, NH) .EQ. 3 .AND. IGBL(15) .EQ. 0 .AND.
     2          IGBL(29) .EQ. 0)) THEN
              CALL PLA015 (427, 7)
              GOTO 10
            ENDIF
          ELSE
            GOTO 10
          ENDIF
          YVERT = VERT - NV * 11.0 / NP46 - 5.6
          XHORS = 9 * SIZ * (NH - 1) + 0.1
          CALL GGIP20 (0.0,  OPTS(NV, NH), 10, SIZ, 2, 2, XHORS, YVERT)
          IF (NH .EQ. 1) THEN
            IF (NV .EQ. 1) THEN
              IGBL(23) = 1
              IGBL(24) = 1
              IPR(68)  = 0
              CALL PLA280 ('PLUTON')
            ELSE IF (NV .EQ. 2) THEN
              IGBL(23) = 1
              CALL PLA280 ('PLOT ADP COLOR')
            ELSE IF (NV .EQ. 3) THEN
              CALL PLA280 ('PLOT NEWMAN COLOR')
            ELSE IF (NV .EQ. 4) THEN
              CALL PLA280 ('PLOT RING COLOR')
              IGBL(23) = 13
            ELSE IF (NV .EQ. 5) THEN
              CALL PLA280 ('PLOT PLAN COLOR')
              IGBL(23) = 13
            ELSE IF (NV .EQ. 6) THEN
              IGBL(23) = 30
              CALL PLA280 ('PLOT POLY')
            ELSE IF (NV .EQ. 7) THEN
              IGBL(23) = 9
              PAR(274) = 0.0
              PAR(275) = 0.0
              PAR(276) = 0.0
              CALL PLA280 ('CONTOUR DI TN')
            ELSE IF (NV .EQ. 8) THEN
              IGBL(23) = 9
              PAR(274) = 0.0
              PAR(275) = 0.0
              PAR(276) = 0.0
              CALL PLA280 ('CONTOUR FO TN')
            ELSE IF (NV .EQ. 9) THEN
              CALL PLA280 ('FIT')
            ELSE IF (NV .EQ. 10) THEN
              CALL PLA280 ('POWDER IOBS')
            ELSE IF (NV .EQ. 11) THEN
              CALL PLA280 ('POWDER')
            ELSE IF (NV .EQ. 12) THEN
              CALL PLA280 ('CALC RDF')
            ELSE IF (NV .EQ. 15) THEN
              IGBL(3)  = 8
              IGBL(23) = 2
              IGBL(24) = 1
              IGBL(75) = 0
              CALL PLA280 ('PLUTON NATIVE')
              LRET = 3
            ENDIF
C * GEOM TOOLS
          ELSE IF (NH .EQ. 2) THEN
            IF (NV .EQ. 1) THEN
              CALL PLA280 ('CALC')
            ELSE IF (NV .EQ. 2) THEN
              CALL PLA280 ('CALC INTRA')
            ELSE IF (NV .EQ. 3) THEN
              CALL PLA280 ('CALC INTER')
            ELSE IF (NV .EQ. 4) THEN
              CALL PLA280 ('CALC COORDN')
            ELSE IF (NV .EQ. 5) THEN
              CALL PLA280 ('CALC METAL')
            ELSE IF (NV .EQ. 6) THEN
              CALL PLA280 ('CALC GEOM')
            ELSE IF (NV .EQ. 7) THEN
              CALL PLA280 ('CALC HBONDS')
            ELSE IF (NV .EQ. 8) THEN
              CALL PLA280 ('CALC TMA')
            ELSE IF (NV .EQ. 9) THEN
              IPR(460) = 1
              CALL PLA280 ('PLOT ADP COLOR')
            ELSE IF (NV .EQ. 10) THEN
              IPR(551) = 1
              CALL PLA280 ('PLOT ADP COLOR')
            ELSE IF (NV .EQ. 11) THEN
              IPR(341) = 5
              CALL PLA280 ('PLOT ADP COLOR')
            ELSE IF (NV .EQ. 12) THEN
              IPR(551) = 1
              CALL PLA280 ('PLOT ADP COLOR')
            ELSE IF (NV .EQ. 13) THEN
              CALL PLA280 ('PLOT RING COLOR')
              IGBL(23) = 13
            ELSE IF (NV .EQ. 14) THEN
              IGBL(121) = 1
              CALL PLA280 ('CALC COORDN NOANG 4.0')
            ELSE IF (NV .EQ. 15) THEN
              IF (IABS(IGBL(8)) .EQ. 2) THEN
                IGBL(3) = 13
                CALL PLA280 ('PLUTON')
              ELSE
                CALL PLA015 (427, 30)
                GOTO 10
              ENDIF
            ENDIF
          ELSE IF (NH .EQ. 3) THEN
            IF (NV .EQ. 1) THEN
              CALL PLA280 ('CALC SOLV')
            ELSE IF (NV .EQ. 2) THEN
              CALL PLA280 ('CALC VOID')
            ELSE IF (NV .EQ. 3) THEN
              CALL PLA280 ('CALC SQUEEZE')
            ELSE IF (NV .EQ. 4) THEN
              CALL PLA280 ('CALC FCF')
            ELSE IF (NV .EQ. 5) THEN
              IGBL(23) = 9
              PAR(274) = 0.0
              PAR(275) = 0.0
              PAR(276) = 0.0
              CALL PLA280 ('CONTOUR SQ TN')
            ELSE IF (NV .EQ. 6) THEN
              CALL PLA280 ('CALC SOLV GRID 0.35 F3D')
            ELSE IF (NV .EQ. 7) THEN
              CALL PLA280 ('CALC SOLV PLOT')
            ELSE IF (NV .EQ. 8) THEN
              CALL PLA280 ('CAVITY')
            ELSE IF (NV .EQ. 9) THEN
            ELSE IF (NV .EQ. 10) THEN
            ELSE IF (NV .EQ. 11) THEN
            ELSE IF (NV .EQ. 14) THEN
              CALL PLA280 ('LEPAGE 0.0 6')
            ELSE IF (NV .EQ. 15) THEN
              IF (IGBL(29) .LE. 0) THEN
                CALL PLA280 ('CALC FCF')
                IPR(516) = 1
              ELSE
                CALL PLA280 ('ROTMAT')
              ENDIF
            ENDIF
          ELSE IF (NH .EQ. 4) THEN
            IF (NV .EQ. 1) THEN
              CALL PLA280 ('CALC ADDSYM')
            ELSE IF (NV .EQ. 2) THEN
              CALL PLA280 ('CALC ADDSYM EQUAL')
            ELSE IF (NV .EQ. 3) THEN
              CALL PLA280 ('CALC ADDSYM EXACT')
            ELSE IF (NV .EQ. 4) THEN
              CALL PLA280 ('CALC ADDSYM PLOT')
            ELSE IF (NV .EQ. 5) THEN
              CALL PLA280 ('CALC ADDSYM SHELX NOSF')
            ELSE IF (NV .EQ. 6) THEN
              CALL PLA280 ('CALC NEWSYM')
            ELSE IF (NV .EQ. 7) THEN
              CALL PLA280 ('CALC NONSYM')
            ELSE IF (NV .EQ. 8) THEN
              CALL PLA280 ('LEPAGE')
            ELSE IF (NV .EQ. 9) THEN
              CALL PLA280 ('DELRED')
            ELSE IF (NV .EQ. 10) THEN
              CALL PLA280 ('CALC MOLSYM')
            ELSE IF (NV .EQ. 12) THEN
              CALL PLA280 ('ASYM')
            ELSE IF (NV .EQ. 13) THEN
              CALL PLA280 ('ASYM AVF')
            ELSE IF (NV .EQ. 14) THEN
              CALL PLA280 ('SPGR')
            ELSE IF (NV .EQ. 15) THEN
              CALL PLA280 ('STIDY')
            ENDIF
          ELSE IF (NH .EQ. 5) THEN
            IF (NV .EQ. 1) THEN
              CALL PLA280 ('CALC DELABS')
            ELSE IF (NV .EQ. 2) THEN
              CALL PLA280 ('ABSP')
            ELSE IF (NV .EQ. 3) THEN
              CALL PLA280 ('ABST')
            ELSE IF (NV .EQ. 4) THEN
              CALL PLA280 ('ABSG')
            ELSE IF (NV .EQ. 5) THEN
              CALL PLA280 ('ABSX')
            ELSE IF (NV .EQ. 6) THEN
              CALL PLA280 ('ABSS')
            ELSE IF (NV .EQ. 7) THEN
              CALL PLA280 ('MULABS')
              IGBL(23) = 16
            ELSE IF (NV .EQ. 8) THEN
              CALL PLA280 ('SHXABS')
            ELSE IF (NV .EQ. 9) THEN
            ELSE IF (NV .EQ. 10) THEN
            ELSE IF (NV .EQ. 11) THEN
            ELSE IF (NV .EQ. 15) THEN
              CALL PLA280 ('XTAL')
            ENDIF
          ELSE IF (NH .EQ. 6) THEN
            IF (NV .EQ. 1) THEN
              IF (IABS(IGBL(8)) .LT. 3 .OR. IABS(IGBL(8)) .GT. 4
     1            .OR. IPR(30) .NE. 0) GOTO 10
              IGBL(66)  = 1
              IGBL(19)  = IABS(IGBL(19))
              IGBL(3)   = 1
              LU6       = LU20
              CALL PLA280 ('VALI')
            ELSE IF (NV .EQ. 2) THEN
              CALL PLA280 ('ASYM AVF VIEW')
              IGBL(23) = 14
            ELSE IF (NV .EQ. 3) THEN
              CALL PLA280 ('ASYM AVF VALID')
            ELSE IF (NV .EQ. 4) THEN
              CALL PLA280 ('TABLE')
            ELSE IF (NV .EQ. 5) THEN
              IF (IGBL(29) .EQ. 1) THEN
                CALL PLA280 ('VARIANCE')
              ELSE
                GOTO 10
              ENDIF
            ELSE IF (NV .EQ. 6) THEN
                CALL PLA280 ('BIJVOET')
            ELSE IF (NV .EQ. 7) THEN
              CALL PLA280 ('ASYM EXPECT')
            ELSE IF (NV .EQ. 8) THEN
            ELSE IF (NV .EQ. 9) THEN
            ELSE IF (NV .EQ. 10) THEN
              CALL PLA280 ('EXPT')
            ELSE IF (NV .EQ. 11) THEN
              CALL PLA294 (1)
              CALL PLA280 ('RESTART')
              GOTO 10
            ELSE IF (NV .EQ. 12) THEN
              CALL PLA280 ('CALC GEOM CSD')
            ELSE IF (NV .EQ. 13) THEN
            ELSE IF (NV .EQ. 14) THEN
            ELSE IF (NV .EQ. 15) THEN
              CALL PLA280 ('TABL ACC LOCAL')
            ENDIF
          ELSE IF (NH .EQ. 7) THEN
            IF (NV .EQ. 1) THEN
              CALL PLA280 ('SETUP PATT')
            ELSE IF (NV .EQ. 2) THEN
              CALL PLA280 ('FCF2HKL')
            ELSE IF (NV .EQ. 3) THEN
              CALL PLA280 ('EXP1')
            ELSE IF (NV .EQ. 4) THEN
              CALL PLA280 ('CALC FCF GENER')
            ELSE IF (NV .EQ. 5) THEN
              CALL PLA280 ('ASYM GENERATE')
            ELSE IF (NV .EQ. 6) THEN
              CALL PLA280 ('HKLTRANS')
            ELSE IF (NV .EQ. 7) THEN
              CALL PLA280 ('EXOR')
            ELSE IF (NV .EQ. 8) THEN
              IF (IABS(IGBL(8)) .EQ. 2) THEN
                IGBL(3) = 26
                CALL PLA280 ('PLUTON')
              ENDIF
            ELSE IF (NV .EQ. 9) THEN
              IF (IABS(IGBL(8)) .EQ. 2) THEN
                IGBL(3)   = 12
                IGBL(105) = 1
                CALL PLA280 ('PLUTON')
              ELSE
                CALL PLA015 (427, 40)
              ENDIF
            ELSE IF (NV .EQ. 10) THEN
              CALL PLA280 ('CALC PDB EXPAND')
            ELSE IF (NV .EQ. 11) THEN
              CALL PLA280 ('CALC EUCLID')
            ELSE IF (NV .EQ. 12) THEN
              CALL PLA280 ('CALC SHELX NOSF')
            ELSE IF (NV .EQ. 13) THEN
              CALL PLA280 ('TABL ACC')
            ELSE IF (NV .EQ. 14) THEN
              IGBL(3) = 27
              CALL PLA280 ('CALC GEOM RENUM SHELX')
            ELSE IF (NV .EQ. 15) THEN
              CALL PLA280 ('SYST')
            ENDIF
          ENDIF
          IF (IGGT(1:1) .EQ. ' ') GOTO 10
          LRET = 2
          GOTO 100
        ELSE IF (IPR(462) .EQ. 1) THEN
          NH = INT (6 * X / (GL(1) * GL(2)))
          NV = INT (43 * Y / GL(1)) + 1
          WRITE (IGGT, '(I6.6)')
     1       INT((IGBL(100) - 1) / 258) * 258 + NH * 43 + NV
        ENDIF
      ELSE IF (MMODE .EQ. 17) THEN
        IF (IGBL(28) .GT. 0) THEN
          NV =  NINT((Y - GL(1) + PAR(360) + PAR(361) / 2.0)
     1           / PAR(361))
          IF (NV .LE. 0) THEN
            CALL PLA280 ('PLOT')
          ELSE
            IF (IGBL(28) .EQ. 1) THEN
              IF (NV .LT. 10) THEN
                WRITE (IGGT, 99998) NV
              ELSE
                WRITE (IGGT, 99997) NV
              ENDIF
            ELSE IF (IGBL(28) .EQ. 2) THEN
              NV = - NV
              IF (NV .LT. 10) THEN
                WRITE (IGGT, 99997) NV
              ELSE
                WRITE (IGGT, 99996) NV
              ENDIF
            ENDIF
          ENDIF
        ELSE
          CALL PLA280 ('PLOT')
        ENDIF
      ELSE IF (MMODE .EQ. 18) THEN
        IF (IGBL(28) .EQ. 1) THEN
          NV = MIN (17, MAX (0, INT(Y - 1.5)))
          IF (NV .LT. 10) THEN
            WRITE (IGGT, 99998) NV
          ELSE
            WRITE (IGGT, 99997) NV
          ENDIF
        ELSE
          CALL PLA280 ('PLOT')
        ENDIF
      ENDIF
  100 RETURN
   10 LRET = -1
      RETURN
99999 FORMAT (6(A, 1X))
99998 FORMAT (I1)
99997 FORMAT (I2)
99996 FORMAT (I3)
      END
      SUBROUTINE PLA021
      PARAMETER (NP12=600,NP13=500,NP17=99,NP38=125,NP39=30)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /FNAME/ KNM(8), KXT, KNM16
      COMMON /NAMES/ NAME(8), EXTENS, PROGNM, FNLU1, FNLU16, RDTYPE
      CHARACTER NAME*80, EXTENS*9, PROGNM*28, FNLU1*80, FNLU16*80,
     1          RDTYPE*7
      CHARACTER FNLU2*80, FILEN*80
      LOGICAL OPEND
      MODE = IGBL(31)
C * FILE OPEN
      IF (MODE .EQ. IPR(437)) THEN
        WRITE (LU2, 99999)
      ELSE
        IPR(437) = MODE
        IF (MODE .LT. 0) THEN
          IF (MODE .EQ. -1) THEN
            FNLU2 = NAME(4)(1:KNM(4))//'.res'
          ELSE
            FNLU2 = NAME(7)(1:KNM(7))//'.res'
          ENDIF
          OPEN (UNIT = LU2, FILE = FNLU2, STATUS = 'UNKNOWN')
        ELSE IF (MODE .EQ. 3) THEN
          FNLU2   = NAME(3)(1:KNM(3))//'.eld'
          IGBL(2) = IGBL(2) + 1
          INQUIRE (LU2, OPENED = OPEND)
C * WORK-AROUND FOR SALFORD-COMPILER
          FILEN = ' '
          INQUIRE (UNIT = LU2, NAME = FILEN)
          IF (OPEND .AND. FILEN(1:1) .NE. ' ') THEN
            WRITE (LU2, 99999)
          ELSE
            OPEN (LU2, FILE = FNLU2, STATUS = 'UNKNOWN')
          ENDIF
        ELSE IF (MODE .EQ. 1) THEN
          FNLU2 = NAME(5)(1:KNM(5))//'.ome'
          OPEN (LU2, FILE = FNLU2, STATUS = 'UNKNOWN')
          IPR(438) = 1
        ELSE IF (MODE .EQ. 2) THEN
          FNLU2  = NAME(2)(1:KNM(2))//'.dge'
          OPEN(UNIT = LU2,  FILE = FNLU2,  STATUS='UNKNOWN')
        ELSE IF (MODE .EQ. 4) THEN
          FNLU2 = NAME(6)(1:KNM(6))//'.que'
          OPEN (LU2, FILE = FNLU2, STATUS = 'UNKNOWN')
        ELSE IF (MODE .EQ. 5) THEN
          FNLU2 = NAME(8)(1:KNM(8))//'.par'
          OPEN (LU2, FILE = FNLU2, STATUS = 'UNKNOWN')
        ELSE IF (MODE .EQ. 6) THEN
          FNLU2 = NAME(7)(1:KNM(7))//'.res'
          OPEN (LU2, FILE = FNLU2, STATUS = 'UNKNOWN')
        ELSE IF (MODE .EQ. 7) THEN
          FNLU2 = NAME(3)(1:KNM(3))//'.pdb'
          OPEN (LU2, FILE = FNLU2, STATUS = 'UNKNOWN')
        ELSE IF (MODE .EQ. 8) THEN
          FNLU2 = NAME(1)(1:KNM(1))//'.acc'
          IPR(438) = 1
          OPEN (LU2, FILE = FNLU2, STATUS = 'UNKNOWN')
        ELSE IF (MODE .EQ. 9) THEN
          FNLU2 = NAME(1)(1:KNM(1))//'.csd'
          IPR(438) = 1
          OPEN (LU2, FILE = FNLU2, STATUS = 'UNKNOWN')
        ELSE IF (MODE .EQ. 10) THEN
          FNLU2 = NAME(1)(1:KNM(1))//'.sqz'
          OPEN (LU2, FILE = FNLU2, STATUS = 'UNKNOWN')
        ENDIF
        IF (IGBL(2) .LE. 1) CALL GEN108 (LU2, 0)
      ENDIF
      RETURN
99999 FORMAT ('ENDS')
      END
      SUBROUTINE PLA022
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118,
     1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP20=20,
     2 NP22=256,NP25=99,NP29=63,NP38=125,NP39=30,NP41=200,NP45=2048,
     3 NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /Q/ ICL, IFL(NP17)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9),
     1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10),
     2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10),
     3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770)
      DIMENSION DHX(3, 37)
      COMMON /LATICE/ TRNSX(3, 3, 128), ROT(3, 5, 5), TRDAT(3, 3, 8)
      COMMON /PLA22/ LGR(12), XSYST(8), IBVL(8), LAT(7)
      CHARACTER LGR*5, XSYST*12, IBVL*1, LAT*1
      DIMENSION RH(3, 3, NP20), HH(4, NP20), AANG(NP20), PH(3, NP20),
     1 PERPAX(NP20), HX(4, 37), SHRT(4, 4), ROW(3), IROW0(3),
     2 TTRANS(3, 3), TTRM1(3, 3), BTRANS(3, 3), BTRM1(3, 3), DEL(3),
     3 TRANSL(3), RATOM(3), ATOM2(3, 2), ROTAX(3, 4), GLIDE(3),
     4 ORIG(3), IROW(3), GLITOT(2), GLIDO(3, 2), XMIS(3, 3, 15),
     5 XMIS4(3, 15), XMIS5(3, 15), NMIS(15), TR1(3, 3), ORGM(3)
      DIMENSION IMPROP(64)
      CHARACTER LATT*1, CENT*1, STAR*2, TEXT1*1, TEXT2*7, FSYM*2
      COMMON /TIMER/ TIMT, TIMEZ, TIMEA, ISAVEMOD
      COMMON /CGGT/ IGGT
      CHARACTER IGGT*80
      COMMON /CGG11/ BCD, SBCD
      CHARACTER BCD*132, SBCD*132
      COMMON /PAGENM/ PAGET, PAGEIND(25)
      CHARACTER PAGET*8, PAGEIND*8
      COMMON /CTRNS/ TRTYP
      CHARACTER TRTYP(8)*5
      DIMENSION DUMMY(3, 3)
      COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0
      DIMENSION GLY(3), NA(3)
      CHARACTER XSUB*1, ZSPG0*7
      NSYMT = IPR(48)
      OPEN (LU61, FILE = 'symmscr', STATUS = 'UNKNOWN')
      DO 5 I = 1, NSYMT
        ISYM = I
        CALL SGSM (ICL, ISYM, XJX, 0, 2, IERR)
        WRITE (LU61, 99922) ICL(1:50)
    5 CONTINUE
      WRITE (LU61, 99921)
      LOOPR = 0
      LU    = 0
C * ADDSYM TEST SUBROUTINE -- NOTE: SUBROUTINE SCRATCHES ARRAY CON( )
      IF (IPR(23) .EQ. 1 .OR. IPR(241) .EQ. 0) GOTO 1160
      PAGET    = 'ADDSYM'
   10 LOOPR    = LOOPR + 1
      JERR     = 0
      IPR(206) = 0
      IF (IGBL(3) .EQ. 1) THEN
        IPR(207) = 0
      ELSE
        IPR(207) = 1
      ENDIF
      IPR(504) = 0
      INVST    = 0
      IN1      = 0
      NORGM    = 0
      NCHIR    = 0
      IPR(595) = 0
      DO 20 I = 1, 3
        PAR(406 + I) = PAR(403 + I - IGBL(97) * 3)
   20 CONTINUE
      IF (IPR(220) .GT. 2) THEN
        DO 30 I = 3, IPR(220)
          IF (IFL(I)(1:2) .EQ. 'EQ') THEN
            IPR(207) = 0
          ELSE IF (IFL(I)(1:2) .EQ. 'PL') THEN
            IPR(504) = 1
          ELSE IF (IFL(I)(1:2) .EQ. 'SH') THEN
            IPR(504) = 2
          ELSE IF (IFL(I)(1:2) .EQ. 'EX') THEN
            PAR(249) = 0.00
            IF (IPR(221) .EQ. 0) THEN
              FN(1)   = 0.30
              IF (LOOPR .LT. 3) THEN
                FN(2) = 0.25
                FN(3) = 0.25
                FN(4) = 0.25
              ELSE
                FN(2) = 0.1
                FN(3) = 0.1
                FN(4) = 0.1
              ENDIF
            ENDIF
          ELSE IF (IFL(I)(1:4) .EQ. 'NOSF') THEN
            IPR(595) = 1
          ELSE IF (IFL(I)(1:3) .EQ. 'ELD') THEN
            IGBL(65) = 1
          ELSE
            CALL PLA037 (I, N, 2)
            IF (N .GT. 0) IPR(206) = N
          ENDIF
   30   CONTINUE
      ENDIF
      IF (FN(1) .GT. 0.0) PAR(43)  = FN(1)
      IF (FN(2) .GT. 0.0) PAR(407) = FN(2)
      IF (FN(3) .GT. 0.0) PAR(408) = FN(3)
      IF (FN(4) .GT. 0.0) PAR(409) = FN(4)
      IWIN  = 0
      IF (IGBL(25) * IGBL(32) .EQ. 1 .AND. IPR(504) .EQ. 0 .AND.
     1    IPR(121) .EQ. 0) IWIN = 1
      IF (IGBL(3) .EQ. 1) IPR(503) = 1
      IGBL(23) = 26
      IPR(209) = 0
      N = 0
      CALL GEN101 (2, N, DHX)
      XSUB  = CHAR(32)
      NLCP  = 1
      NLCLP = 0
      NLTX  = 1
   40 NLCLP = NLCLP + 1
      IF (IWIN .EQ. 1) THEN
        CALL GGIP (HORS, VERT, 0.0, 1)
        VRT = VERT - 0.5
        WRITE (PRBUF, 99940) JID(1:20)
        CALL GGIP20 (0.0, PRBUF, 80, 0.35, 5 + IGBL(68), 2, 1.0, VRT)
      ENDIF
      CALL PLA087 (NLTX)
      NRXX  = 0
      NSGTR = 0
      NEWLT = 0
      IF (IPR(100) .GT. 0) WRITE (LU6, 99960)
      IF (IGBL(63) .GT. 2) THEN
        CALL PLA269 (-2)
        WRITE (LU7, 99999)
      ENDIF
      IF (IPR(206) .EQ. 0) THEN
        IF (IPR(207) .NE. 0) THEN
          WRITE (PRBUF, 99993) NINT(PAR(249))
        ELSE
          WRITE (PRBUF, 99992) NINT(PAR(249))
        ENDIF
      ELSE
        CALL GEN020 (-1, NQ3, 2, 2)
        WRITE (PRBUF, 99994) NQ3, NINT(PAR(249))
      ENDIF
      WRITE (LU6, 99979)
      WRITE (LU6, 99990) PRBUF
      IF (IPR(206) .EQ. 0 .AND. IPR(207) .NE. 0) WRITE (LU6, 99983)
      IF (IGBL(63) .GT. 2) THEN
        CALL PLA269 (2)
        WRITE (LU7, 99990) PRBUF
      ENDIF
      IF (IWIN .EQ. 1) THEN
        VRT = VRT - 0.5
        CALL GGIP20 (0.0, PRBUF, 80, 0.35, 3, 2, 1.0, VRT)
      ENDIF
      NEWS  = 0
      IBV   = IPR(256)
      NSYM  = NSYMT / IBV
      DO 50 I = 1, NSYM
        CALL SGSM (ICL, I, XJX, LU6, 6, IERR)
        IMPROP(I) = NINT(GEN119(XJX))
   50 CONTINUE
      NATOMS = 0
      NSKIP  = 0
      NINC   = 0
      DO 110 I = 1, IPR(37)
        CALL GEN048 (-2, IFG(I), 28, JCAI)
        IF (JCAI .GT. 0) THEN
          JR(I)    = JCAI - 2
          NCHIR    = NCHIR + 1
        ELSE
          JR(I) = 0
        ENDIF
        CALL GEN048 (-4, IFG(I), 15, NO1)
        IF (IEN(NO1 + 1) .NE. 1) THEN
          CALL GEN048 (-7, JFG(I), 1, IDSO)
          IF (IPPR(IDSO + 1, 1) .EQ. 1000) THEN
            IF (IPR(206) .NE. 0 .AND. NO1 + 1 .NE. IPR(206)) GOTO 110
            DO 60 L = 1, 3
              XJX(L)     = XXO(I, L)
              XJX(L + 3) = 0.0
   60       CONTINUE
            NINC = NINC + 1
            CALL GEN048 (-1, IFG(I), 19, IMET)
            IF (NLCLP .EQ. 1) THEN
              NATOMB = NATOMS
            ELSE
              NATOMB = 0
            ENDIF
            DO 100 J = 1, NSYM
              CALL SGSM (ICL, J, XJX, LU6, 3, IERR)
              CALL GEN002 (1, TRNSM1, XJX(7), V2, XLNG)
              DO 70 K = 1, 3
                CON(NATOMS + 1, K) = MOD (V2(K) + 10.0, 1.0)
   70         CONTINUE
              IF (NATOMS .GT. NATOMB) THEN
                DO 90 L = NATOMB + 1, NATOMS
                  DO 80 M = 1, 3
                    XDUM = MOD (CON(NATOMS + 1, M) - CON(L, M), 1.0)
                    IF (ABS(ABS(XDUM) - 0.5) .LT. 0.49) GOTO 90
   80             CONTINUE
                  GOTO 100
   90           CONTINUE
              ENDIF
              IF (NATOMS .LT. NP1) THEN
                NATOMS         = NATOMS + 1
                CON(NATOMS, 8) = XLAB(I)
                JCA(NATOMS)    = IMET
                IFNT(NATOMS)   = JR(I) * IMPROP(J)
                CON(NATOMS, 4) = (IEN(NO1 + 1) - 1) * IPR(207) + 1
              ELSE
                WRITE (LU6, 99969) NP1
                GOTO 1160
              ENDIF
  100       CONTINUE
          ELSE
            NSKIP = NSKIP + 1
            IF (NSKIP .EQ. 1) THEN
              IF (IGBL(63) .GT. 0) THEN
                CALL PLA269 (2)
                WRITE (LU7, 99962)
              ENDIF
            ENDIF
            CALL PLA047 (XLAB(I), NQ1, IDUM, JDUM, 0, IGBL(55), 0, 0)
            IF (IGBL(63) .GT. 0) THEN
              IF (MOD (NSKIP, 8) .NE. 0) THEN
                WRITE (LU7, '(3X, A, $)') NQ1
              ELSE
                WRITE (LU7, 99925) NQ1
                CALL PLA269 (1)
              ENDIF
            ENDIF
          ENDIF
        ENDIF
  110 CONTINUE
      NCHIRF = NCHIR
      IF (NATOMS .EQ. 0) THEN
        WRITE (LU6, 99968)
      ELSE
        IF (NSKIP .GT. 0) THEN
          WRITE (LU6, 99975) NSKIP
          IF (IGBL(63) .GT. 0) THEN
            CALL PLA269 (1)
            WRITE (LU7, 99975) NSKIP
          ENDIF
        ENDIF
        IF (PAR(386) .NE. 0.0) THEN
          YUNK = PAR(98) / PAR(386)
        ELSE
          YUNK = 0.0
        ENDIF
        WRITE (PRBUF, 99936) PAR(387), YUNK
        WRITE (LU6, 99997) NINC, NATOMS
        WRITE (LU6, 99990) PRBUF(1:80)
        IF (IGBL(63) .GT. 0) THEN
          CALL PLA269 (2)
          WRITE (LU7, 99997) NINC, NATOMS
          WRITE (LU7, 99990) PRBUF(1:80)
        ENDIF
        IF (IWIN .EQ. 1) THEN
          IF (PAR(387) .LT. 1.0) THEN
            VRT = VRT - 0.5
            CALL GGIP20 (0.0, PRBUF, 80, 0.35, 2, 2, 1.0, VRT)
          ENDIF
        ENDIF
        NSV      = 0
        N2       = 0
        IMETRIC  = 0
        IPR(118) = 0
        IPR(459) = 0
        NROT     = 0
        NNFIT    = 100
        NNNFIT   = 100
        NFT      = 100
        ANGMAX  = SIN(PAR(43) / GL(5))**2
        DO 120 I = 1, 37
          CALL GEN002 (2, ADIR, DHX(1, I), HX(1, I), HX(4, I))
  120   CONTINUE
        DO 150 I = 1, 37
          CALL GEN002 (-2, AINV, DHX(1, I), V1, XLNG)
          DO 140 J = 1, 37
            MULT = NINT (ABS (GEN009 (DHX(1, I), DHX(1, J))))
            IF (MULT .EQ. 1 .OR. MULT .EQ. 2) THEN
              CALL GEN008 (V1, HX(1, J), V5, -1)
              IF (V5(1) .LT. ANGMAX) THEN
                IF (N2 .GE. NP20) THEN
                  IPR(2) = 23
                  GOTO 1160
                ENDIF
                N2 = N2 + 1
                DO 130 K = 1, 3
                  PH(K, N2)    = DHX(K, I)
                  HH(K, N2)    = HX (K, J)
                  RH(K, 3, N2) = DHX(K, J)
  130           CONTINUE
                AANG(N2)   = ASIN(SQRT(V5(1))) * GL(5)
                PERPAX(N2) = 2.0
                HH(4, N2)  = HX(4, J)
              ENDIF
            ENDIF
  140     CONTINUE
  150   CONTINUE
        N3 = N2
        IF (N2 .GT. 0) THEN
          IF (N2 .GT. 2) THEN
            DO 220 I = 1, N2 - 2
              DO 210 J = I + 1, N2 - 1
                NMX   = 2
                CALL GEN008 (HH(1, I), HH(1, J), V6 , 0)
                DO 160 K = J + 1, N2
                  IF (ABS(GEN009 (V6, HH(1, K))) .LE. 0.01)
     1                NMX = NMX + 1
  160           CONTINUE
                DO 170 K = 1, N2
                  IF (ABS(GEN009(PH(1, K), RH(1, 3, I))) .LE. 0.01)
     1              THEN
                    IF (ABS(GEN009(PH(1, K), RH(1, 3, J))) .LE. 0.01)
     1                THEN
                      IF (NMX .GT. PERPAX(K)) PERPAX(K) = NMX
                      GOTO 210
                    ENDIF
                  ENDIF
  170           CONTINUE
                IF (NMX .GT. 2) THEN
                  CALL GEN002 ( 2, AINV, V6, V4, XLEN)
                  CALL GEN002 (-2, ADIR, V6, V3, XLNG)
                  SMR = 2.0
                  SMD = 2.0
                  DO 180 K = 1, 3
                    IF (ABS(V3(K)) .GT. 0.1 .AND. ABS(V3(K)) .LT. SMR)
     1                      SMR = ABS(V3(K))
                    IF (ABS(V4(K)) .GT. 0.1 .AND. ABS(V4(K)) .LT. SMD)
     1                      SMD = ABS(V4(K))
  180             CONTINUE
                  DO 190 K = 1, 3
                    V3(K) = NINT(V3(K) / SMR)
                    V4(K) = NINT(V4(K) / SMD)
  190             CONTINUE
                  CALL GEN002 (-2, AINV, V3, V1, XLNG)
                  CALL GEN002 ( 2, ADIR, V4, V2, XLEN)
                  CALL GEN008 (V1, V2, V5, -1)
                  IF (V5(1) .LT. ANGMAX) THEN
                    N3 = N3 + 1
                    DO 200 K = 1, 3
                      PH(K, N3)    = V3(K)
                      RH(K, 3, N3) = V4(K)
                      HH(K, N3)    = V2(K)
  200               CONTINUE
                    AANG(N3)   = ASIN(SQRT(V5(1))) * GL(5)
                    PERPAX(N3) = NMX
                    HH(4, N3)  = XLEN
                  ENDIF
                ENDIF
  210         CONTINUE
  220       CONTINUE
            DO 250 I = 1, N3 - 1
              AIMAX = PERPAX(I) - AANG(I)
              KMAX  = I
              DO 230 J = I + 1, N3
                AJMAX = PERPAX(J) - AANG(J)
                IF (AJMAX .GT. AIMAX) THEN
                  AIMAX = AJMAX
                  KMAX  = J
                ENDIF
  230         CONTINUE
              CALL GEN018 (PERPAX(I), PERPAX(KMAX))
              DO 240 K = 1, 3
                CALL GEN018 (RH(K, 3, I), RH(K, 3, KMAX))
                CALL GEN018 (PH(K, I),    PH(K, KMAX))
                CALL GEN018 (HH(K, I),    HH(K, KMAX))
  240         CONTINUE
              CALL GEN018 (AANG(I), AANG(KMAX))
              CALL GEN018 (HH(4, I), HH(4, KMAX))
  250       CONTINUE
          ENDIF
          DO 380 IT = 1, N3
            J = 0
            DO 280 I = 1, 37
              IF (ABS(GEN009 (DHX(1, I), PH(1, IT))) .LT. 0.01) THEN
                J = J + 1
                DO 270 K = 1, 3
                  SHRT(K, J) = DHX(K, I)
  270           CONTINUE
                IF (J .EQ. 2) GOTO 290
              ENDIF
  280       CONTINUE
  290       DO 300 I = 1, 3
              SHRT (I, 3) = SHRT (I, 1) + SHRT (I, 2)
              SHRT (I, 4) = SHRT (I, 1) - SHRT (I, 2)
  300       CONTINUE
            DO 310 I = 1, 4
              CALL GEN002 (2, ADIR, SHRT(1, I), V5, SHRT(4, I))
  310       CONTINUE
            ISWTCH = 0
            DO 340 I = 1, 2
              DO 330 J = 2, 4
                IF (SHRT(4, J) .LT. SHRT(4, I)) THEN
                  DO 320 K = 1, 4
                    CALL GEN018 (SHRT(K, I), SHRT(K, J))
  320             CONTINUE
                  ISWTCH = 1
                ENDIF
  330         CONTINUE
  340       CONTINUE
            IF (ISWTCH .EQ. 1) GOTO 290
            CALL GEN002 (2, ADIR, SHRT(1, 1), SHRT(1, 3), XLEN)
            CALL GEN002 (2, ADIR, SHRT(1, 2), SHRT(1, 4), XLEN)
            IF (GEN009 (SHRT(1, 3), SHRT(1, 4)) .GT. 0.000001) THEN
              DO 350 NX = 1, 3
                SHRT(NX, 2) = - SHRT(NX, 2)
  350         CONTINUE
            ENDIF
            SGN0 = SIGN (1.0, GEN009 (RH(1, 3, IT), PH(1, IT)))
            CALL GEN008 (SHRT(1, 1), SHRT(1, 2), V3, 0)
            SGN = SIGN(1.0, GEN009 (V3, RH(1, 3, IT)))
            DO 370 NX = 1, 3
              RH(NX, 3, IT) = SGN * RH(NX, 3, IT)
              PH(NX, IT)    = SGN * PH(NX, IT) * SGN0
              DO 360 NY = 1, 2
                RH(NX, NY, IT) = SGN * SHRT(NX, NY)
  360         CONTINUE
  370       CONTINUE
  380     CONTINUE
        ENDIF
        CALL GEN021 (RH(1, 1, N3 + 1), 1)
        PH(1, N3 + 1) = 0.0
        PH(2, N3 + 1) = 0.0
        PH(3, N3 + 1) = 1.0
        DSCENT   = 999.0
        DLIM     = PAR(407)
        PAR(291) = 0.0
        WRITE (PRBUF, 99989)
        IF (IGBL(63) .GT. 2) THEN
          CALL PLA269 (6)
          WRITE (LU7, 99990) PRBUF(1:78)
          WRITE (LU7, 99955) PAR(43), PAR(407), PAR(408), PAR(409)
          WRITE (LU7, 99979)
          WRITE (LU7, 99953)
          WRITE (LU7, 99952)
          WRITE (LU7, 99951)
        ENDIF
        WRITE (LU6, 99990) PRBUF(1:78)
        WRITE (LU6, 99955) PAR(43), PAR(407), PAR(408), PAR(409)
        WRITE (LU6, 99979)
        WRITE (LU6, 99953)
        WRITE (LU6, 99952)
        WRITE (LU6, 99951)
        IF (IWIN .EQ. 1) THEN
          WRITE (PRBUF, 99955) PAR(43), PAR(407), PAR(408), PAR(409)
          VRT = VRT - 0.5
          CALL GGIP20 (0.0, PRBUF, 80, 0.35, 3, 2, 1.0, VRT)
          WRITE (PRBUF, 99953)
          VRT = VRT - 0.5
          CALL GGIP20 (0.0, PRBUF, 80, 0.35, 5 + IGBL(68), 2, 1.0, VRT)
          WRITE (PRBUF, 99952)
          VRT = VRT - 0.5
          CALL GGIP20 (0.0, PRBUF, 80, 0.35, 5 + IGBL(68), 2, 1.0, VRT)
          CALL GGIP (0.0, 1.0, 0.0, 0)
          CALL GGIP (0.0,  VRT - 0.2, 0.0, 3)
          CALL GGIP (HORS, VRT - 0.2, 0.0, 2)
          VRT = VRT - 0.3
          CALL GGIP (0.0, 0.0, 0.0, 6)
        ENDIF
        DO 850  ISYM = 1, N3 + 1
          DO 400 I = 1, 3
            DO 390 J = 1, 3
              BTRANS(I, J) = RH(I, J, ISYM)
  390       CONTINUE
            IROW0(I) = NINT (RH(I, 3, ISYM))
  400     CONTINUE
          CALL GEN003 (BTRANS, BTRM1, DET, 0)
          IRCTR = 0
          DO 410 I = 1, 3
            IF (ABS (ABS (BTRM1(3, I)) - 0.5) .LT. 0.48) IRCTR = I
  410     CONTINUE
          DO 440 I = 1, NATOMS
            DO 420 J = 1, 3
              V1(J) = CON(I, J)
  420       CONTINUE
            CALL GEN002 (1, BTRM1, V1, V2, XLNG)
            DO 430 J = 1, 3
              CON(I, J + 4) = V2(J)
  430       CONTINUE
  440     CONTINUE
          IF (ISYM .LE. N3) THEN
            IPERP = NINT (PERPAX(ISYM))
            ANG   = AANG(ISYM)
            MULT  = NINT (GEN009 (RH(1, 3, ISYM), PH(1, ISYM)))
            DLE   = HH(4, ISYM)
            IF (IPERP .GE. 6) THEN
              ITYPB = 1
              ITYPE = 4
            ELSE IF (IPERP .EQ. 3) THEN
              ITYPB = 2
              ITYPE = 2
            ELSE IF (IPERP .GE. 4) THEN
              ITYPB = 3
              ITYPE = 4
            ELSE
              ITYPB = 4
              ITYPE = 4
            ENDIF
          ELSE
            ITYPB = 5
            ITYPE = 5
            INVST = 0
          ENDIF
          DO 840 ITYP = ITYPB, ITYPE
            IF (ITYP .EQ. 1) THEN
              NROT = 6
            ELSE IF (ITYP .EQ. 2) THEN
              NROT = 3
            ELSE IF (ITYP .EQ. 3) THEN
              NROT = 4
            ELSE IF (ITYP .EQ. 4) THEN
              NROT = 2
            ENDIF
            DO 830 NTYP = 1, 2
              ITRY  = ITYP * (-1) ** NTYP
              JROT  = 6 - NTYP
              DSMAX = -1.0
              NCHR  = 0
              IF (ITRY .EQ. 5) THEN
                DLIM = PAR(408)
              ELSE IF (ITRY .EQ. -5) THEN
                DLIM = PAR(409)
              ENDIF
              DO 460 I = 1, 3
                ROTAX(I, 4) = 0.0
                TRANSL(I) = ROT(I, JROT, ITYP)
                DO 450 J = 1, 3
                  TEMP = ROT(I, J, ITYP)
                  IF (ITRY .LT. 0) TEMP = - TEMP
                  ROTAX(I, J) = TEMP
                  IF (I .EQ. J) TEMP = TEMP - 1.0
                  ROTM1(I, J) = TEMP
  450           CONTINUE
  460         CONTINUE
              DO 480 I = 1, 3
                V6(I) = 1.0
                DO 470 J = 1, 3
                  IF (ROTM1(I, J) .NE. 0.0) GOTO 480
                  IF (ROTM1(J, I) .NE. 0.0) GOTO 480
  470           CONTINUE
                V6(I)       = 0.0
                ROTM1(I, I) = 1.0
  480         CONTINUE
              CALL GEN003 (ROTM1, ROTM2, DET, 0)
              DO 490 I = 1, 3
                ROTM2(I, I) = ROTM2(I, I) * V6(I)
  490         CONTINUE
              IAT1  = 1
              CATM1 = CON(IAT1, 4)
              IFNT1 = IFNT(IAT1)
              DO 510 I = 1, 3
                RATOM(I) = 0.0
                DO 500 J = 1, 3
                  RATOM(I) = RATOM(I) + ROTAX(I, J) * CON(IAT1, J + 4)
  500           CONTINUE
  510         CONTINUE
              DO 820 IAT2 = 1, NATOMS
                IFNT2 = IFNT(IAT2)
                IF (NTYP .EQ. 1 .OR. ITRY .EQ. 5) THEN
                  IF ((IFNT1 + IFNT2) .NE. 0) GOTO 820
                ELSE IF (NTYP .EQ. 2 .OR. ITRY .EQ. -5) THEN
                  IF ((IFNT1 - IFNT2) .NE. 0) GOTO 820
                ENDIF
                NCHR  = IABS(IFNT1)
                DSMAX = -1.0
                IF (NINT(CON(IAT2, 4)) .EQ. NINT(CATM1)) THEN
                  DO 520 II = 1, 3
                    ATOM2(II, 1) = CON(IAT2, II + 4)
  520             CONTINUE
                  IF (IRCTR .NE. 0) THEN
                    JM = 2
                    DO 530 I = 1, 3
                      ATOM2(I, 2) = ATOM2(I, 1) + BTRM1(I, IRCTR)
  530               CONTINUE
                  ELSE
                    JM = 1
                  ENDIF
                  DO 550 J = 1, JM
                    GLITOT(J) = 0.0
                    DO 540 I = 1, 3
                      GLIDO(I, J) = 0.0
                      IF (TRANSL(I) .GE. 0.1 .OR. ITRY .EQ. -5) THEN
                        GLIDO(I, J) = ATOM2(I, J) - CON(IAT1, I + 4)
                        GLITOT(J)   = GLITOT(J)   + GLIDO(I, J)**2
                        GLITOT(J)   = GLITOT(J) - INT(GLITOT(J) + 0.1)
                        IF (ITRY .NE. - 5) THEN
                          XDUM = MOD (12.0 * GLIDO(I, J) /
     1                                       TRANSL(I) + 10.0, 1.0)
                          IF (ABS (XDUM - 0.5) .LE. 0.45) GOTO 820
                        ENDIF
                      ENDIF
  540               CONTINUE
  550             CONTINUE
                  JG = 1
                  IF (IRCTR .NE. 0) THEN
                    IF (ABS (GLITOT(2)) .LT. ABS(GLITOT(1))) JG = 2
                  ENDIF
                  DO 560 I = 1, 3
                    ROTAX(I, 4) = GLIDO(I, JG) * 12.0
                    V1(I) = RATOM(I) - ATOM2(I, JG) + GLIDO(I, JG)
  560             CONTINUE
                  CALL GEN002 (1, ROTM2, V1, ORIG, XLNG)
                  P249  = PAR(249)
                  NLOOP = 0
  570             NFIT  = 0
                  NNFIT = 100
                  DO 580 I = 1, NATOMS
                    CON(I, 9) = 0.0
  580             CONTINUE
                  CON(IAT1, 9) = 2.0
                  CON(IAT2, 9) = 2.0
                  DO 640 IAT3 = 2, NATOMS
                    IFNT3 = IFNT(IAT3)
                    DO 590 K = 1, 3
                      V1(K) = CON(IAT3, K + 4) - ORIG(K)
  590               CONTINUE
                    DO 610 K = 1, 3
                      V2(K) = ROTAX(K, 4) / 12.0 + ORIG(K)
                      DO 600 J = 1, 3
                        V2(K) = V2(K) + ROTAX(K, J) * V1(J)
  600                 CONTINUE
  610               CONTINUE
                    CALL GEN002 (1, BTRANS, V2, V3, XLNG)
                    IIAT3 = NINT(CON(IAT3, 4))
                    DO 630 IAT4 = 1, NATOMS
                      IFNT4 = IFNT(IAT4)
                      IF (NTYP .EQ. 1 .OR. ITRY .EQ. 5) THEN
                        IF ((IFNT3 + IFNT4) .NE. 0) GOTO 630
                      ELSE IF (NTYP .EQ. 2 .OR. ITRY .EQ. -5) THEN
                        IF ((IFNT3 - IFNT4) .NE. 0) GOTO 630
                      ENDIF
                      IF (NINT(CON(IAT4, 4)) .EQ. IIAT3)
     1                  THEN
                        IF (ITRY .NE. -5 .OR. IAT3 .NE. IAT4) THEN
                          DO 620 K = 1, 3
                            DELTA = MOD (V3(K) - CON(IAT4, K), 1.0)
                            IF (ABS (DELTA) .GT. 0.5)
     1                        DELTA = DELTA - SIGN (1.0, DELTA)
                            IF (ABS (DELTA) .GT. 0.2) GOTO 630
                            DEL(K) = DELTA
  620                     CONTINUE
                          CALL GEN002 (2, ADIR, DEL, V4, DIS)
                          DIS = DIS / 2
                          IF (DIS .LE. DLIM) THEN
                            IF (DIS .GT. DSMAX) THEN
                              DSMAX = DIS
                              CALL PLA047 (CON(IAT3, 8), NQ3, IDUM,
     1                                     JDUM, 0, IGBL(55), 0, 0)
                              CALL PLA047 (CON(IAT4, 8), NQ4, IDUM,
     1                                     JDUM, 0, IGBL(55), 0, 0)
                              NQ3(6 : 6) = '-'
                            ENDIF
                            CON(IAT3, 9) = CON(IAT3, 9) + 1
                            NCHR = NCHR + IABS(IFNT3)
                            GOTO 640
                          ENDIF
                        ENDIF
                      ENDIF
  630               CONTINUE
                    NFIT = NFIT + 1
                    IF (NFIT * 100.0 / NATOMS .GT. P249) GOTO 820
  640             CONTINUE
                  IF (ITRY .EQ. 5) THEN
                    IF (IPR(257) .EQ. 1) THEN
                      IF (NFIT .NE. 0) IPR(118) = 1
                    ENDIF
                  ENDIF
                  NQ1  = ' '
                  NFTX = 0
                  CALL GEN038 (LINE, 1, 80)
                  DO 650 N = 1, NATOMS
                    IF (NINT (CON(N, 9)) .LT. 1) THEN
                      CALL PLA047 (CON(N, 8), NQ2, IDUM, JDUM, 0,
     1                             IGBL(55), 0, 0)
                      IF (NQ2 .NE. NQ1) THEN
                        NQ1 = NQ2
                        IF (JCA(N) .EQ. 1 .AND. ITRY .EQ. 5) THEN
                          IF (NFTX .NE. 0) THEN
                            WRITE (LU6, 99979)
                            IF (IGBL(63) .GT. 0) THEN
                              CALL PLA269 (1)
                              WRITE (LU7, 99979)
                            ENDIF
                          ENDIF
                          GOTO 820
                        ENDIF
                        NFTX = NFTX + 1
                        IF (NFTX .LT. 12) THEN
                          LINE((NFTX - 1) * 5 + 1:) = NQ1
                        ENDIF
                      ENDIF
                    ENDIF
  650             CONTINUE
                  FIT = NFTX * 100.0 / NINC
                  IF (FIT .GT. P249) GOTO 820
                  IF (NFTX .EQ. 0) THEN
                    NNFIT = 100
                  ELSE
                    NNFIT = INT(100.0 - FIT)
                  ENDIF
                  CALL GEN004 (TRNS,   BTRANS, TTRANS)
                  CALL GEN003 (TTRANS, TTRM1,  DET, 0)
                  CALL GEN004 (ROTAX , TTRM1,  DUMV)
                  CALL GEN004 (TTRANS, DUMV,   ROTM1)
                  ISTR = 1
                  STAR = ' *'
                  IF (ITRY .NE. -5) THEN
                    DO 680 I0 = 1, NSYM
                      CALL SGSM (ICL, I0, XJX, LU6, 6, IERR)
                      ITEL = 0
                      DO 670 IR = 1, 3
                        DO 660 IL = 1, 3
                          ITEL = ITEL + 1
                          IF (ABS (ROTM1(IR, IL) - XJX(ITEL))
     1                        .GT. 0.01) GOTO 680
  660                   CONTINUE
  670                 CONTINUE
                      ISTR = 0
                      STAR = '  '
                      IF (NFIT .GT. 0 .AND. NLCLP .EQ. 1) THEN
                        P249  = 0.0
                        NLOOP = NLOOP + 1
                        IF (NLOOP .LT. 10) GOTO 570
                      ENDIF
                      GOTO 690
  680               CONTINUE
                    IPR(209) = 1
                  ENDIF
  690             FSYM  = ' '
                  TEXT1 = ' '
                  NRT   = NROT
                  IF (ITRY .GT. 0 .AND. ITYP .NE. 4) THEN
                    FSYM(1 : 1) = '-'
                    IF (NRT .EQ. 4) NRT = 5
                  ENDIF
                  FSYM(2 : 2) = CHAR(ICHAR('0') + NROT)
                  IF (ITRY .EQ. -4) THEN
                    FSYM(2 : 2) = 'm'
                    NRT         = 0
                  ENDIF
                  IGLIDE = 0
                  DO 700 I0 = 1, 3
                    ORI = MOD (ORIG(I0), 1.0)
                    IF (ORI .LT. -0.45) ORI = ORI + 1.0
                    IF (ORI .GT.   0.6) ORI = ORI - 1.0
                    ORIG(I0) = ORI
                    GLI     = MOD (GLIDO(I0, JG), 1.0)
                    IF (GLI .LT. -0.45) GLI = GLI + 1.0
                    IF (GLI .GT.  0.6)  GLI = GLI - 1.0
                    GLIDE(I0) = GLI
                    IF (ABS(GLI) .GE. 0.05) IGLIDE = 1
  700             CONTINUE
                  CALL GEN002 (1, BTRANS, GLIDE,        V1, XLNG)
                  CALL GEN002 (1, TRNS ,  V1,        GLIDE, XLNG)
                  CALL GEN002 (1, TRNS ,  V1,          GLY, XLNG)
                  CALL GEN002 (1, BTRANS, ORIG ,        V1, XLNG)
                  CALL GEN002 (1, TRNS ,  V1 ,        ORIG, XLNG)
                  CALL GEN002 (1, TRNS ,  RH(1, 3, ISYM), ROW, XLNG)
                  DO 710 I0 = 1, 3
                    IF (ISYM .GT. N3) THEN
                      ORIG(I0) = MOD (1.0 + ORIG(I0), 0.5)
                    ELSE
                      IF (ORIG(I0) .LT. - 0.1) ORIG(I0) = ORIG(I0) + 1.0
                    ENDIF
  710             CONTINUE
                  IF (DSMAX .LT. 0.0001) THEN
                    NQ3 = ' '
                    NQ4 = ' '
                  ENDIF
                  IF (ITYP .NE. 5) THEN
                    ISIG  = 0
                    DO 720 I0 = 1, 3
                      IF (ISIG .EQ. 0 .AND. ROW(I0) .LT. -0.01)
     1                    ISIG = -1
                      IF (ISIG .EQ. 0 .AND. ROW(I0) .GT.  0.01)
     1                    ISIG = 1
  720               CONTINUE
                    IMULT = 0
  730               IMULT = IMULT + ISIG
                    DO 740 I0 = 1, 3
                      IROW(I0) = NINT(IMULT * ROW(I0))
                      IF (ABS(ABS(ROW(I0) * IMULT) - IABS(IROW(I0)))
     1                    .GT. 0.01) GOTO 730
  740               CONTINUE
                    IF (ITRY .LT. 0) THEN
                      DO 750 I0 = 1, 3
                        GLIDE(I0) = ISIG * GLIDE(I0)
                        GLY(I0)   = GLIDE(I0)
  750                 CONTINUE
                    ENDIF
                    IF (IGLIDE .EQ. 1) THEN
                      TEXT2 = 'Screw ='
                      DO 760 I0 = 1, 3
                        ITR(I0) = MOD (NINT(12.0 * GLIDE(I0)) + 12, 12)
                        GLIDE(I0) = ITR(I0) / 12.0
                        ISHFT     = ITR(I0) * IROW(I0)
                        ITRI0     = ITR(I0)
                        IF (ISHFT .NE. 0) THEN
                          IF (NROT .EQ. 3) THEN
                            IF (ITRI0 .EQ. 2) THEN
                              ITRI0 = 4
                            ELSE IF (ITRI0 .EQ. 10) THEN
                              ITRI0 = 8
                            ENDIF
                          ENDIF
                          TEXT1 = CHAR(ICHAR('0') + ITRI0 * NROT / 12)
                        ENDIF
  760                 CONTINUE
                      IF (ITRY .EQ. - 4) THEN
                        NRT   = 0
                        TEXT1 = ' '
                        TEXT2 = 'Glide ='
                        IF (ITR(1) .EQ. 0 .AND. ITR(2) .EQ. 0) THEN
                          FSYM(2 : 2) = 'c'
                        ELSE IF (ITR(1) .EQ. 0 .AND. ITR(3) .EQ. 0) THEN
                          FSYM(2 : 2) = 'b'
                        ELSE IF (ITR(2) .EQ. 0 .AND. ITR(3) .EQ. 0) THEN
                          FSYM(2 : 2) = 'a'
                        ELSE IF (MOD (ITR(1), 6) .EQ. 3 .OR.
     1                           MOD (ITR(2), 6) .EQ. 3) THEN
                          FSYM(2 : 2) = 'd'
                        ELSE
                          FSYM(2 : 2) = 'n'
                        ENDIF
                      ENDIF
                      IPRMX = 80
                    ELSE
                      IPRMX = 55
                    ENDIF
                    NEWS = NEWS + 1
                    NMIS(NEWS) = (6 - NRT) * 100 + NEWS
                    DO 780 IR = 1, 3
                      DO 770 IK = 1, 3
                        XMIS(IR, IK, NEWS) = ROTM1(IR, IK)
  770                 CONTINUE
                      XMIS4(IR, NEWS) = ORIG(IR)
                      XMIS5(IR, NEWS) = GLY(IR) * ISIG
  780               CONTINUE
                    IF (NFTX .GT. 0) THEN
                      WRITE (LU6, 99964)
                      WRITE (LU6, 99954) LINE(1:75)
                      WRITE (LU6, 99979)
                      WRITE (LU6, 99979)
                      IF (IGBL(63) .GT. 0) THEN
                        CALL PLA269 (4)
                        WRITE (LU7, 99964)
                        WRITE (LU7, 99954) LINE(1:75)
                        WRITE (LU7, 99979)
                      ENDIF
                    ENDIF
                    IF (STAR .EQ. ' *')
     1              WRITE (LU20, 99935) '_112', NNFIT, NNFIT, FSYM
                    WRITE (PRBUF, 99995) FSYM, STAR, IROW, IROW0, DLE,
     1                     IPERP, MULT, ANG, NNFIT, DSMAX, ORIG
                    NNNFIT = MIN (NNNFIT, NNFIT)
                    CALL GEN065 (0, PRBUF, 81, 7)
                    WRITE (LU6, 99954) PRBUF(1:80)
                    IF (NNFIT .LT. 100 .AND. ISTR .EQ. 1) ISTR = 5
                    IF (IWIN .EQ. 1 .AND. VRT .GT. 6.0) THEN
                      VRT = VRT - 0.5
                      CALL GGIP20 (0.0, PRBUF, 80, 0.35, 1 + ISTR,
     1                             2, 1.0, VRT)
                    ENDIF
                    IF (IGBL(63) .GT. 2) THEN
                      CALL PLA269 (1)
                      WRITE (LU7, 99954) PRBUF(1:80)
                    ENDIF
                    WRITE (PRBUF, 99991) TEXT1, NQ3(1:6), NQ4(1:6),
     1                     TEXT2, GLIDE
                    CALL GEN065 (0, PRBUF, IPRMX + 1, 7)
                    WRITE (LU6, 99954) PRBUF(1:IPRMX)
                    IF (IWIN .EQ. 1 .AND. VRT .GT. 6.0) THEN
                      DO 790 I0 = 1, IPRMX
                        IF (PRBUF(I0:I0) .NE. ' ') THEN
                          VRT = VRT - 0.5
                          CALL GGIP20 (0.0, PRBUF, IPRMX, 0.35,
     1                         1 + ISTR, 2,  1.0, VRT)
                          GOTO 800
                        ENDIF
  790                 CONTINUE
                    ENDIF
  800               IF (IWIN .EQ. 1) CALL GGIP (0.0, 0.0, 0.0, 6)
                    IF (IGBL(63) .GT. 2) THEN
                      CALL PLA269 (1)
                      WRITE (LU7, 99954) PRBUF(1:IPRMX)
                    ENDIF
                    IF (DSMAX .GT. PAR(291)) PAR(291) = DSMAX
                    NSV         = NSV + 1
                    KBO(NSV, 1) = NROT
                    KBO(NSV, 2) = ISYM
                    KBO(NSV, 3) = ISTR
                  ELSE
                    IF (ITRY .LT. 0) THEN
                      DO 810 I0 = 1, 3
                        GLIDE(I0) = MOD (GLIDE(I0), 1.0)
                        IF (ABS(GLIDE(I0)) .LT. 0.001) GLIDE(I0) = 0.0
                        IF (GLIDE(I0) .LT. -0.001)
     1                      GLIDE(I0) = GLIDE(I0) + 1.0
                        NA(I0) = MOD (NINT(GLIDE(I0) * 24), 24)
                        NZ = NA(I0)
                        IF (NZ .GT. 12) NZ = 24 - NZ
                        IF (NZ .EQ. 1 .OR. NZ .EQ. 5. .OR. NZ .EQ. 7
     1                    .OR. NZ .EQ. 10 .OR. NZ .EQ. 11) GOTO 820
  810                 CONTINUE
                      NLCP = NA(1) * 10000 + NA(2) * 100 + NA(3)
                      IF (NLCP .EQ. 0) THEN
                        FSYM = ' P'
                      ELSE
                        IF (NLCP .EQ. 1212) THEN
                          FSYM = ' A'
                        ELSE IF (NLCP .EQ. 120012) THEN
                          FSYM = ' B'
                        ELSE IF (NLCP .EQ. 121200) THEN
                          FSYM = ' C'
                        ELSE IF (NLCP .EQ. 121212) THEN
                          FSYM = ' I'
                        ELSE IF (NLCP .EQ. 120000) THEN
                          FSYM = ' X'
                        ELSE IF (NLCP .EQ.   1200) THEN
                          FSYM = ' Y'
                        ELSE IF (NLCP .EQ.     12) THEN
                          FSYM = ' Z'
                        ELSE
                          FSYM = ' S'
                        ENDIF
                        NSGTR = 1
                        IF (NFTX .GT. 0) THEN
                          WRITE (LU6, 99964)
                          WRITE (LU6, 99954) LINE(1:75)
                          WRITE (LU6, 99979)
                          WRITE (LU6, 99979)
                          IF (IGBL(63) .GT. 0) THEN
                            CALL PLA269 (4)
                            WRITE (LU7, 99964)
                            WRITE (LU7, 99954) LINE(1:75)
                            WRITE (LU7, 99979)
                          ENDIF
                        ENDIF
                        WRITE (LU20, 99935) '_112', 1, 1, FSYM
                        WRITE (PRBUF, 99988) FSYM, NLCP, NNFIT, DSMAX,
     1                                       GLIDE
                        CALL GEN065 (0, PRBUF, 81, 7)
                        WRITE (LU6, 99954) PRBUF(1:80)
                        IF (IGBL(63) .GT. 2) THEN
                          CALL PLA269 (1)
                          WRITE (LU7, 99954) PRBUF(1:80)
                        ENDIF
                        IF (IWIN .EQ. 1 .AND. VRT .GT. 6.0) THEN
                          VRT = VRT - 0.5
                          IF (NNFIT .EQ. 100) THEN
                            NCOL = 2
                          ELSE
                            NCOL = 6
                          ENDIF
                          CALL GGIP20 (0.0, PRBUF, 80, 0.35, NCOL, 2,
     1                                 1.0, VRT)
                        ENDIF
                        WRITE (PRBUF, 99970) NQ3(1:6), NQ4(1:6)
                        WRITE (LU6, 99954) PRBUF(1:80)
                        IF (IWIN .EQ. 1 .AND. VRT .GT. 6.0) THEN
                          VRT = VRT - 0.5
                          CALL GGIP20 (0.0, PRBUF, 80, 0.35, NCOL, 2,
     1                                 1.0, VRT)
                        ENDIF
                        IF (IGBL(63) .GT. 2) THEN
                          CALL PLA269 (1)
                          WRITE (LU7, 99954) PRBUF(1:80)
                        ENDIF
                        IF (NLCLP .EQ. 1) THEN
                          IF (NNFIT .GE. (100 - IPR(568) *
     1                        NINT(PAR(249)))) THEN
                            IF (NEWLT .EQ. 0) WRITE (LU20, 99954)
     1                          '_110         1         1'
                            IF (IPR(503) .EQ. 0) THEN
                              NEWLT         = NEWLT + 1
                              NEWLAT(NEWLT) = NLCP
                              IPR(209) = 1
                              IPR(459) = 1
                            ELSE
                              NNFIT = 100
                            ENDIF
                          ENDIF
                        ENDIF
                      ENDIF
                      GOTO 820
                    ELSE
                      IF (IPR(257) .EQ. 1) INVST = 1
                      IF (STAR .EQ. ' *') THEN
                        WRITE (LU20, 99935) '_111', NNFIT, NNFIT
                      ENDIF
                      WRITE (PRBUF, 99987) STAR, NNFIT, DSMAX, ORIG
                      IF (DSMAX .LT. DSCENT) THEN
                        NFT     = NNFIT
                        DSCENT  = DSMAX
                        ORGM(1) = ORIG(1)
                        ORGM(2) = ORIG(2)
                        ORGM(3) = ORIG(3)
                      ENDIF
                      CALL GEN065 (0, PRBUF, 81, 7)
                      WRITE (LU6, 99954) PRBUF(1:80)
                      IF (IGBL(63) .GT. 2) THEN
                        CALL PLA269 (1)
                        WRITE (LU7, 99954) PRBUF(1:80)
                      ENDIF
                      IF (NNFIT .LT. 100 .AND. ISTR .EQ. 1) ISTR = 5
                      IF (IWIN .EQ. 1 .AND. VRT .GT. 6.0) THEN
                        VRT = VRT - 0.5
                        CALL GGIP20 (0.0, PRBUF, 80, 0.35, 1 + ISTR, 2,
     1                               1.0, VRT)
                      ENDIF
                      WRITE (PRBUF, 99970) NQ3(1:6), NQ4(1:6)
                      WRITE (LU6, 99954) PRBUF(1:80)
                      IF (IWIN .EQ. 1 .AND. VRT .GT. 6.0) THEN
                        VRT = VRT - 0.5
                        CALL GGIP20 (0.0, PRBUF, 80, 0.35, 1 + ISTR, 2,
     1                               1.0, VRT)
                      ENDIF
                      IF (IGBL(63) .GT. 2) THEN
                        CALL PLA269 (1)
                        WRITE (LU7, 99954) PRBUF(1:80)
                      ENDIF
                    ENDIF
                  ENDIF
                  IF (ITYP .NE. 5 .OR. STAR .EQ. '  ') GOTO 850
                ENDIF
  820         CONTINUE
  830       CONTINUE
            IF (ITRY .NE. 5) NCHIRF = MIN (NCHIRF, NCHR / NSYM)
  840     CONTINUE
          IF (ISYM .LE. N3) THEN
            IMETRIC = IMETRIC + 1
            WRITE (PRBUF, 99996) IROW0, DLE, IPERP, MULT, ANG
            CALL GEN065 (0, PRBUF, 61, 4)
            WRITE (LU6, 99932) PRBUF(1:61)
            IF (IGBL(63) .GT. 2) THEN
              CALL PLA269 (2)
              WRITE (LU7, 99932) PRBUF(1:61)
            ENDIF
          ENDIF
  850   CONTINUE
        IF (NEWLT .GT. 0 .AND. IPR(503) .EQ. 0) THEN
          CALL PLA028 (NEWLT, NLTX, NEWLAT, NP47)
          IF (NLTX .GT. 0) THEN
            IF (IWIN .EQ. 1) THEN
              BCD = 'Implement new Sublattice ? (y/n[N])'//CHAR(0)
              CALL GGIP (-999.0, 5.0 + FLOAT(IGBL(68)), 36.0, 110)
              CALL PLA013 (0, 1)
            ELSE
              IGGT = 'Y'
            ENDIF
            IF (IGGT(1:1) .EQ. 'Y') THEN
              WRITE (PRBUF, 99959) JID(1:21)
              WRITE (LU6, 99926) PRBUF
              IF (IWIN .EQ. 1) THEN
                VRT = VRT - 1.5
                CALL GGIP20 (0.0, PRBUF, 80, 0.35, 1, 2, 4.0, VRT)
                CALL PLA297 (0)
              ENDIF
              IF (IGBL(63) .GT. 2) THEN
                CALL PLA269 (3)
                WRITE (LU7, 99927) PRBUF
              ENDIF
              XSUB = 'S'
              GOTO 40
            ELSE
              IPR(459) = 0
              IPR(209) = 0
            ENDIF
          ENDIF
        ENDIF
        IF (NSV .EQ. 2) THEN
          DO 870 I = 1, 2
            IF (KBO(I, 3) .EQ. 1) THEN
              KBO(I, 1) = 0
              GOTO 880
            ENDIF
  870     CONTINUE
        ENDIF
  880   JMX = NSV - 1
  890   NB  = 0
        DO 910 J = 1, JMX
          IF (KBO(J, 1) .LT. KBO(J + 1, 1)) THEN
            DO 900 K = 1, 3
              CALL GEN014 (KBO(J, K), KBO(J + 1, K))
  900       CONTINUE
            NB = 1
          ENDIF
  910   CONTINUE
        IF (NB .EQ. 1) GOTO 890
        ISYST =  8
        MLAUE = 12
        IF (NSV .EQ. 2) NSV = 1
        IF (NSV .EQ. 0) THEN
          CALL GEN021 (PAT, 1)
          ISYST = 1
          MLAUE = 1
        ELSE
          NROT = KBO(1, 1)
          IF (NSV .EQ. 7 .AND. NROT .NE. 6) THEN
            I0 = 4
          ELSE
            I0 = 0
          ENDIF
          IF (I0 .EQ. 4 .OR. NSV .EQ. 3 .OR. NSV .EQ. 13) THEN
            DO 930 I = 1, 3
              DO 920 J = 1, 3
                PAT(I, J) = RH(J, 3, KBO(I0 + I, 2))
  920         CONTINUE
  930       CONTINUE
            IF (NSV .EQ. 3) THEN
              ISYST = 3
              MLAUE = 3
            ELSE IF (NSV .EQ. 7) THEN
              ISYST = 7
              MLAUE = 10
            ELSE
              ISYST = 7
              MLAUE = 11
            ENDIF
          ELSE
            ISYM = KBO(1, 2)
            DO 940 J = 1, 3
              DO 945 K = 1, 3
                PAT(K, J) = RH(J, K, ISYM)
  945         CONTINUE
  940       CONTINUE
            IF (NSV .EQ. 1) THEN
              IF (NROT .EQ. 2) THEN
                ISYST = 2
                MLAUE = 2
                DO 950 J = 1, 3
                  CALL GEN018 (PAT(2, J), PAT(3, J))
  950           CONTINUE
              ELSE IF (NROT .EQ. 3) THEN
                ISYST = 5
                MLAUE = 6
              ELSE IF (NROT .EQ. 4) THEN
                ISYST = 4
                MLAUE = 4
              ELSE
                ISYST = 6
                MLAUE = 8
              ENDIF
            ELSE IF (NSV .EQ. 4) THEN
              IF (NROT .NE. 4) THEN
                ISYST = 5
                MLAUE = 7
              ELSE
                ISYST = 4
                MLAUE = 5
              ENDIF
            ELSE IF (NSV .EQ. 5) THEN
              ISYST = 4
              MLAUE = 5
            ELSE IF (NSV .EQ. 7) THEN
              ISYST = 6
              MLAUE = 9
            ENDIF
          ENDIF
        ENDIF
        CALL GEN010 (PAT, IDET, 0)
        IF(IDET .LT. 0) THEN
          DO 960 J = 1, 3
            PAT(2, J) = - PAT(2, J)
  960     CONTINUE
        ENDIF
        CALL GEN003 (PAT, ROTM1, DET, 0)
        IDET = NINT(DET)
        IF (IDET .EQ. 4) THEN
          LATT = 'F'
        ELSE IF (IDET .EQ. 3) THEN
          LATT = 'R'
          V1(1) = 2.0
          V1(2) = 1.0
          V1(3) = 1.0
          CALL GEN094 (PAT, V1, 3, IDUM)
          IF (IDUM .NE. 0) THEN
            CALL GEN021 (DAM, 1)
            DAM(1, 2) =  1.0
            DAM(2, 1) = -1.0
            DAM(2, 2) =  0.0
            CALL GEN004 (DAM, PAT, PAT)
          ENDIF
        ELSE IF (IDET .EQ. 2) THEN
          V1(1) = 0.0
          V1(2) = 1.0
          V1(3) = 1.0
          N     = 0
          CALL GEN094 (PAT, V1, 2, IDUM)
          IF (IDUM .EQ. 0) THEN
            LATT = 'A'
            N    = 1
          ELSE
            CALL GEN018 (V1(1), V1(2))
            CALL GEN094 (PAT, V1, 2, IDUM)
            IF (IDUM .EQ. 0) THEN
              LATT = 'B'
              N    = 2
            ELSE
              CALL GEN018 (V1(2), V1(3))
              CALL GEN094 (PAT, V1, 2, IDUM)
              IF (IDUM .EQ. 0) THEN
                LATT = 'C'
              ELSE
                V1(3) = 1.0
                CALL GEN094 (PAT, V1, 2, IDUM)
                IF (IDUM .EQ. 0) THEN
                  LATT = 'I'
                ELSE
                  LATT = ' '
                ENDIF
              ENDIF
            ENDIF
          ENDIF
          IF (N .NE. 0) THEN
            DO 970 I = 1, 3
              PAT(2, I) = - PAT(2, I)
              CALL GEN018 (PAT(N, I), PAT(3, I))
  970       CONTINUE
            LATT = 'C'
          ENDIF
        ELSE
          LATT = 'P'
        ENDIF
        IF (ISYST .EQ. 5) THEN
          LAT0 = 6
        ELSE
          LAT0 = ISYST
        ENDIF
        IF (LAT0 .EQ. 2 .AND. LATT .EQ. 'I' .AND. IGBL(106) .EQ. 0) THEN
          LATT = 'C'
          CALL GEN021 (DAM, 1)
          DAM(1, 3) =  1.0
          DAM(3, 1) = -1.0
          DAM(3, 3) =  0.0
          CALL GEN004 (DAM, PAT, PAT)
        ENDIF
        CALL GEN005 (TRNS, QM)
        CALL GEN004 (PAT, QM, ROTM2)
        CALL GEN005 (ROTM2, TR1)
        CALL GEN003 (TR1, ROTM1, DET, 0)
        CALL GEN038 (SPGRNM(2), 1, 11)
        CALL GEN074 (ORG, 0.0, 1, 3)
        IF (INVST .EQ. 1) CALL GEN002 (1, ROTM1, ORGM, ORG, XLNG)
        IF (INVST .EQ. 1 .OR. IPR(257) .EQ. 2) THEN
          CENT = 'C'
        ELSE
          CENT = 'A'
        ENDIF
        IF (LAT0 .EQ. 7) THEN
          DO 990 JN = 1, NEWS
            IN = NMIS(JN) / 100
            IF (IN .EQ. 3) NMIS(JN) = NMIS(JN) + 300
  990     CONTINUE
        ENDIF
        CALL GEN022 (NMIS, 1, NEWS)
        NRT1 = 0
        NNRT = 0
        V41  = 0.25
        V42  = 0.25
        V43  = 0.25
        DO 1010 JN = 1, NEWS
          IN  = MOD (NMIS(JN), 100)
          NRT = 6 - NMIS(JN) / 100
          IF (NRT .EQ. 5) THEN
            NRT  = 4
            NNRT = 1
          ENDIF
          CALL GEN004 (ROTM1, XMIS(1, 1, IN), XMIS(1, 1, IN))
          CALL GEN004 (XMIS(1, 1, IN), TR1, XMIS(1, 1, IN))
          CALL GEN002 (1, ROTM1, XMIS4(1, IN), XMIS4(1, IN), XLNG)
          CALL GEN002 (1, ROTM1, XMIS5(1, IN), XMIS5(1, IN), XLNG)
          IF (JN .EQ. 1) THEN
            IF (INVST .EQ. 0 .AND. IPR(257) .EQ. 1) THEN
              IN1    = IN
              ORG(1) = XMIS4(1, IN)
              ORG(2) = XMIS4(2, IN)
              ORG(3) = XMIS4(3, IN)
              NRT1   = NRT
              IF (LAT0 .EQ. 4) THEN
                V43 = 0.125
              ELSE IF (LAT0 .EQ. 6) THEN
                V41 = 0.3333
                V42 = 0.3333
                V43 = 0.5 / NRT1
              ELSE IF (LAT0 .EQ. 7) THEN
                V41 = 0.125
                V42 = 0.125
                V43 = 0.125
              ENDIF
            ELSE
              IF (NRT .EQ. 3 .OR. NRT .EQ. 6) THEN
                ORG(1) = ORG(1) +
     1             0.5 * MOD (NINT((XMIS4(1, IN) - ORG(1)) * 6), 2)
                ORG(2) = ORG(2) +
     1             0.5 * MOD (NINT((XMIS4(2, IN) - ORG(2)) * 6), 2)
              ENDIF
            ENDIF
          ELSE IF (JN .EQ. 2 .AND. NNRT .EQ. 0) THEN
            IF (INVST .EQ. 0 .AND. IPR(257) .EQ. 1) THEN
              IF (NRT1 .GT. 2) THEN
                IF (NRT .EQ. 4) THEN
                  IF (XMIS(1, 1, IN1) .EQ. 1) THEN
                    ORG(1) = XMIS4(1, IN)
                  ELSE IF (XMIS(2, 2, IN1) .EQ. 1) THEN
                    ORG(2) = XMIS4(2, IN)
                  ELSE IF (XMIS(3, 3, IN1) .EQ. 1) THEN
                    ORG(3) = XMIS4(3, IN)
                  ENDIF
                ELSE
                  ORG(3) = XMIS4(3, IN)
                ENDIF
              ELSE
                IF (NINT(XMIS(1, 1, IN1)) .EQ.  1 .AND.
     1              NINT(XMIS(2, 2, IN1)) .EQ. -1 .AND.
     2              NINT(XMIS(3, 3, IN1)) .EQ. -1) THEN
                  ORG(1) = XMIS4(1, IN)
                ELSE IF (NINT(XMIS(1, 1, IN1)) .EQ. -1 .AND.
     1                   NINT(XMIS(2, 2, IN1)) .EQ.  1 .AND.
     2                   NINT(XMIS(3, 3, IN1)) .EQ. -1) THEN
                  ORG(2) = XMIS4(2, IN)
                ELSE IF (NINT(XMIS(1, 1, IN1)) .EQ. -1 .AND.
     1                   NINT(XMIS(2, 2, IN1)) .EQ. -1 .AND.
     2                   NINT(XMIS(3, 3, IN1)) .EQ.  1) THEN
                  ORG(3) = XMIS4(3, IN)
                ENDIF
              ENDIF
            ENDIF
          ENDIF
          DO 1000 IR = 1, 3
            XMIS4(IR, IN) = XMIS4(IR, IN) - ORG(IR)
 1000     CONTINUE
 1010   CONTINUE
        V4(1) = 0.0
        V4(2) = 0.0
        V4(3) = 0.0
        NORG  = 0
 1020   WRITE (ICL, 99958) LATT, CENT
        CALL SGSM (ICL, 0, FN, LU6, 0, IERR)
        DO 1060 JN = 1, NEWS
          IN = MOD (NMIS(JN), 100)
          DO 1030 JJ = 1, 3
            V5(JJ) = - XMIS4(JJ, IN) + V4(JJ)
 1030     CONTINUE
          CALL GEN002 (1, XMIS(1, 1, IN), V5, V6, XLNG)
          KK = 0
          DO 1050 II = 1, 3
            FN(9 + II) = NINT (24.0 * MOD (XMIS4(II, IN) - V4(II) +
     1                   V6(II) + XMIS5(II, IN) + 10.0, 1.0)) / 24.0
            DO 1040 JJ = 1, 3
              KK = KK + 1
              FN(KK) = XMIS(II, JJ, IN)
 1040       CONTINUE
 1050     CONTINUE
          CALL SGSM (ICL, 0, FN, LU6, 15, IERR)
          IF (IERR .NE. 0) THEN
            IF (LOOPR .EQ. 1) THEN
              JERR = 1
              GOTO 1155
            ELSE
              GOTO 1070
            ENDIF
          ENDIF
 1060   CONTINUE
        CALL SGSM (ICL, 0, FN, 0,  18, IERR)
        SPGRNM(2) = ICL(1:26)
        IF (SPGRNM(2)(1:4) .NE. 'C2/n') THEN
          IF (IBVL(LAT0)//LATT .NE. ICL(12:13)) GOTO 1070
          IF (SPGRNM(2)(1:2) .NE. '  ') GOTO 1080
        ENDIF
 1070   IF (CENT .EQ. 'A') THEN
          V4(3) = V4(3) + V43
          IF (V4(3) .GT. 0.99) THEN
            V4(3) = 0.0
            V4(2) = V4(2) + V42
            IF (V4(2) .GT. 0.99) THEN
              V4(2) = 0.0
              V4(1) = V4(1) + V41
            ENDIF
          ENDIF
          IF (V4(1) .LT. 1.0) GOTO 1020
        ELSE
          NORG  = NORG + 1
          IF (LATT .EQ. 'P') THEN
            IF (NORG .EQ. 1) THEN
              V4(1) = 0.50
              V4(2) = 0.00
              V4(3) = 0.00
            ELSE IF (NORG .EQ. 2) THEN
              V4(1) = 0.00
              V4(2) = 0.50
              V4(3) = 0.00
            ELSE IF (NORG .EQ. 3) THEN
              V4(1) = 0.00
              V4(2) = 0.00
              V4(3) = 0.50
            ENDIF
            NORGM = 3
          ELSE IF (LATT .EQ. 'A') THEN
            V4(2) = 0.25
            V4(3) = 0.25
            NORGM = 1
          ELSE IF (LATT .EQ. 'B') THEN
            V4(1) = 0.25
            V4(3) = 0.25
            NORGM = 1
          ELSE IF (LATT .EQ. 'C') THEN
            V4(1) = 0.25
            V4(2) = 0.25
            NORGM = 1
          ELSE IF (LATT .EQ. 'F') THEN
            IF (NORG .EQ. 1) THEN
              V4(1) = 0.00
              V4(2) = 0.25
              V4(3) = 0.25
            ELSE IF (NORG .EQ. 2) THEN
              V4(1) = 0.25
              V4(2) = 0.00
              V4(3) = 0.25
            ELSE IF (NORG .EQ. 3) THEN
              V4(1) = 0.25
              V4(2) = 0.25
              V4(3) = 0.00
            ENDIF
            NORGM = 3
          ELSE IF (LATT .EQ. 'I') THEN
            IF (NORG .EQ. 1) THEN
              V4(1) = 0.25
              V4(2) = 0.25
              V4(3) = 0.25
            ELSE IF (NORG .EQ. 2) THEN
              V4(1) = 0.50
              V4(2) = 0.00
              V4(3) = 0.00
            ELSE IF (NORG .EQ. 3) THEN
              V4(1) = 0.00
              V4(2) = 0.50
              V4(3) = 0.00
            ELSE IF (NORG .EQ. 4) THEN
              V4(1) = 0.00
              V4(2) = 0.00
              V4(3) = 0.50
            ELSE IF (NORG .EQ. 5) THEN
              V4(1) = 0.75
              V4(2) = 0.25
              V4(3) = 0.25
            ELSE IF (NORG .EQ. 6) THEN
              V4(1) = 0.25
              V4(2) = 0.75
              V4(3) = 0.25
            ELSE IF (NORG .EQ. 7) THEN
              V4(1) = 0.25
              V4(2) = 0.25
              V4(3) = 0.75
            ENDIF
            NORGM = 7
          ELSE IF (LATT .EQ. 'R') THEN
            IF (NORG .EQ. 1) THEN
              V4(1) = 0.33333
              V4(2) = 0.16667
              V4(3) = 0.16667
            ELSE
              V4(1) = 0.16667
              V4(2) = 0.33333
              V4(3) = 0.33333
            ENDIF
            NORGM = 2
          ENDIF
          IF (NORG .LE. NORGM) GOTO 1020
        ENDIF
 1080   DO 1090 J = 1, 3
          ORG(J) = ORG(J) + V4(J)
          V4(J)  = 0.0
 1090   CONTINUE
        IF (SPGRNM(2)(1:1) .EQ. ' ') THEN
          SPGRNM(2)(1:1) = '?'
        ELSE
          IF (SPGRNM(2)(12:12) .EQ. 'm') THEN
            IF (SPGRNM(2)(1:7) .EQ. 'Pa     ') THEN
              SPGRNM(2)(1:11) = 'Pc     C-BA'
            ELSE IF (SPGRNM(2)(1:7) .EQ. 'P2/a   ') THEN
              SPGRNM(2)(1:11) = 'P2/c   C-BA'
            ELSE IF (SPGRNM(2)(1:7) .EQ. 'P21/a  ') THEN
              SPGRNM(2)(1:11) = 'P21/c  C-BA'
            ELSE IF (IGBL(106) .EQ. 0) THEN
              IF (SPGRNM(2)(1:7) .EQ. 'Pn     ') THEN
                SPGRNM(2)(1:11) = 'Pc     A-B-'
              ELSE IF (SPGRNM(2)(1:7) .EQ. 'P2/n   ') THEN
                SPGRNM(2)(1:11) = 'P2/c   A-B-'
              ELSE IF (SPGRNM(2)(1:7) .EQ. 'P21/n  ') THEN
                SPGRNM(2)(1:11) = 'P21/c  A-B-'
              ENDIF
            ENDIF
          ELSE IF (SPGRNM(2)(12:12) .EQ. 'c') THEN
            IF (SPGRNM(2)(1:7) .EQ. 'Pb-3   ') THEN
              SPGRNM(2)(1:11) = 'Pa-3   BA-C'
              V4(2) = 0.5
            ENDIF
          ENDIF
          CALL GEN020 (1, SPGRNM(2), 8, 11)
          DO 1100 J = 1, 8
            IF (SPGRNM(2)(8:11) .EQ. TRTYP(J)(1:4)) THEN
              CALL GEN004 (TRDAT(1, 1, J), PAT, PAT)
              CALL GEN004 (PAT, QM, ROTM2)
              CALL GEN005 (TRDAT(1, 1, J), TR1)
              CALL GEN003 (TR1, TTRM1, DET, 0)
              CALL GEN002 (1, TTRM1, ORG, ORG, XLNG)
            ENDIF
 1100     CONTINUE
          WRITE (ICL, 99939) SPGRNM(2)(1:7)
          CALL SGSM (ICL, NRXX, XJX, LU6, 0, IERR)
          CALL SGSM (ICL, 0, FN, LU6, 18, IERR)
          SPGRNM(2) = ICL(1:26)
          ISGNR     = NINT(FN(1))
          LAT0      = NINT(FN(2))
          LATT      = SPGRNM(2)(13:13)
        ENDIF
        DO 1110 J = 1, 3
          ORG(J) = ORG(J) + V4(J)
          IF (ORG(J) .LE. - 0.5) ORG(J) = ORG(J) + 1.0
          IF (ORG(J) .GT.   0.5) ORG(J) = ORG(J) - 1.0
 1110   CONTINUE
        LU = LU6
        IF (LU .GT. 0) THEN
          WRITE (LU6, 99974)
          IF (IWIN .EQ. 1 .AND. LU .NE. 0) THEN
            WRITE (PRBUF, 99943)
            VRT = VRT - 0.7
            CALL GGIP20 (0.0, PRBUF, 80, 0.35, 5 + IGBL(68), 2, 1.0,
     1                   VRT)
            CALL GGIP (0.0, 1.0, 0.0, 0)
            CALL GGIP (0.0,  VRT - 0.2, 0.0, 3)
            CALL GGIP (HORS, VRT - 0.2, 0.0, 2)
            VRT = VRT - 0.3
          ENDIF
        ENDIF
        CALL GEN003 (ROTM2, DUMMY, DET, 0)
        CALL GEN005 (DUMMY, DUMMY)
        IF (IGBL(63) .GT. 2) THEN
          CALL PLA269 (8)
          WRITE (LU7, 99974)
        ENDIF
        WRITE (PRBUF, 99973) (PAT(1, J), J = 1, 3),
     1      (QM(1, J), J = 1, 3), (ROTM2(1, J), J = 1, 3)
        CALL GEN065 (LU, PRBUF, 80, 16)
        IF (IWIN .EQ. 1 .AND. LU .NE. 0) THEN
          VRT = VRT - 0.5
          CALL GGIP20 (0.0, PRBUF, 80, 0.35, 1, 2, 1.0, VRT)
        ENDIF
        IF (IGBL(63) .GT. 2) WRITE (LU7, 99954) PRBUF
        WRITE (PRBUF, 99972) (PAT(2, J), J = 1, 3),
     1      (QM(2, J), J = 1, 3), (ROTM2(2, J), J = 1, 3)
        CALL GEN065 (LU, PRBUF, 80, 16)
        IF (IWIN .EQ. 1 .AND. LU .NE. 0) THEN
          VRT = VRT - 0.5
          CALL GGIP20 (0.0, PRBUF, 80, 0.35, 1, 2, 1.0, VRT)
        ENDIF
        IF (IGBL(63) .GT. 2)  WRITE (LU7, 99954) PRBUF
        WRITE (PRBUF, 99971) (PAT(3, J), J = 1, 3),
     1      (QM(3, J), J = 1, 3), (ROTM2(3, J), J = 1, 3), DET
        CALL GEN065 (LU, PRBUF, 80, 16)
        IF (IWIN .EQ. 1 .AND. LU .NE. 0) THEN
          VRT = VRT - 0.5
          CALL GGIP20 (0.0, PRBUF, 80, 0.35, 1, 2, 1.0, VRT)
        ENDIF
        IF (IGBL(63) .GT. 0) WRITE (LU7, 99954) PRBUF
        CALL GEN004 (ROTM2, AA, DUMV)
        CALL GEN005 (ROTM2, ROTM1)
        CALL GEN004 (DUMV, ROTM1, DUMV)
        CALL GEN026 (-1, DUMV, PAR(143), GL(5))
        CALL GEN003 (DUMV, ROTM1, DET, 0)
        PAR(100) = SQRT(DET)
        DDIS     = 0.0
        DANG     = 0.0
        IF (ISYST .EQ. 2) THEN
          DANG = MAX (ABS(PAR(146) - 90.0), DANG)
          DANG = MAX (ABS(PAR(148) - 90.0), DANG)
        ELSE IF (ISYST .EQ. 3) THEN
          DANG = MAX (ABS(PAR(146) - 90.0), DANG)
          DANG = MAX (ABS(PAR(147) - 90.0), DANG)
          DANG = MAX (ABS(PAR(148) - 90.0), DANG)
        ELSE IF (ISYST .EQ. 4) THEN
          DDIS = MAX (ABS(PAR(143) - PAR(144)), DDIS)
          DANG = MAX (ABS(PAR(146) - 90.0), DANG)
          DANG = MAX (ABS(PAR(147) - 90.0), DANG)
          DANG = MAX (ABS(PAR(148) - 90.0), DANG)
        ELSE IF (ISYST .EQ. 5 .OR. ISYST .EQ. 6) THEN
          DDIS = MAX (ABS(PAR(143) - PAR(144)), DDIS)
          DANG = MAX (ABS(PAR(148) - 120.0), DANG)
        ELSE IF (ISYST .EQ. 7) THEN
          DDIS = MAX (ABS(PAR(143) - PAR(144)), DDIS)
          DDIS = MAX (ABS(PAR(143) - PAR(145)), DDIS)
          DDIS = MAX (ABS(PAR(144) - PAR(145)), DDIS)
          DANG = MAX (ABS(PAR(146) - 90.0), DANG)
          DANG = MAX (ABS(PAR(147) - 90.0), DANG)
          DANG = MAX (ABS(PAR(148) - 90.0), DANG)
        ENDIF
        IF (IGBL(63) .GT. 2) THEN
          JMAX = 2
        ELSE
          JMAX = 1
        ENDIF
        DO 1120 J = 1, JMAX
          IF (J .EQ. 2) THEN
            LU = LU7
            CALL PLA269 (6)
          ELSE
            LU = LU6
          ENDIF
          WRITE (LU, 99979)
          WRITE (LU, 99998)
          WRITE (LU, 99951)
          WRITE (LU, 99949) SPGRNM(1)(12:13), (PAR(100 + I), I = 1, 6),
     1                      NINT(PAR(98)), KRSYST,  LAUEGR
          WRITE (LU, 99948) (PAR(122 + I), I = 1, 6), NINT(PAR(99))
          LAT1 = LAT0
          IF (LAT1 .EQ. 5) LAT1 = 6
          WRITE (LU, 99947) IBVL(LAT1), LATT, (PAR(142 + I), I = 1, 6),
     1                      NINT(PAR(100)), XSYST(ISYST), LGR(MLAUE)
          IF (J .EQ. 1) THEN
            IF (IWIN .EQ. 1) THEN
              WRITE (PRBUF, 99998)
              VRT = VRT - 0.8
              CALL GGIP20 (0.0, PRBUF, 80, 0.35, 5 + IGBL(68), 2, 1.0,
     1                     VRT)
              CALL GGIP (0.0, 1.0, 0.0, 0)
              CALL GGIP (0.0,  VRT - 0.2, 0.0, 3)
              CALL GGIP (HORS, VRT - 0.2, 0.0, 2)
              WRITE (PRBUF, 99949)
     1               SPGRNM(1)(12:13), (PAR(100 + I), I = 1, 6),
     2                      NINT(PAR(98)), KRSYST,  LAUEGR
              VRT = VRT - 0.8
              CALL GGIP20 (0.0, PRBUF, 80, 0.35, 1, 2, 1.0, VRT)
              WRITE (PRBUF, 99948)
     1              (PAR(122 + I), I = 1, 6), NINT(PAR(99))
              VRT = VRT - 0.5
              CALL GGIP20 (0.0, PRBUF, 80, 0.35, 1, 2, 1.0, VRT)
              LAT1 = LAT0
              IF (LAT1 .EQ. 5) LAT1 = 6
              WRITE (PRBUF, 99947)
     1               IBVL(LAT1), LATT, (PAR(142 + I), I = 1, 6),
     2                      NINT(PAR(100)), XSYST(ISYST), LGR(MLAUE)
              VRT = VRT - 0.5
              CALL GGIP20 (0.0, PRBUF, 80, 0.35, 1, 2, 1.0, VRT)
            ENDIF
            IF (NLCLP .EQ. 1) THEN
              N0 = INDEX (ZSPG, ':')
              IF (N0 .NE. 0) THEN
                ZSPG0 = ZSPG(1:N0-1)
              ELSE
                ZSPG0 = ZSPG
              ENDIF
              IF (ZSPG0 .EQ. SPGRNM(2)(1:7)) THEN
                IF (SPGRNM(1)(1:1) .EQ. ' ') THEN
                  NSP = 2
                ELSE
                  NSP = 1
                ENDIF
                WRITE (LU, 99984) SPGRNM(NSP)(1:11)
                IF (IWIN .EQ. 1) THEN
                  VRT = VRT - 0.9
                  IF (NSGTR .EQ. 0) THEN
                    WRITE (PRBUF, 99950) SPGRNM(NSP)(1:11)
                    NCOL = 3
                  ELSE
                    WRITE (PRBUF, 99929) SPGRNM(NSP)(1:11)
                    NCOL = 2
                  ENDIF
                  CALL GGIP20 (0.0, PRBUF, 80, 0.35, NCOL, 2, 1.0,
     1                         VRT)
                ENDIF
              ELSE
                IF (INDEX (SPGRNM(2), '?') .NE. 0) THEN
                  IF (LOOPR .LT. 3) THEN
                    JERR = 1
                    GOTO 1155
                  ENDIF
                  IF (IWIN .EQ. 1) THEN
                    VRT = VRT - 0.9
                    WRITE (PRBUF, 99931)
                    CALL GGIP20 (0.0, PRBUF, 80, 0.35, 2, 2, 1.0, VRT)
                  ENDIF
                  WRITE (LU, 99930) PRBUF
                  WRITE (LU20, 99954) '_114         1         1'
                ENDIF
              ENDIF
            ENDIF
          ENDIF
          IF (DDIS .GT. 0.0001) WRITE (LU, 99967) DDIS
          IF (DANG .GT. 0.001)  WRITE (LU, 99966) DANG
 1120   CONTINUE
        IF ((ZSPG .NE. SPGRNM(2)(1:7) .AND.
     1       SPGRNM(2)(1:1) .NE. '?') .OR. NLCLP .NE. 1) THEN
          WRITE (LU6, 99963)
          IF (IGBL(63) .GT. 0) THEN
            CALL PLA269 (-4)
            WRITE (LU7, 99963)
          ENDIF
          CALL SGSM (ICL, 0, FN, LU6, 2, IERR)
          IF (IGBL(63) .GT. 0) CALL SGSM (ICL, 0, FN, LU7, 2, IERR)
          IF (IPR(209) .EQ. 0 .AND. IPR(118) .EQ. 0 .AND.
     1        IPR(459) .EQ. 0) THEN
            IF (IGBL(94) .EQ. 0) THEN
              IF (ZSPG(1:6) .NE. 'P21/n ' .AND.
     1            ZSPG(1:5) .NE. 'I2/n ') THEN
                 WRITE (LU20, 99934) '_128', 1, 1,
     1                 SPGRNM(2)(1:7), ZSPG
              ENDIF
            ENDIF
            WRITE (PRBUF, 99945) ZSPG, SPGRNM(2)(1:7)
            WRITE (LU6, 99961) PRBUF(1:80)
            IF (IWIN .EQ. 1) THEN
              VRT = VRT - 0.8
              CALL GGIP20 (0.0, PRBUF, 80, 0.35, 3, 2, 1.0, VRT)
            ENDIF
            IF (IGBL(63) .GT. 0) THEN
              CALL PLA269 (2)
              WRITE (LU7, 99961) PRBUF(1:80)
            ENDIF
          ENDIF
        ENDIF
        DO 1150 J = 1, JMAX
          IF (J .EQ. 2) THEN
            LU = LU7
          ELSE
            LU = LU6
          ENDIF
          IF (IMETRIC .GT. 0) THEN
            IF (J .EQ. 2) CALL PLA269 (2)
            WRITE (LU, 99978)
          ENDIF
          IF (IPR(209) .EQ. 0) THEN
            IF (IPR(118) .EQ. 0 .AND. IPR(459) .EQ. 0
     1        .AND. NSGTR .EQ. 0) THEN
              IF (J .EQ. 1) THEN
                CALL PLA015 (0, 5)
              ELSE IF (J .EQ. 2) THEN
                CALL PLA269 (3)
                WRITE (LU, 99985)
                IF (IPR(207) .NE. 0) THEN
                  CALL PLA269 (1)
                  WRITE(LU, 99924)
                ENDIF
              ENDIF
            ELSE
              WRITE (PRBUF, 99977)
              IF (J .EQ. 1) THEN
                IF (IWIN .EQ. 1) THEN
                  VRT = VRT - 1.0
                  CALL GGIP20 (0.0, PRBUF, 80, 0.35, 2, 2, 1.0, VRT)
                ENDIF
              ENDIF
              IF (J .EQ. 2) CALL PLA269 (1)
              WRITE (LU, 99932) PRBUF
              IF (IPR(118) .NE. 0) THEN
                CALL PLA269 (1)
                WRITE (LU, 99976)
              ENDIF
            ENDIF
          ELSE
            IF (J .EQ. 2) CALL PLA269 (12)
            WRITE (LU, 99965) ORG(1), ORG(2), ORG(3),
     1            ((DUMMY(III, JJJ), JJJ = 1,3), -ORG(III), III = 1, 3)
            IF (IGBL(45) .GT. 0) IGBL(45) = - 1
            NNNFIT = MIN (NNNFIT, NFT)
            WRITE (LU, 99986)
            IF (SPGRNM(1)(1:11) .NE. SPGRNM(2)(1:11) .OR.
     1        XSUB .EQ. 'S') THEN
              IF (SPGRNM(2)(1:11) .NE. '?' .OR. NNNFIT .EQ. 100) THEN
                IF (J .EQ. 2) CALL PLA269 (3)
                WRITE (LU, 99957) JID(1:27), SPGRNM(1)(12:13),
     1            IBVL(LAT0), LATT, PAR(142), NCHIR, NCHIRF, DDIS,
     2            DANG, PAR(291), XSUB, NNNFIT, SPGRNM(2)(1:11),
     3            CHAR(IPR(223))
              ENDIF
              IF (SPGRNM(2)(1:11) .NE. '?') WRITE (LU20, 99934) '_113',
     1            NNNFIT, NNNFIT, SPGRNM(2)(1:10)
            ENDIF
            IF (J .EQ. 1) THEN
              IF (IWIN .EQ. 1) THEN
                IF (ABS(ORG(1)) + ABS(ORG(2)) + ABS(ORG(3)) .GT. 0.001)
     1            THEN
                  WRITE (PRBUF, 99944) ORG(1), ORG(2), ORG(3)
                  VRT = VRT - 0.7
                  CALL GGIP20 (0.0, PRBUF, 80, 0.35, 2, 2, 1.0, VRT)
                ENDIF
                IF (SPGRNM(2)(1:11) .NE. '?') THEN
                  VRT = VRT - 0.5
                  IF (NNNFIT .EQ. 100) THEN
                    WRITE (PRBUF, 99946) SPGRNM(2)(1:11), ISGNR
                    CALL GGIP20 (0.0, PRBUF, 80, 0.35, 2, 2, 1.0, VRT)
                  ELSE
                    WRITE (PRBUF, 99942) SPGRNM(2)(1:11), ISGNR
                    CALL GGIP20 (0.0, PRBUF, 80, 0.35, 6, 2, 1.0, VRT)
                    WRITE (PRBUF, 99941)
                    VRT = VRT - 0.7
                    CALL GGIP20 (0.0, PRBUF, 80, 0.35, 6, 2, 1.0, VRT)
                  ENDIF
                ENDIF
              ENDIF
              CALL PLA015 (0, 6)
            ENDIF
            IF (ISYST .GT. IPR(259)) THEN
              IF (J .EQ. 2) CALL PLA269 (1)
              WRITE (LU, 99982) PAR(291)
            ELSE IF (IPR(259) .NE. 8) THEN
              IF (MLAUE .NE. IPR(258)) THEN
                IF (J .EQ. 2) CALL PLA269 (1)
                WRITE (LU, 99981) DSMAX
              ENDIF
            ENDIF
            IF (INVST .EQ. 1) THEN
              IPR(457) = 1
              PAR(291) = MAX (PAR(291), 2.0 * MAX (0.25, DSMAX))
              IF (DSMAX .GT. 0.0) THEN
                IF (J .EQ. 2) CALL PLA269 (1)
                WRITE (LU, 99980) DSMAX
              ENDIF
            ENDIF
          ENDIF
 1150   CONTINUE
 1155   IF (SPGRNM(1)(1:1) .NE. ' ') THEN
          IF (INDEX (SPGRNM(1)(1:11), ':') .NE. 0) THEN
            WRITE (ICL, '(''SPGR '', A, 64X)') SPGRNM(1)(1:11)
          ELSE
            WRITE (ICL, 99938)
     1        SPGRNM(1)(1:7)//' '//SPGRNM(1)(8:11)
            IF (SPGRNM(1)(13:13) .NE. ' ') ICL(13:13) = '.'
          ENDIF
          CALL SGSM (ICL, NRXX, XJX, LU6, 0, IERR)
        ELSE
          REWIND LU61
          WRITE (ICL, 99937)
          CALL SGSM (ICL, NRXX, XJX, 0, 0, IERR)
          DO 1156 I = 1, NSYMT
            READ (LU61, 99923, END = 1157) ICL
            IF (ICL(1:3) .EQ. 'END') GOTO 1157
            CALL SGSM (ICL, NRXX, XJX, 0, 0, IERR)
 1156     CONTINUE
 1157     CONTINUE
        ENDIF
        IF (LOOPR .LT. 3 .AND. JERR .EQ. 1) THEN
          IPR(220)      = IPR(220) + 1
          IFL(IPR(220)) = 'EXACT'
          IF (LU .EQ. 0) LU = LU6
          WRITE (LU, 99928)
          GOTO 10
        ENDIF
        IF ((ISAVEMOD .EQ. 0 .OR. IGBL(65) .EQ. 1) .AND.
     1     (IPR(209) .GT. 0 .OR. IPR(504) .GT. 0)) THEN
          IF (SPGRNM(2)(1:1) .EQ. '?') THEN
            SPGRNM(2) = SPGRNM(1)
            CALL GEN074 (ORG, 0.0, 1, 3)
            WRITE (LU6, 99956)
            IF (IGBL(63) .GT. 0) THEN
              CALL PLA269 (2)
              WRITE (LU7, 99956)
            ENDIF
          ENDIF
          CALL PLA280 ('CALC GEOM EUCLID')
          JID(34:40) = SPGRNM(2)(1:7)
        ENDIF
        IGBL(67) = 0
      ENDIF
 1160 IF (IWIN .EQ. 1) CALL PLA013 (0, 1)
      IF (IGGT(1:4) .EQ. 'PLOT') THEN
        CALL PLA280 ('CALC ADDSYM')
      ELSE IF (IGGT(1:1) .EQ. '!') THEN
        CALL PLA280 ('CALC ADDSYM')
      ELSE IF (IGGT(1:3) .EQ. 'END') THEN
        CALL PLA280 ('!')
      ENDIF
      IF (LOOPR .GT. 0) THEN
        IF (IPR(121) .GT. 0) IPR(220) = 1
      ENDIF
      IGBL(23) = 10
      CLOSE (LU61, STATUS = 'DELETE')
      RETURN
99999 FORMAT ('ADDSYM - CHECK  (cf. MISSYM (C): Le Page, Y.,',
     1        ' J. Appl. Cryst. (1987), 20, 264-269; J. Appl.',
     2        ' Cryst. (1988), 21, 983-984)', /, 132('-'))
99998 FORMAT ('Cell Lattice', 2X, 'a', 7X, 'b', 7X, 'c', 4X,
     1        'Alpha', 3X, 'Beta', 2X, 'Gamma Volume', 1X,
     2        'CrystalSystem Laue')
99997 FORMAT ('- Number of Input Atoms Included in Search', I5,
     1        ' (Unitcell', I5, ')')
99996 FORMAT (14X, '[', 3I2, ']', F6.2, 2I3, F6.2, 14X, ' Metric')
99995 FORMAT (2A, ' [', 3I2, '] [', 3I2, ']', F6.2, 2I3, F6.2,
     1        I5, F8.3, '  through', 3F6.3)
99994 FORMAT ('ADDSYM Search on Chemical Type ', A, 'ONLY',
     1        ' [Max NonFit',I3, ' Perc]')
99993 FORMAT ('ADDSYM Search on ALL NON-H Chemical Types',
     1        ' [Max NonFit',I3, ' Perc]')
99992 FORMAT ('ADDSYM Search on ALL NON-H Chem. Types (Treated EQUAL)',
     1        ' [Max NonFit',I3, ' Perc]')
99991 FORMAT (2X, A, 40X, 3A, 4F6.3)
99990 FORMAT ('- ', A)
99989 FORMAT ('The Structure Implies the Following Symmetry ',
     1        'Elements Subject to the Criteria:')
99988 FORMAT (A, ' * ', I6, '/24 (NonSpacegroup) Translation',
     1        I3, F8.3, 9X, 3F6.3)
99987 FORMAT ('-1', A, 1X, 35('='), 2X, I3, F8.3, 2X, 'at', 5X,
     1         3F6.3, 1X)
99986 FORMAT (/, ':: * Symmetry Elements Preceded by an Asterisk ',
     1        'are New and Indicate', /,
     2        '::   Missed/Pseudosymmetry. Proposed Inversion or',
     3        ' (Glide) Planes do NOT Apply', /,
     4        '::   for Chiral Molecules.', /,
     5        ':: Note: Glide Plane Codes are with Reference ',
     6        'to the Input Cell !!')
99985 FORMAT (/, ':: *** No Obvious Extra Crystallographic Symmetry',
     1         ' was Detected ***', /)
99984 FORMAT (/, ':: SpaceGroup = ', A,
     1        ' - No Obvious Spacegroup Change Needed/Suggested', //,
     2           ':: An Alternative Analysis for Missed Symmetry may ',
     3           'be tried with ''CALC NEWSYM''.', /)
99983 FORMAT ('- The  ADDSYM Search may be rerun for a choosen atom',
     1        ' type', /
     1         '- Use LIST RADII for an overview of the atom types', /)
99982 FORMAT (':: Change of Crystal System indicated.',
     1        ' (Maxdev. = ', F6.3, ' Ang.)')
99981 FORMAT (':: Change of Laue Class without change of System',
     1        ' indicated (Maxdev = ', F6.3, ' Ang)')
99980 FORMAT (':: Addition of an Inversion Center Indicated.',
     1        ' (Maxdev. = ', F6.3, ' Ang.)')
99979 FORMAT (1X)
99978 FORMAT (/, ':: Lattice Features Metrical Symmetry not ',
     1           'Supported by Contents.')
99977 FORMAT (':: Check for (Approximate/Pseudo) ',
     1        'Inversion/Transl. Symmetry.')
99976 FORMAT ('   See e.g. R.E. Marsh, Acta Cryst. (1994). C50,',
     1        ' 1713-1715', /)
99975 FORMAT (/, '- Number of Excluded Disordered Input Atoms = ', I5)
99974 FORMAT (/, 9X, 'T.R.A.N.S.F.O.R.M.A.T.I.O.N  M.A.T.R.I.X',
     1        ' for CELL and HKL DATA', /, 9X, 62('='),
     2        /, 3X, 'Reduced->Convent', 9X, 'Input->Reduced', 7X,
     3          'T = Input->Convent:    a'' = T a', /, 80('-'))
99973 FORMAT ('(', 3F6.2, ' )   (', 3F6.2, ' )   (', 3F6.2, ' )',
     1         5X, 'Det(T)')
99972 FORMAT ('(', 3F6.2, ' ) X (', 3F6.2, ' ) = (', 3F6.2, ' )',
     1         7X, '=')
99971 FORMAT ('(', 3F6.2, ' )   (', 3F6.2, ' )   (', 3F6.2, ' )',
     1         F10.3)
99970 FORMAT (43X, 2A)
99969 FORMAT (':: Over', I7, 'atoms in the Primitive Cell',
     1        ' (ADDSYM request aborted!)')
99968 FORMAT (':: No Fully Occ. Atoms found in list ...',
     1        ' ADDSYM request aborted!')
99967 FORMAT (/, ':: Axial Lengths differ by', F6.3, ' Ang.')
99966 FORMAT (/, ':: Cell Angles differ', F5.2, ' Deg. from (90/120)')
99965 FORMAT (/, ':: Origin Shifted to:', F7.4, ',', F7.4, ',', F7.4,
     1        ' after Transformation', //,
     2        '::                      (', 3F8.4, ') (', F8.4, ')', /,
     2        ':: R/t for Coordinates  (', 3F8.4, ') (', F8.4, ')', /,
     2        '::                      (', 3F8.4, ') (', F8.4, ')', /)
99964 FORMAT (/, ':: NonFits (i.e. Atoms with no symmetry related',
     1           ' counterpart):')
99963 FORMAT (/, 10X, 'Conventional, New or Pseudo Symmetry', /,
     1        80('='), /)
99962 FORMAT (/, ':: Excluded Disorder Atoms From ADDSYM Analysis:')
99961 FORMAT (/, A, /)
99960 FORMAT (/, ':: Note: Atoms deleted from input !')
99959 FORMAT ('Forced RESTART of ADDSYM to Implement TRANSLATION for ',
     1        A)
99958 FORMAT ('LATT ', A, 1X, A, 72X)
99957 FORMAT (/, 'P! ', A, 1X, A, '=>', 2A, F4.1, 2I3, F6.3, F5.2,
     1        F6.3, 1X, A, I4, '% ', A, /, A, //,
     2        ':: An SPF-style file is written',
     2        ' to be used for the cell transformation.', /)
99956 FORMAT (/, ':: Higher (pseudo)symmetry not compatible,',
     1           '(current symmetry retained)')
99955 FORMAT ('Criteria:', F6.2, ' Deg (Metric),', F5.2, ' Ang (Rot.),'
     1        , F5.2, ' Ang (Inv),', F5.2, ' Ang (Transl)')
99954 FORMAT (A)
99953 FORMAT ('Symm.  Input  Reduced  (Ang)', 8X, '(Deg)', 1X,
     1        '(%)', 3X, '(Ang)', 16X, 'Input Cell')
99952 FORMAT ('Elem', 1X, 'Cell_Row', 1X, 'Cell_Row', 3X,
     1        'd  Typ Dot Angle Fit  MaxDev.', 13X,
     2        'x     y     z')
99951 FORMAT (80('-'))
99950 FORMAT (':: SpaceGroup = ', A,
     1        ' - No Obvious Spacegroup Change Needed/Suggested')
99949 FORMAT ('Input   ',  A,  F7.3, 2F8.3, 3F7.2, I7, 1X, A, 1X, A)
99948 FORMAT ('Reduced ',' P', F7.3, 2F8.3, 3F7.2, I7)
99947 FORMAT ('Convent ', 2A,  F7.3, 2F8.3, 3F7.2, I7, 1X, A, 1X, A)
99946 FORMAT ('Missed/Additional Symmetry : Suggested SPGR = ', A,
     1        '(No', I4,')')
99945 FORMAT (':: Alternative Setting ', A, ' of Standard Setting ', A)
99944 FORMAT ('Origin shifted to:', F6.3, ',', F6.3, ',', F6.3,
     1        ' after transformation')
99943 FORMAT ('  Reduced-to-Convent', 7X, 'Input-to-Reduced', 5X,
     3          'T = Input-to-Convent:   a'' = T a')
99942 FORMAT ('Missed/Additional Symmetry (Ignore Nonfit):',
     1        ' Suggested SPGR = ', A, '(No', I4,')')
99941 FORMAT (' *** PLEASE COMPARE with ''CALC ADDSYM EXACT'' ')
99940 FORMAT (25X, 'PLATON/ADDSYM for ', A)
99939 FORMAT ('SPGR ' , A, 68X)
99938 FORMAT ('SPGR ' , A, 63X)
99937 FORMAT ('LATT P A ', 72X)
99936 FORMAT ('Density based on Input Atom Set =', F6.3,
     1        ' g.cm-3 - Vol / Non-H atom =', F5.1, ' Ang+3')
99935 FORMAT (A, 2I10, 5X, A)
99934 FORMAT (A, 2I10, 2A)
99932 FORMAT (A, /)
99931 FORMAT (':: ADDSYM Could Not (Re)Construct Proper Spacegroup')
99930 FORMAT (/, A)
99929 FORMAT (':: Spacegroup: ', A, ' Not Changed but Check ',
     1        'Pseudo-Translations')
99928 FORMAT (/, 'Restart with EXACT', /)
99927 FORMAT (/, A, /)
99926 FORMAT (/, ':: ', A, /)
99925 FORMAT (3X, A)
99924 FORMAT (':: Note: Rerun in EQUAL Atom Type Mode for more Checks')
99923 FORMAT (A)
99922 FORMAT ('SYMM ', A)
99921 FORMAT ('END')
      END
      SUBROUTINE PLA024
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118,
     1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NPVD=40000000,
     2 NP22=256,NP23=18000,NP25=99,NP29=63,NP38=125,NP39=30,NP41=200,
     3 NP45=2048,NP47=9,NCS=50)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /Q/ ICL, IFL(NP17)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9),
     1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10),
     2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10),
     3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770)
      COMMON // JNSC(2, NP23), VOID(NPVD)
      COMMON /DSPGR/ TYPE, NLAUE
      CHARACTER TYPE(NCS)*16, NLAUE(13)*5
      COMMON /FNAME/ KNM(8), KXT, KNM16
      COMMON /NAMES/ NAME(8), EXTENS, PROGNM, FNLU1, FNLU16, RDTYPE
      CHARACTER NAME*80, EXTENS*9, PROGNM*28, FNLU1*80, FNLU16*80,
     1          RDTYPE*7
      CHARACTER LSB*1, RSB*1, ND13*1, FORMA*136, FORMB*47, DISOR*1
      COMMON /PAGENM/ PAGET, PAGEIND(25)
      CHARACTER PAGET*8, PAGEIND*8
      XI = 0.0
      YI = 0.0
      ZI = 0.0
      FORMA(1:26)    = '(I4,1X, A ,F8.4,''('',I2,'')'''
      FORMA(27:42)   = ',F9.4,''('',I2,'')'''
      FORMA(43:74)   =  FORMA(27:42)//FORMA(27:42)
      FORMA(75:106)  =  FORMA(43:74)
      FORMA(107:136) =  FORMA(27:42)//',3F7.4,F7.2,A)'
      FORMB(1:27)    = '(I4,1X, A ,F8.4,''('',I2,'')'','
      FORMB(28:47)   = '65X,F9.4,''('',I2,'')'')'
      DO 10 I = 1, IAN + 1
        BOK(I, 1) = 0.0
        BOK(I, 2) = 9999.0
        BOK(I, 3) = 0.0
        KBO(I, 1) = 0
   10 CONTINUE
      PAGET = 'ADP-Anal'
      WAVELTH = PAR(17)
      IPR493  = IPR(493)
      IF (IPR493 .EQ. 0) THEN
        WAVELTH = 0.71073
        IPR493  = 2
        WRITE (LU6, 99958)
      ENDIF
      NAT  = IPR(37)
      NATB = IPR(39)
      NRES = IPR(75)
      IF (IPR(67) .EQ. 0) THEN
        NATC = NAT
      ELSE
        NATC = NATB
      ENDIF
      IF (IGBL(31) .EQ. 0) THEN
        IGBL(31) = 3
        CALL PLA021
      ENDIF
      IF (IGBL(31) .LT. 0) IPR(109) = 1
      IF (IGBL(31) .EQ. 7) THEN
        WRITE (LU2, 99963) JID(1:73), (PAR(100 + I), I = 1, 6),
     1       SPGRNM(4), ((ROR(I, J), J = 1, 3), 0.0, I = 1, 3)
      ENDIF
      IF (IGBL(31) .NE. 0 .AND. IGBL(31) .NE. 2 .AND.
     1    IGBL(31) .NE. 4 .AND. IGBL(31) .NE. 7) THEN
        WRITE (LU2, 99982) JID(1:74)
        IF (IGBL(31) .EQ. 3 .AND.
     1     (IPR(209) .GT. 0 .OR. IPR(504) .GT. 0)) THEN
          WRITE (LU2, 99973) ((ROTM2(I, J), J = 1, 3), I = 1, 3),
     1                        (ORG(J), J = 1, 3)
          WRITE (LU2, 99960) MAX (0.3, PAR(291) + 0.01)
        ENDIF
        IF (IGBL(31) .EQ. -2) THEN
          CALL GEN066 (2, PAR(101), PAR(107), SPGRNM(1)(12:12))
        ENDIF
        IF (IPR(23) .EQ. 0) THEN
          WRITE (LU2, 99974) WAVELTH, (PAR(100 + I), I = 1, 6)
        ENDIF
        IF (IPR(438) .EQ. 1 .OR. IGBL(31) .EQ. 3) THEN
          IF (IPR(23) .EQ. 0) THEN
            WRITE (LU2, 99979) (PAR(106 + I), I = 1, 6)
          ENDIF
          IF (PAR(2) .NE. 0.4) WRITE (LU2, 99951) PAR(2)
        ELSE IF (IGBL(31) .EQ. -2) THEN
          WRITE (LU2, 99971) (PAR(106 + I), I = 1, 6)
        ENDIF
        IF (IPR(438) .EQ. 1) WRITE (LU2, 99990) PAR(98), PAR(21)
        IF (IPR(256) .EQ. 0 .OR. IGBL(31) .LT. 0) THEN
          IF (IGBL(31) .LT. 0) THEN
            WRITE (LU2, 99975) IPR(242)
            ISW = 17
          ELSE
            IF (IPR(23) .EQ. 0) THEN
              WRITE (LU2, 99978) SPGRNM(1)(13:13), SPGRNM(1)(14:14)
            ENDIF
            ISW = 2
          ENDIF
          IF (IPR(23) .EQ. 0) THEN
            DO 20 I = 2, IPR(255)
              CALL SGSM (ICL, I, XJX, 0, ISW, IERR)
              WRITE (LU2, 99977) ICL(1:60)
   20       CONTINUE
          ENDIF
        ELSE
          IF (IGBL(31) .EQ. 3 .AND. IPR(67) .NE. 0) THEN
            WRITE (LU2, 99989)
          ELSE
            IF (SPGRNM(1)(1:3) .EQ. '   ' .AND. IPR(209) .EQ. 0
     1          .AND. IPR(504) .EQ. 0) THEN
              IF (IPR(23) .EQ. 0) THEN
                WRITE (LU2, 99978) SPGRNM(1)(13:13), SPGRNM(1)(14:14)
                ISW = 2
                DO 30 I = 2, IPR(255)
                  CALL SGSM (ICL, I, XJX, 0, ISW, IERR)
                  WRITE (LU2, 99977) ICL(1:60)
   30           CONTINUE
              ENDIF
            ELSE
              IF (SPGRNM(2)(1:1) .NE. '?' .AND. SPGRNM(2)(1:1) .NE. ' '
     1            .AND. IGBL(31) .EQ. 3) THEN
                J   = 2
                LSB = '['
                RSB = ']'
              ELSE
                J   = 1
                LSB = ' '
                RSB = ' '
              ENDIF
              IF (INDEX(SPGRNM(J)(1:11), ':') .NE. 0) THEN
                WRITE (LU2, 99976) LSB, SPGRNM(J)(1:11),RSB
              ELSE
                IF (SPGRNM(J)(8:11) .EQ. '    ') THEN
                  I = ICHAR(' ')
                ELSE
                  I = ICHAR('.')
                ENDIF
                WRITE (LU2, 99976)
     1               LSB, SPGRNM(J)(1:7), CHAR(I), SPGRNM(J)(8:11), RSB
              ENDIF
            ENDIF
          ENDIF
        ENDIF
        IF (IPR(504) .EQ. 2) THEN
          WRITE (LU2, 99994) (LMT(IENS(K), 1), K = 1, IAN)
        ENDIF
        IF ((IGBL(31) .EQ. 3 .OR. IGBL(3) .LT. 0) .AND. IPR(310) .GT. 0)
     1      WRITE (LU2, 99998) IPR(310) - 273
      ENDIF
C * OUTPUT (LU2) SHELXL - SFAC, UNIT, FVAR
      IF (IGBL(31) .LT. 0) THEN
        NFVR = IPR(109)
        IF (IPR(595) .EQ. 0) THEN
          DO 40 K = 1, IAN
            L   = IEN(IENS(K))
            IF (IPR493 .LT. 5) THEN
              J   = (L - 1) * 15
              IF (IPR493 .LT. 4) THEN
                J0  = J + 15 - 2 * IPR493
                FAC = SFAC(J0 + 1)
                FDC = SFAC(J0 + 2)
                RMU = AMR(L, IPR493)
              ELSE
                FAC = 0.0
                FDC = 0.0
                RMU = 0
              ENDIF
              WRITE (LU2, 99981) LMT(IENS(K), 1),
     1          (SFAC(J + I), I = 1, 9), FAC, FDC, RMU, REL(L),
     2           SATWT(IENS(K))
            ELSE
              WRITE (LU2, 99981) LMT(IENS(K), 1), 0.0, 0.0, 0.0, 0.0,
     1          0.0, 0.0, 0.0, 0.0, RNSCL(L), 0.0, 0.0, 0.0, REL(L),
     2          SATWT(IENS(K))
            ENDIF
   40     CONTINUE
        ELSE
          WRITE (LU2, 99941) (LMT(IENS(K), 1), K = 1, IAN)
        ENDIF
        WRITE (LU2, 99980) (NINT(CONT(IENS(L), 2)), L = 1, IAN)
        IF (IPR(310) .GT. 0) WRITE (LU2, 99998) IPR(310) - 273
        WRITE (LU2, 99942)
        WRITE (LU2, 99999) PAR(74), (RP(L), L = 2, NFVR)
      ELSE IF (IGBL(31) .EQ. 3 .AND. IPR(209) .EQ. 0) THEN
        WRITE (LU2, 99970)
      ENDIF
      IF (IPR(32) .NE. 0 .AND. IGBL(63) .GT. 2) THEN
         CALL PLA269 (-2)
         WRITE (LU7, 99984) CHAR(ICHAR('#'))
      ENDIF
      CALL GEN074 (XPV, 0.0, 1, 4)
      DO 210 N = 1, NRES
        DO 60 I = 1, IAN + 1
          BOK(I, 5) = 9999.0
          BOK(I, 6) = 0.0
   60   CONTINUE
        CALL GEN074 (DEV, 0.0, 1, 6)
        NDEV = 0
        NADD = 0
        IF (RCONT(N) .LT. IPR(487) .AND. NRES .GT. 1) NADD = 1
        IF (IPR(32) .NE. 0) THEN
          NLN = 5
          IF (NRES .GT. 1) NLN = NLN + 5
          IF (IGBL(63) .GT. 2) THEN
            CALL PLA269 (NLN)
            IF (NRES .NE. 1) WRITE (LU7, 99993) N
            WRITE (LU7, 99991)
          ENDIF
        ENDIF
        IF (IPR(438) .EQ. 1 .OR. IGBL(31) .EQ. 3) WRITE (LU2, 99992) N
        NRAT = 0
        DO 180 I = 1, NATB
          CALL GEN048 (-6, IFG(I), 9, IRESI)
          IF (N .EQ. IRESI) THEN
            CALL GEN048 (-1, IFG(I), 7, NHAT)
            IF (IGBL(31) .LT. 0) THEN
              IF (NHAT .EQ. 0) THEN
                XI = VOID((I - 1) * (NP4 + 15) + 4)
                YI = VOID((I - 1) * (NP4 + 15) + 5)
                ZI = VOID((I - 1) * (NP4 + 15) + 6)
              ELSE
                GOTO 180
              ENDIF
            ENDIF
            CALL GEN048 (-4, IFG(I), 15, NIEN)
            NIEN  = NIEN + 1
            IF (IGBL(31) .EQ. 3 .AND. IPR(501) .EQ. 0) THEN
              IALIAS = 1
            ELSE
              IALIAS = IGBL(55)
            ENDIF
            CALL PLA036 (-I, 1, 1, IDISD, IDUM1, IDUM2, 0, IALIAS)
            CALL PLA036 (-I, 1, 2, IDISD, IDUM1, IDUM2, 0, IGBL(55))
            IF (NHAT .EQ. 0) THEN
              XPV(1 + NADD) = XPV(1 + NADD) + 1
              IF (IDISD .LT. 1000)
     1          XPV(3 + NADD) = XPV(3 + NADD) + IDISD / 1000.0
            ENDIF
            CALL GEN048 (-1, IFG(I), 4, IVAL)
            IF (IVAL .GT. 0) THEN
              JM = 6
            ELSE
              JM = 1
              CALL GEN048 (-1, IFG(I), 7, IHA)
              IF (IHA .EQ. 0 .AND. I .LE. NAT .AND. IDISD .GT. 500)
     1          IPR(489 + NADD) = IPR(489 + NADD) + 1
            ENDIF
            DO 70 J = 1, JM
              CALL GEN041 (XXO(I, J), XSD(I, J), ISDV(J), 5, NDEC,
     1                    IPR(68))
              ISDV(J) = MIN (99, ISDV(J))
              IF (ISDV(J) .LE. 0) XSD(I, J) = -1.0
              IF (JM .EQ. 1) THEN
                FORMB(15:15) = CHAR(ICHAR('0') + NDEC)
                FORMB(35:35) = CHAR(ICHAR('0') + NDEC)
              ELSE
                IFT = -1 + J * 16
                FORMA(IFT:IFT) = CHAR(ICHAR('0') + NDEC)
              ENDIF
   70       CONTINUE
            DO 80 K = 1, 4
              CALL GEN041 (CON(I, K), CON(I, K + 4), IDUM, IPR(183),
     1                   NDEC, IPR(68))
              IF (1.1 * CON(I, K + 4) .LT. 1.0 / 10 ** IPR(183))
     1           CON(I, K + 4) = -1.0
   80       CONTINUE
            IF (IGBL(31) .EQ. 7) THEN
              IPDB = 1
            ELSE
              IPDB = 0
            ENDIF
            CALL PLA047 (XLAB(I), NQ2, IDUM, JDUM, 0, IGBL(55), IPDB, 0)
            IF (IGBL(31) .EQ. 7) THEN
              DO 90 K = 1, 3
                V1(K) = CON(I, K)
   90         CONTINUE
              CALL GEN002 (1, OR, V1, V3, XLNG)
              IF (NQ2(1:1) .EQ. CHAR(32)) THEN
                NB = 2
                NE = 5
              ELSE
                NB = 1
                NE = 4
              ENDIF
              WRITE (LU2, 99962) I, NQ2(NB:NE), 0, (V3(K), K = 1, 3),
     1                           1.0, 0.0, NQ2(1:2)
            ENDIF
            IF (I .LE. NATC) THEN
              IF (IGBL(31) .LT. 0) THEN
                DO 100 L = 1, IAN
                  IF (IENS(L) .EQ. NIEN) THEN
                    ISCFT = L
                    GOTO 110
                  ENDIF
  100           CONTINUE
  110           POPL = 10.0 + CON(I, 4)
                IF (CON(I, 4) .LT. 0.99) THEN
                  DO 111 K = 1, 3
                    XJX(K) = CON(I, K)
  111             CONTINUE
                  XJX(10) = 0.05
                  CALL SGSM (ICL, 0, XJX, LU6, 19, IERR)
                  DO 112 K = 1, 3
                    CON(I, K) = XJX(6 + K)
  112             CONTINUE
                ENDIF
              ELSE IF (IPR(438) .EQ. 1 .OR. IGBL(31) .EQ. 3) THEN
                DISOR = NAMS(1, 1)(1:1)
                IF (DISOR .NE. ' ') DISOR = 'X'
                IF (IPR(23) .EQ. 0) THEN
                  WRITE (LU2, 99987)
     1                NAMS(1, 1)(2:7), (CON(I, K), K = 1, 8)
                ELSE
                  WRITE (LU2, 99955)
     1                NAMS(1, 1)(2:7), DISOR, (CON(I, K), K = 1, 8)
                ENDIF
              ENDIF
            ENDIF
            IF (JM .GT. 1) THEN
              DO 120 K = 1, 6
                DUMA(K) = XXO(I, K)
  120         CONTINUE
              IF (I .LE. NAT) THEN
                DO 125 K = 1, 6
                  DEV(K) = DEV(K) + DUMA(K)
  125           CONTINUE
                NDEV = NDEV + 1
              ENDIF
              CALL GEN025 (UIJ, DUMA, -1)
              CALL PLA210 (PAR, OR, UIJ, UIJC, DUMA, DUMV, UEQ)
              NRESD = 0
              SUEQ  = 0.0
              DO 130 J = 1, 3
                IF (XSD(I, J) .GT. 0.0) THEN
                  NRESD = NRESD + 1
                  SUEQ = SUEQ + XSD(I, J) ** 2
                ENDIF
  130         CONTINUE
              IF (NRESD .GT. 0) SUEQ = SQRT(SUEQ) / NRESD
              CALL GEN041 (UEQ, SUEQ, ISUEQ, 5, NDEC, IPR(68))
              ISUEQ = MIN (99, ISUEQ)
              FORMA(111:111) = CHAR(ICHAR('0') + NDEC)
              IF (ISUEQ .LE. 0) SUEQ = -1
              IF (DUMA(1) .LT. PAR(12)) THEN
                D13 = -1.0
                NQ3 = 'N.P.D. '
              ELSE
                D13 = DUMA(3) / DUMA(1)
                D21 = DUMA(2) - DUMA(1)
                D32 = DUMA(3) - DUMA(2)
                IF (D32 .LT. D21) THEN
                  NQ3 = 'oblate '
                ELSE
                  NQ3 = 'prolate'
                ENDIF
              ENDIF
              DATC(I) = UEQ
              IF (I .LE. NAT) THEN
                IF (NHAT .EQ. 0) THEN
                  BOK(1, 1) = BOK(1, 1)     + UEQ
                  BOK(1, 2) = MIN (BOK(1, 2), UEQ)
                  BOK(1, 3) = MAX (BOK(1, 3), UEQ)
                  KBO(1, 1) = KBO(1, 1) + 1
                ENDIF
                BOK(NIEN + 1, 1) = BOK(NIEN + 1, 1)     + UEQ
                BOK(NIEN + 1, 2) = MIN (BOK(NIEN + 1, 2), UEQ)
                BOK(NIEN + 1, 3) = MAX (BOK(NIEN + 1, 3), UEQ)
                KBO(NIEN + 1, 1) = KBO(NIEN + 1, 1) + 1
                BOK(NIEN + 1, 5) = MIN (BOK(NIEN + 1, 5), UEQ)
                BOK(NIEN + 1, 6) = MAX (BOK(NIEN + 1, 6), UEQ)
                IF (D13 .GT. 0.0) SQD13 = SQRT(D13)
                ND13     = ' '
                IF (D13 .LE. 0.0 .OR. SQD13 .GT. 2.0) THEN
                  IF (D13 .GT. 9.0 .OR. D13 .LT. 0.0) THEN
                    WRITE (LU6, 99959)
     1              NAMS(1, 1), (DUMA(J), J = 1, 3), D13, NQ3
                    ND13     = '#'
                    IPR(135) = IPR(135) + 1
                  ENDIF
                  IF (D13 .LT. 0) THEN
                    NCOD = 211 + NADD
                    IF (IGBL(22) .NE. -1) WRITE (LU20, 99946)
     1                     NCOD, 1.0, 1.0, NAMS(1, 1)(2:8)
                  ELSE
                    IF (NAMS(1, 1)(1:1) .EQ. '*') THEN
                      NCOD = 215 + NADD
                      IF (IGBL(22) .NE. -1) WRITE (LU20, 99946)
     1                       NCOD, SQD13, SQD13, NAMS(1, 1)(2:8)
                    ELSE
                      NCOD = 213 + NADD
                      IF (IGBL(22) .NE. -1) WRITE (LU20, 99946)
     1                       NCOD, SQD13, SQD13, NAMS(1, 1)(2:8), NQ3
                    ENDIF
                  ENDIF
                ENDIF
                IF (IPR(32) .NE. 0) THEN
                  NRAT = NRAT + 1
                  IF (IGBL(63) .GT. 2) THEN
                    WRITE (PRBUF, FORMA) NRAT, NAMS(1, 2),
     1                (XXO(I, J), ISDV(J), J = 1, 6), UEQ, ISUEQ,
     2                (DUMA(J), J = 1, 3), D13, ND13
                    CALL PLA067 (LU7, PRBUF, 132, 1, 9)
                    CALL GEN025 (UIJC, DUMA, 1)
                    IF (IPR(347) .GT. 0) THEN
                      CALL PLA269 (1)
                      WRITE (LU7, 99972) (DUMA(J), J = 1, 6)
                    ENDIF
                  ENDIF
                ENDIF
              ENDIF
              IF (I .LE. NATC) THEN
                IF (IGBL(31) .LT. 0) THEN
                  WRITE (LU2, 99997) NQ2(1:4), ISCFT,
     1            (CON(I, K), K = 1, 3), CHAR(ICHAR('=')),
     2             POPL, (XXO(I, K), K = 1, 6)
                ELSE IF (IPR(438) .EQ. 1 .OR. IGBL(31) .EQ. 3) THEN
                  WRITE (LU2, 99986) NAMS(1, 1)(2:7),
     1                               (XXO(I, K), K = 1, 6), UEQ
                  WRITE (LU2, 99985) NAMS(1, 1)(2:7),
     1                               (XSD(I, K), K = 1, 6), SUEQ
                ENDIF
              ENDIF
            ELSE IF (JM .EQ. 1) THEN
              DATC(I) = XXO(I, 1)
              IF (I .LE. NATC) THEN
                IF (IGBL(31) .LT. 0) THEN
                WRITE (LU2, 99996) NQ2(1:4), ISCFT,
     1            (CON(I, K), K = 1, 3), POPL, XXO(I, 1)
                ELSE IF (IPR(438) .EQ. 1 .OR. IGBL(31) .EQ. 3) THEN
                  WRITE (LU2, 99988) NAMS(1, 1)(2:7),
     1                                XXO(I, 1), XSD(I, 1)
                ENDIF
              ENDIF
              IF (IPR(32) .NE. 0 .AND. I .LE. NAT) THEN
                NRAT = NRAT + 1
                IF (NHAT .EQ. 0) THEN
                  BOK(1, 1) = BOK(1, 1)     + XXO(I, 1)
                  BOK(1, 2) = MIN (BOK(1, 2), XXO(I, 1))
                  BOK(1, 3) = MAX (BOK(1, 3), XXO(I, 1))
                  KBO(1, 1) = KBO(1, 1) + 1
                ENDIF
                BOK(NIEN + 1, 1) = BOK(NIEN + 1, 1)     + XXO(I, 1)
                BOK(NIEN + 1, 2) = MIN (BOK(NIEN + 1, 2), XXO(I, 1))
                BOK(NIEN + 1, 3) = MAX (BOK(NIEN + 1, 3), XXO(I, 1))
                KBO(NIEN + 1, 1) = KBO(NIEN + 1, 1) + 1
                BOK(NIEN + 1, 5) = MIN (BOK(NIEN + 1, 5), XXO(I, 1))
                BOK(NIEN + 1, 6) = MAX (BOK(NIEN + 1, 6), XXO(I, 1))
                IF (IGBL(63) .GT. 2) THEN
                  WRITE (PRBUF, FORMB) NRAT, NAMS(1, 2),
     1              XXO(I, 1), ISDV(1), XXO(I, 1), ISDV(1)
                  CALL PLA067 (LU7, PRBUF, 132, 1, 1)
                ENDIF
              ENDIF
            ENDIF
            IF (IGBL(31) .LT. 0) THEN
              ISCFT = 0
              DO 135 J = 1, IAN
                IF (IEN(IENS(J)) .EQ. 1) ISCFT = J
  135         CONTINUE
              NCH   = 0
              DO 145 NLP = 1, 2
                IF (NLP .EQ. 2) THEN
                  NM = 3
                  IF (NCH .EQ. 0) THEN
                    GOTO 149
                  ELSE IF (IEN(NIEN) .EQ. 2) THEN
                    CALL GEN048 (-4, IFG(I), 24, IHYB)
                    IF (NCH .EQ. 1) THEN
                      IF (IHYB .EQ. 1) THEN
                        NM = 163
                      ELSE IF (IHYB .EQ. 2) THEN
                        NM = 43
                      ELSE IF (IHYB .EQ. 3) THEN
                        NM = 13
                      ENDIF
                    ELSE IF (NCH .EQ. 2) THEN
                      IF (IHYB .EQ. 2) THEN
                        NM = 93
                      ELSE IF (IHYB .EQ. 3) THEN
                        NM = 23
                      ENDIF
                    ELSE IF (NCH .EQ. 3) THEN
                      IF (IHYB .EQ. 3) THEN
                        NM = 137
                      ENDIF
                    ENDIF
                  ENDIF
                  WRITE (LU2, 99961) NM
                ENDIF
                DO 140 J = 1, NATC
                  CALL GEN048 (-1, IFG(J), 7, JHAT)
                  IF (JHAT .NE. 0) THEN
                    XJ = VOID((J - 1) * (NP4 + 15) + 4)
                    YJ = VOID((J - 1) * (NP4 + 15) + 5)
                    ZJ = VOID((J - 1) * (NP4 + 15) + 6)
                    DIST = SQRT ((XI - XJ)**2 + (YI - YJ)**2
     1                   +       (ZI - ZJ)**2)
                    IF (DIST .LT. 1.2) THEN
                      IF (NLP .EQ. 1) THEN
                        NCH = NCH + 1
                      ELSE
                        YNK = -1.2
                        IF (NM .EQ. 137) YNK = -1.5
                        CALL PLA047 (XLAB(J), NQ3, IDUM, JDUM, 0,
     1                             IGBL(55), IPDB, 0)
                        WRITE (LU2, 99953) NQ3(1:4), ISCFT,
     1                    (CON(J, K), K = 1, 3), 10.0 + CON(J, 4), YNK
                      ENDIF
                    ENDIF
                  ENDIF
  140           CONTINUE
  145         CONTINUE
              WRITE (LU2, 99961) 0
            ENDIF
  149       IF (JM .GT. 1) THEN
              J = IPR(297) + (I - 1) * 21
              DO 150 K = 1, 3
                V8(K) = VOID(J + K + 6)
  150         CONTINUE
              XDUM = SQRT (GEN009 (V8, V8))
              DO 160 K = 1, 3
                V8(K) = V8(K) * (VOID(J + 12) - MAX(VOID(J + 10), 0.0))
     1                / XDUM
  160         CONTINUE
              CALL GEN002 (1, ROR, V8, V6, XLNG)
              J = (I - 1) * (NP4 + 15)
              DO 170 K = 1, 3
                V5(K) = VOID(J + K) - V6(K)
                V8(K) = VOID(J + K) + V6(K)
  170         CONTINUE
              IF (I .LE. NATC .AND. IGBL(63) .GT. 2) THEN
                CALL PLA269 (1)
                WRITE (LU7, 99952) (V5(K), K = 1, 3), (V8(K), K = 1, 3)
              ENDIF
            ENDIF
          ENDIF
  180   CONTINUE
        IF (IPR(32) .NE. 0) THEN
          DO 190 I = 2, IAN + 1
            IF (BOK(I, 5) .GT. 0.0) THEN
              BOK(I, 4) = MIN (9.9999, BOK(I, 6) / BOK(I, 5))
            ELSE
              BOK(I, 4) = 0.0
            ENDIF
            IF (BOK(I, 5) .GT. 1000.0) BOK(I, 5) = 0.0
  190     CONTINUE
          DO 200 I = 1, IAN
            J = IENS(I)
            IF (BOK(J + 1, 4) .GT. 1.5) THEN
              IF (LMT(J, 1) .EQ. ' H' .OR. LMT(J, 1) .EQ. ' D') THEN
                K = 2 + NADD
              ELSE
                K = NADD
              ENDIF
              IF (IGBL(22) .NE. -1) WRITE (LU20, 99945) '_22', K,
     1           BOK(J + 1, 4), BOK(J + 1, 4), LMT(J, 1)
            ENDIF
  200     CONTINUE
        ENDIF
        IF (NDEV .GT. 0) THEN
          DO 205 I = 1, 6
            DEV(I) = DEV(I) / NDEV
  205     CONTINUE
          CALL GEN025 (UIJ, DEV, -1)
          CALL PLA210 (PAR, OR, UIJ, UIJC, DUMA, DUMV, UEQ)
          CALL PLA269 (3)
          RATIO = DUMA(3) / DUMA(1)
          IF (IGBL(63) .GT. 2) WRITE (LU7, 99948) (DEV(K), K = 1, 6),
     1            UEQ, (DUMA(K), K = 1, 3), RATIO
          IF (NDEV .GT. 5 .AND. IGBL(22) .NE. -1)
     1      WRITE (LU20, 99947) '_250', RATIO, RATIO
        ENDIF
  210 CONTINUE
      IF (IPR(32) .NE. 0) THEN
        IF (IGBL(63) .GT. 2) THEN
          CALL PLA269 (15)
          WRITE (LU7, 99983)
          CALL PLA269 (6)
          WRITE (LU7, 99968) (LMT(IENS(I), 1), I = 1, IAN)
          WRITE (LU7, 99967) BOK(1, 1) / MAX (1, KBO(1, 1)),
     1      (BOK(IENS(I) + 1, 1) /
     2      MAX (1, KBO(IENS(I) + 1, 1)), I = 1, IAN)
        ENDIF
        DO 220 I = 1, IAN + 1
          IF (BOK(I, 2) .GT. 0.0) THEN
            BOK(I, 1) = MIN (9.9999, BOK(I, 3) / BOK(I, 2))
          ELSE
            BOK(I, 1) = 0.0
          ENDIF
          IF (BOK(I, 2) .GT. 1000.0) BOK(I, 2) = 0.0
  220   CONTINUE
        IF (IGBL(63) .GT. 2) THEN
          CALL PLA269 (4)
          WRITE (LU7, 99966) BOK(1, 2), (BOK(IENS(I) + 1, 2),
     1                       I = 1, IAN)
          WRITE (LU7, 99965) BOK(1, 3), (BOK(IENS(I) + 1, 3),
     1                       I = 1, IAN)
          WRITE (LU7, 99964) BOK(1, 1), (BOK(IENS(I) + 1, 1),
     1                       I = 1, IAN)
          WRITE (LU7, 99957) KBO(1, 1), (KBO(IENS(I) + 1, 1),
     1                       I = 1, IAN)
        ENDIF
      ENDIF
      IF (IGBL(31) .EQ. -2) THEN
        WRITE (LU2, 99969) (PAR(230 + I), I = 1, 9)
        IF (IPR(209) .GT. 0) THEN
          DO 230 I0 = 1, 12
            IF (LAUEGR .EQ. NLAUE(I0)) GOTO 240
  230     CONTINUE
  240     WRITE (LU2, 99954) (PAR(230 + I), I = 1, 9),
     1      SPGRNM(1)(12:13), I0, SPGRNM(1)(1:7)
        ENDIF
      ENDIF
      IF (IGBL(31) .LT.  0) WRITE (LU2, 99995)
      IF (IGBL(31) .EQ. 3 .AND. IPR(504) .NE. 2) THEN
        WRITE (LU2, 99969) (PAR(230 + I), I = 1, 9)
        IF (IGBL(97) .EQ. 0) THEN
          WRITE (LU2, 99944)
        ELSE
          WRITE (LU2, 99943)
        ENDIF
      ENDIF
      IF (IPR(43) .GT. 0 .AND. IGBL(22) .NE. -1) THEN
        IF (XPV(3) .GT. 0.0)
     1    WRITE (LU20, 99949) '_301', XPV(3) * 100 / XPV(1),
     2                                        XPV(3) * 100 / XPV(1)
        IF (XPV(4) .GT. 0.0)
     1    WRITE (LU20, 99949) '_302', XPV(4) * 100 / XPV(2),
     2                                      XPV(4) * 100 / XPV(2)
      ENDIF
      IF (IPR(504) .EQ. 2) THEN
        WRITE (LU2, 99969) (PAR(I), I = 231, 239)
        IF (IPR(595) .EQ. 0) THEN
          WRITE (LU2, 99956) IPR(209), ' '
        ELSE
          WRITE (LU2, 99956) IPR(209), 'NOSF'
        ENDIF
        CLOSE (LU1)
        CLOSE (LU2, ERR = 250)
  250   CALL PLA280 ('END')
        KXT    = 3
        EXTENS = 'eld'
        FNLU1 = NAME(3)(1:KNM(3))//'.'//EXTENS(1:KXT)
        OPEN (UNIT = LU1, FILE = FNLU1, FORM = 'FORMATTED',
     1         STATUS = 'OLD')
        IPR(3)  = 1
        IGBL(8) = 1
      ENDIF
      IF (IABS(IGBL(8)) .NE. 4 .AND. IGBL(94) .EQ. 0) THEN
        IF (IPR(489) + IPR(490) .GT. 0) THEN
          IF (IPR(489) .GT. 0 .AND. IGBL(22) .NE. -1)
     1      WRITE (LU20, 99950) '_201', IPR(489), IPR(489)
          IF (IPR(490) .GT. 0 .AND. IGBL(22) .NE. -1)
     1      WRITE (LU20, 99950) '_202', IPR(490), IPR(490)
        ENDIF
        IF (IPR(32) .EQ. 0 .AND. IGBL(22) .NE. -1)
     1      WRITE (LU20, 99950) '_210', 1, 1
      ENDIF
      RETURN
99999 FORMAT ('FVAR ', 6F10.5, ' =', 8(/, 5X, 6F10.5, '='))
99998 FORMAT ('TEMP ', I5)
99997 FORMAT (A, I3, 3F9.5, 1X, A, /, 5X, F10.5, 6F9.4)
99996 FORMAT (A, I3, 3F9.5, F10.5, F9.4)
99995 FORMAT ('END')
99994 FORMAT ('SCAT', 16(1X, A))
99993 FORMAT (/, 57X, 13('='), /, 56('*'), ' Residue = ', I3, 1X,
     1 61('*'), /, 57X, 13('=')/)
99992 FORMAT ('RESD ', I5)
99991 FORMAT (132('-'), /, 'Atom  Label', 3X, 'U11 or Uiso', 6X, 'U22',
     1 10X, 'U33', 10X, 'U23', 10X, 'U13', 10X, 'U12', 8X, 'Ueq(sUeq)',
     2 5X, 'U1', 5X, 'U2', 5X, 'U3', 2X, 'U3/U1', /, 132('-'))
99990 FORMAT ('VOLU ', 2F10.3)
99989 FORMAT ('SPGR P1')
99988 FORMAT ('U    ', A, 2F10.5)
99987 FORMAT ('ATOM ', A, 1X, 2(3F9.6, F7.4))
99986 FORMAT ('UIJ  ', A, 1X, 7F9.5)
99985 FORMAT ('SUIJ ', A, 1X, 7F9.5)
99984 FORMAT ('(An)isotropic, Equivalent and Main Axes Displacement ',
     1 'Parameters - Unusual Values Marked with a ', A,
     2 ' - [Optional Coordinate Split-up]', /, 132('-'))
99983 FORMAT (/, 49X, 21('='), /, 38X, 'The Displacement Factor has ',
     1 'the Form of Exp(-T)'//54X, 'where'//29X, 'T = 8*(pi**2)*Uiso*',
     2 'sin(theta/lambda)**2, for Isotropic Atoms,'//2X, 'T = 2*(pi',
     3 '**2)*(U11*(h*as)**2+U22*(k*bs)**2+U33*(l*cs)**2+2*U23*k*l*',
     4 'bs*cs+2*U13*h*l*as*cs+2*U12*h*k*as*bs),for Anisotr. Atoms'//
     5 37X, ' Ueq = 1/3 Sum(i,j) (Uij*as(i)*as(j)*a(i).a(j))',//, 34X,
     6 ' U1, U2, U3 are the three Main Axes Components of Uij', //,
     7 'Reference U(eq): R.X. Fischer & E. Tillmanns, ',
     8 'Acta Cryst. (1988). C44, 775-776')
99982 FORMAT ('TITL ', A)
99981 FORMAT ('SFAC ', A, 7F10.5, ' =', /, 7X, 4F10.5, F10.3, 2F10.5)
99980 FORMAT ('UNIT ', 2I5, 14I4)
99979 FORMAT ('CESD', 9X, 3F10.4, 3F10.3)
99978 FORMAT ('LATT ', A, 2X, A)
99977 FORMAT ('SYMM ', A)
99976 FORMAT ('SPGR ', 5A)
99975 FORMAT ('LATT', I4)
99974 FORMAT ('CELL', F9.5, 3F10.4, 3F10.3)
99973 FORMAT ('TRNS ', 9F8.4, ' = ', /, 5X, 3F8.4)
99972 FORMAT (13X, 6(F13.4))
99971 FORMAT ('ZERR', ' 1', 7X, 3F10.4, 3F10.3)
99970 FORMAT ('NOMOVE')
99969 FORMAT ('HKLF 4 1', 9F8.4)
99968 FORMAT (/, 'Ueq [or U(iso)] Averages per Element', /,
     1        132('-'), /, 10X, 'Non-H', 16(3X, A, 2X))
99967 FORMAT (132('-'), /, 'Average', 1X, 17F7.4)
99966 FORMAT ('Minimum', 1X, 17F7.4)
99965 FORMAT ('Maximum', 1X, 17F7.4)
99964 FORMAT ('Ratio  ', 1X, 17F7.4)
99963 FORMAT ('HEADER', 1X, A, /, 'CRYST1', 3F9.3, 3F7.2, 1X, A, /,
     1        'SCALE1', 4X, 3F10.7, 5X, F10.7, /,
     2        'SCALE2', 4X, 3F10.7, 5X, F10.7, /,
     3        'SCALE3', 4X, 3F10.7, 5X, F10.7)
99962 FORMAT ('ATOM', 2X, I5, 1X, A, 5X, I5, 4X, 3F8.3, 2F6.2, 10X, A)
99961 FORMAT ('AFIX', I5)
99960 FORMAT ('REM RESET CLOSENESS CRITERIUM', /,
     1 'SET PAR 22', F10.3)
99959 FORMAT (':: ADP ', A, 3F8.3, ' - RATIO(MAX/MIN) = ', F8.1, 1X, A)
99958 FORMAT ('W: No Wavelength given, MoKa - assumed for SFAC')
99957 FORMAT ('Number', 2X, 17I7)
99956 FORMAT ('SET IPR 209', I3, /, 'CALC SHELX ', A, /, 'END')
99955 FORMAT ('ATOM ', A, 1X, A, 1X, 3F9.4, F6.3, 3F9.4, F6.2)
99954 FORMAT ('REM TRMX', 9F7.3, 1X, A, I3, /, 'REM SPGR ', A)
99953 FORMAT (A, I3, 5F9.5, F9.3)
99952 FORMAT (15X, '[', F9.4, 2F13.4, ']  [', F9.4, 2F13.4,']')
99951 FORMAT ('SET PAR 2', F6.2)
99950 FORMAT (A, 2I10)
99949 FORMAT (A, 2F10.0)
99948 FORMAT (/, 'U(i,j)-Average', F11.4, 5F13.4, 6X, 4F7.4, F7.2, /)
99947 FORMAT (A, 2F10.2)
99946 FORMAT ('_', I3, 2F10.1, 2A)
99945 FORMAT (A, I1, 2F10.3, A)
99944 FORMAT ('INORGANIC')
99943 FORMAT ('ORGANIC')
99942 FORMAT ('L.S. 5', /, 'ACTA', /, 'BOND $H')
99941 FORMAT ('SFAC', 16(1X, A))
      END
      SUBROUTINE PLA025
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118,
     1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP22=256,
     2 NP25=99,NP29=63,NP38=125,NP39=30,NP41=200,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9),
     1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10),
     2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10),
     3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770)
      COMMON /PL16/ VALI(3), VI(3,3), VT(3,3), XOCG(3), XCG(3), D(3,3),
     1 H(3,3), R(3,3), UC(3,3), UI(3,3), ROL(3), SL(3,3), SO(3,3),
     2 TO(3,3), TW2(3,3), TT2(3,3), SOM(3,3), TOM(3,3), W3D(3),
     3 TOM2(3,3), TTOM2(3,3), TOM3(3), TL(3,3), AO(20), AN(250),
     4 BN(25), AMC(3,3), ALC(3,3), ATC(3,3), ALM(3,3), ATM(3,3),
     5 W1(3,3), W2(3,3), W3(3), S1(3,3), T1(3,3), T2(3,3), T3(3)
       CHARACTER ITLS*1
      IF (IPR(32) .NE. 0 .AND. IPR(5) .NE. 0) THEN
        NMAX    = IPR(39)
        NRES    = IPR(75)
        NSYM    = IPR(48)
        IPR72   = IPR(72)
        IPR(72) = 0
        DO 20 I = 1, NMAX
          DO 10 J = 1, 3
            CALL GEN018 (CON(I, J), XXO(I, J))
            CON(I, J + 3) = XXO(I, J + 3)
   10     CONTINUE
          CALL GEN048 (-4, IFG(I), 15, IVL)
          CON(I, 7) = SATWT(IVL + 1)
          CON(I, 8) = (XSD(I, 1) + XSD(I, 2) + XSD(I, 3)) / 3
          IO = I
          CALL PLA059 (IO, IO)
   20   CONTINUE
        IPR(72) = IPR72
        DO 260 NRS = 1, NRES
          NATR    = 0
          IPR(73) = 1
          IPR(74) = 1
          ITLS    = 'S'
          MULT    = MLTI(NRS)
          DO 40 I = 1, NMAX
            IVL = NP1 + I
            CALL GEN048 (-6, IFG(I), 9, IVAL)
            IF (IVAL .EQ. NRS) THEN
              CALL GEN048 (-1, IFG(I), 4, IVAL)
              IF (IVAL .NE. 0) THEN
                IF (IPR(497) .NE. 0) THEN
                  IVAL = 0
                ELSE
                  CALL GEN048 (-1, IFG(I), 7, IVAL)
                ENDIF
                IF (IVAL .EQ. 0) THEN
                  IVL  = I
                  NATR = NATR + 1
                  CALL PLA047 (XLAB(I), NQ1, IVAL, JDUM, IPR(119),
     1                         IGBL(55), 0, 0)
                  IF (IVAL .NE. 1) THEN
                    IPR(73) = 2
                    IPR(74) = 0
                    ITLS    = ' '
                  ENDIF
                ENDIF
              ENDIF
            ENDIF
            IATP(I) = IVL
   40     CONTINUE
          IF (IPR(32) .NE. 0) THEN
            IF (NATR .LT. IPR(21)) THEN
              WRITE (LU6, 99992) NRS, IPR(21)
            ELSE IF ((NSYM / MULT) * MULT .EQ. NSYM) THEN
              CALL PLA054 (1)
              DO 50 I = 1, 3
                VALI(I)  =  DUMA(I)
                XOCG(I)  =  DXI(I)
                VI(I, 3) =  DUMV(I, 1)
                VI(I, 1) =  DUMV(I, 3)
                VI(I, 2) = -DUMV(I, 2)
                VT(3, I) =  DUMV(I, 1)
                VT(1, I) =  DUMV(I, 3)
                VT(2, I) = -DUMV(I, 2)
   50         CONTINUE
              DO 80 K = 1, NMAX
                IF (IATP(K) .LE. NP1) THEN
                  DO 70 I = 1, 3
                    XXO(K, I) = 0.0
                    DO 60 J = 1, 3
                      XXO(K, I) = XXO(K, I) + (XXO(K, J + 3)
     1                          - XOCG(J)) * VI(J, I)
   60               CONTINUE
   70             CONTINUE
                ENDIF
   80         CONTINUE
              DO 100 I = 1, 3
                DO 90 J = 1, 3
                  IF (I .EQ. J) THEN
                    D(I, I) = PAR(112 + I)
                  ELSE
                    D(I, J) = 0.0
                  ENDIF
   90           CONTINUE
  100         CONTINUE
              CALL GEN004 (VT, OR, H)
              CALL GEN004 (H,  D,  H)
                DO 120 N = 1, NMAX
                IF (IATP(N) .LE. NP1) THEN
                  DO 110 I = 1, 6
                    DUMA(I) = CON(N, I)
  110             CONTINUE
                  CALL GEN025 (UC, DUMA, -1)
                  CALL GEN001 (1, H,  UC,   UI)
                  XSD(N, 1) = UI(1, 1)
                  XSD(N, 2) = UI(1, 2)
                  XSD(N, 3) = UI(1, 3)
                  XSD(N, 4) = UI(2, 2)
                  XSD(N, 5) = UI(2, 3)
                  XSD(N, 6) = UI(3, 3)
                ENDIF
  120         CONTINUE
              CALL GEN074 (BN, 0.0, 1, 20)
              CALL GEN074 (AN, 0.0, 1, 250)
              NN = 12 + IPR(74) * 8
              DO 210 I = 1, NMAX
                IF (IATP(I) .LE. NP1) THEN
                  DO 180 JLOOP = 1, 6
                    J = JLOOP
                    CALL GEN100 (AO, J, XXO(I, 1), XXO(I, 2), XXO(I, 3))
                    M = NN + 1
                    DO 200 N = 1, NN
                      Y     = AO(N)
                      L     = M
                      M     = M + NN - N + 1
                      BN(N) = BN(N) + Y * XSD(I, J)
                      AN(N) = AN(N) + Y**2
                      DO 190 K = N, NN
                        AN(L) = AN(L) + Y * AO(K)
                        L     = L + 1
  190                 CONTINUE
  200               CONTINUE
  180             CONTINUE
                ENDIF
  210         CONTINUE
              IF (IGBL(63) .GT. 2) THEN
                CALL PLA269 (-2)
                WRITE (LU7, 99999)
                IF (NRES .NE. 1) THEN
                  CALL PLA269 (5)
                  WRITE (LU7, 99997) NRS
                ENDIF
              ENDIF
              CALL GEN012 (AN, BN, NN, 0.0, PAR(410), 1.0)
              IF (IGBL(63) .GT. 2) THEN
                CALL PLA269 (4)
                WRITE (LU7, 99996)
              ENDIF
              NNA   = 0
              SUM   = 0.0
              SUM1  = 0.0
              SUMN  = 0.0
              SUMN1 = 0.0
              DELM = 0
              DO 240 I = 1, NMAX
                IF (IATP(I) .LE. NP1) THEN
                  DO 220 JLOOP = 1, 6
                    J       = JLOOP
                    DUMA(J) = - XSD(I, J)
                    SUMN    = SUMN  + DUMA(J)**2
                    SUMN1   = SUMN1 + ABS(DUMA(J))
                    CALL GEN100 (AO, J, XXO(I, 1), XXO(I, 2), XXO(I, 3))
                    DO 230 K = 1, NN
                      DUMA(J) = DUMA(J) + AO(K) * AN(K)
  230               CONTINUE
                    SUM  = SUM  + DUMA(J)**2
                    SUM1 = SUM1 + ABS(DUMA(J))
                    IF (ABS(DUMA(J)) .GT. DELM) DELM = ABS(DUMA(J))
  220             CONTINUE
                  NNA = NNA + 6
                  IF (IGBL(63) .GT. 2) THEN
                    CALL PLA047 (XLAB(I), NQ1, IDUM, JDUM, IPR(119),
     1                           IGBL(55), 0, 0)
                    CALL PLA269 (1)
                    UEQO = (XSD(I, 1) + XSD(I, 4) + XSD(I, 6)) / 3.0
                    UEQC = UEQO + (DUMA(1) + DUMA(4) + DUMA(6)) / 3.0
                    WRITE (LU7, 99995)
     1              NQ1, (XSD(I, K), DUMA(K), K = 1, 6), UEQO, UEQC
                  ENDIF
                ENDIF
  240         CONTINUE
              SIG   = SQRT(SUM / (NNA - IPR(73) * NN))
              RIND1 = SUM1 / SUMN1
              RIND  = SQRT(SUM / SUMN)
              IF (IGBL(63) .GT. 2) THEN
                CALL PLA269 (17)
                WRITE (LU7, 99994) RIND1, RIND, SIG, NATR, IPR(73),
     1            NN, DELM, ITLS
              ENDIF
              DO 250 I = 1, NN
                BN(I) = BN(I) * SIG
  250         CONTINUE
              CALL PLA043 (0, 1, LU7, 0)
              IF (RIND .GT. PAR(34)) THEN
                WRITE (LU6, 99993) NRS, PAR(34)
                IF (IGBL(63) .GT. 2) THEN
                  CALL PLA269 (2)
                  WRITE (LU7, 99993) NRS, PAR(34)
                ENDIF
                CALL PLA027 (0, W1, W2)
              ELSE
                CALL PLA026
                CALL PLA027 (1, W1, W2)
              ENDIF
            ENDIF
          ENDIF
  260   CONTINUE
      ENDIF
      RETURN
99999 FORMAT ('V.Schomaker and K.N.Trueblood Rigid Body Motion',
     1 ' Analysis, TLS - Model   (Acta Cryst. (1968), B24, 63-76)',
     2 '  -  see also Dunitz, p244', /, 132('='))
99997 FORMAT (/, 57X, 13('='), /, 56('*'), ' Residue =', I4, 1X,
     1 61('*'), /, 57X, 13('='), /)
99996 FORMAT ('Vibration Tensor in Inertial System I(1)=L,I(2)=M',
     1 ', I(3)=N (Difference U(calc)-U(obs) in Parentheses)', /,
     2 132('='), /, 'Label     U(L,L)', 12X, 'U(L,M)', 12X, 'U(L,N)',
     3 12X, 'U(M,M)', 12X, 'U(M,N)', 12X, 'U(N,N)', 9X,
     4 'Ueq(obs) Ueq(cal)', /, 132('-'))
99995 FORMAT (A, 6(F9.5, '(', F7.5, ')'), F8.4, F9.4)
99994 FORMAT (//
     1 'R1 = Sum(abs(U(obs)-U(calc)))/Sum(abs(U(obs)))     =', F10.5,//
     2 'R2 = Sqrt(Sum((U(obs)-U(calc))**2)/Sum(U(obs)**2)) =', F10.5,//
     3 'S  = Sqrt(Sum((U(obs)-U(calc))**2)/(6*N-NS*M))     =', F10.5,//
     4 'N  = Number of Atoms in Rigid Group', 16X,        '=', I10  ,//
     5 'NS = Symmetry Factor', 31X, '=', I10, //, 'M  = Number of ',
     6 'Rigid-Body Parameters', 15X, '=', I10, //, 5X,
     7 'Largest abs(U(obs)-U(calc))', 19X, '=', F10.5, //, 54X, 'TL', A,
     8 '-Mode')
99993 FORMAT (/, ':: No TLS-Analysis for Residue Nr:', I3,
     1 ', Because R >', F6.2)
99992 FORMAT (/, ':: No TLS-Analysis for Residue Nr:', I3,
     1 ', Because Number non-H atoms <', I3)
      END
      SUBROUTINE PLA026
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16,
     1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP25=99,NP29=63,
     2 NP38=125,NP39=30,NP41=200,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /PL16/ VALI(3), VI(3,3), VT(3,3), XOCG(3), XCG(3), D(3,3),
     1 H(3,3), R(3,3), UC(3,3), UI(3,3), ROL(3), SL(3,3), SO(3,3),
     2 TO(3,3), TW2(3,3), TT2(3,3), SOM(3,3), TOM(3,3), W3D(3),
     3 TOM2(3,3), TTOM2(3,3), TOM3(3), TL(3,3), AO(20), AN(250),
     4 BN(25), AMC(3,3), ALC(3,3), ATC(3,3), ALM(3,3), ATM(3,3),
     5 W1(3,3), W2(3,3), W3(3), S1(3,3), T1(3,3), T2(3,3), T3(3)
      K = 0
      DO 20 I = 1, 3
        DO 10 J = I, 3
          K = K + 1
          W1(I, J) = AN(K)
          W1(J, I) = AN(K)
          T1(I, J) = AN(K + 6)
          T1(J, I) = T1(I, J)
          S1(I, J) = 0.0
          S1(J, I) = 0.0
   10   CONTINUE
   20 CONTINUE
      BN(21) = 0.0
      IF (IPR(74) .NE. 0) THEN
        S1(1, 1) = AN(13)
        S1(1, 2) = AN(14)
        S1(1, 3) = AN(15)
        S1(2, 1) = AN(16)
        S1(2, 2) = AN(17)
        S1(2, 3) = AN(18)
        S1(3, 1) = AN(19)
        S1(3, 2) = AN(20)
        S1(3, 3) = -AN(13) - AN(17)
        BN(21) = SQRT(BN(13)**2 + BN(17)**2)
      ENDIF
      CALL GEN024 (W1, W2, W3, TW2)
      CALL GEN024 (T1, T2, T3, TT2)
      CALL GEN004 (VT, OR, AMC)
      CALL GEN004 (W2, VT, ALC)
      CALL GEN004 (ALC, OR, ALC)
      CALL GEN002 (1, ROR, XOCG, XCG, XLNG)
      CALL GEN001 (1, W2, S1, SL)
      CALL GEN001 (1, W2, T1, TL)
      ROL(1) = (SL(2, 3) - SL(3, 2)) / (W3(2) + W3(3))
      ROL(2) = (SL(3, 1) - SL(1, 3)) / (W3(3) + W3(1))
      ROL(3) = (SL(1, 2) - SL(2, 1)) / (W3(1) + W3(2))
      R(1, 1) =   0.0
      R(1, 2) =   ROL(3)
      R(1, 3) = - ROL(2)
      R(2, 1) = - ROL(3)
      R(2, 2) =   0.0
      R(2, 3) =   ROL(1)
      R(3, 1) =   ROL(2)
      R(3, 2) = - ROL(1)
      R(3, 3) =   0.0
      DO 80 N = 1, 3
        DO 70 I = 1, 3
          SO(N, I) = R(I, N) * W3(N) + SL(N, I)
   70   CONTINUE
   80 CONTINUE
      DO 110 I = 1, 3
        DO 100 L = 1, 3
          TO(I, L) = 0.0
          DO 90 J = 1, 3
            TO(I, L) = TO(I, L) + R(I, J) * R(L, J) * W3(J)
     1               + R(I, J) * SL(J, L) + R(L, J) * SL(J, I)
   90     CONTINUE
          TO(I, L) = TO(I, L) + TL(I, L)
  100   CONTINUE
  110 CONTINUE
      CALL GEN001 (1, TW2, TO, TOM)
      CALL GEN001 (1, TW2, SO, SOM)
      CALL GEN024 (TOM, TOM2, TOM3, TTOM2)
      CALL GEN004 (TOM2, VT, ATC)
      CALL GEN004 (ATC, OR, ATC)
      DO 130 I = 1, 3
        W3D(I) = W3(I) * GL(5)**2
        DO 120 J = 1, 3
          AMCIJ = AMC(I, J) / PAR(100 + J)
          IF (ABS(AMCIJ) .GT. 1.0) AMCIJ = SIGN(1.0, AMCIJ)
          AMC(I, J) = ACOS(AMCIJ) * GL(5)
          ALCIJ = ALC(I, J) / PAR(100 + J)
          IF (ABS(ALCIJ) .GT. 1.0) ALCIJ = SIGN(1.0, ALCIJ)
          ALC(I, J) = ACOS(ALCIJ) * GL(5)
          ATCIJ = ATC(I, J) / PAR(100 + J)
          IF (ABS(ATCIJ) .GT. 1.0) ATCIJ = SIGN(1.0, ATCIJ)
          ATC(I, J) = ACOS(ATCIJ) * GL(5)
          ALM(I, J) = ACOS(W2(I, J)) * GL(5)
          ATM(I, J) = ACOS(TOM2(I, J)) * GL(5)
  120   CONTINUE
  130 CONTINUE
      TRSO = T3(1)   + T3(2)   + T3(3)
      TRSN = TOM3(1) + TOM3(2) + TOM3(3)
      DO 140 I = 1, 21
        IF (ABS(BN(I)) .GT. 0.99999) BN(I) = 0.999989
  140 CONTINUE
      IF (IGBL(63) .GT. 2) THEN
        CALL PLA269 (0)
        WRITE (LU7, 99999) (I, (VT(I, J), J = 1, 3), VALI(I),
     1        (AMC(I, J), J = 1, 3), CHAR(ICHAR('W') + I), XCG(I),
     2         I = 1, 3)
        WRITE (LU7, 99998) (W1(1, J), BN(J), J = 1, 3),
     1   (W2(1, J), J = 1, 3), W3(1), W3D(1), (W1(2, J),
     2   BN(J + 2), J = 2, 3), (W2(2, J), J = 1, 3), W3(2), W3D(2),
     3   W1(3, 3), BN(6), (W2(3, J), J = 1, 3), W3(3), W3D(3)
        WRITE (LU7, 99997) T1(1, 1), BN(7), T1(1, 2), BN(8), T1(1, 3),
     1   BN(9), (T2(1, J), J = 1, 3), T3(1), T1(2,2), BN(10), T1(2, 3),
     2   BN(11), (T2(2, J), J = 1, 3), T3(2), T1(3, 3), BN(12),
     3   (T2(3, J), J = 1, 3), T3(3)
        IF (IPR(74) .NE. 0) THEN
          WRITE (LU7, 99996) S1(1, 1), BN(13), S1(1, 2), BN(14),
     1     S1(1, 3), BN(15), S1(2, 1), BN(18), S1(2, 2), BN(17),
     2     S1(2, 3), BN(18), S1(3, 1), BN(19), S1(3, 2), BN(20),
     3     S1(3, 3), BN(21)
          WRITE (LU7, 99995) TRSO, TRSN
          WRITE (LU7, 99994) (I, ROL(I), (SOM(I, J), J = 1, 3),
     1     (TOM(I, J), J = 1, 3), I, (TOM2(I, J), J = 1, 3),
     2      TOM3(I), I = 1, 3)
        ENDIF
        WRITE (LU7, 99993)
        WRITE (LU7, 99992) (I, (ALM(I, J), J = 1, 3),
     1                     (ALC(I, J), J = 1, 3), I = 1, 3)
        WRITE (LU7, 99991)
        WRITE (LU7, 99990) (I, (ATM(I, J), J = 1, 3),
     1                     (ATC(I, J), J = 1, 3), I = 1, 3)
      ENDIF
      RETURN
99999 FORMAT ('Inertial Tensor I, Eigenvectors and Eigenvalues ',
     1 'of I in the Cartesian XO,YO,ZO System and Angular Relation',
     2 ' with X,Y,Z System', /, 132('-'), /, 15X, 'XO', 8X, 'YO',
     3 8X, 'ZO', 10X, 'Value', 14X, 'X', 9X, 'Y', 9X, 'Z', 5X, 'Origin',
     4 ' (Mass-Weighted)', /, 132('-'), /, 3('I(', I1, ')', 3X,
     5 3F10.5, 5X, F10.2, 6X, 3F10.2, 3X, A, ' =', F9.5, /))
99998 FORMAT ('Librational Tensor, L(rad**2)', 25X, 'Eigenvectors ',
     1 'and Eigenvalues of L in the Inertial System XI,YI,ZI', /,
     2 132('-'), /, 66X, 'XI', 8X, 'YI', 8X, 'ZI', 9X, 'rad**2', 4X,
     3 'deg**2', /, 132('-'), /, F7.5, '(', F6.5, ')', F8.5, '(',
     4 F6.5, ')', F8.5, '(', F6.5, ')', 7X, 'L(1)', 3F10.5, 5X, F10.5,
     5 F10.2, /, 15X, F8.5, '(', F6.5, ')', F8.5, '(', F6.5, ')', 7X,
     6 'L(2)', 3F10.5, 5X, F10.5, F10.2, /, 31X, F8.5, '(', F6.5, ')',
     7 7X, 'L(3)', 3F10.5, 5X, F10.5, F10.2, /)
99997 FORMAT ('Translational Tensor, T(ang**2)', 23X, 'Eigenvectors',
     1 ' and Eigenvalues of T in the Inertial System XI,YI,ZI', /,
     2 132('-'), /, 66X, 'XI', 8X, 'YI', 8X, 'ZI', 9X, 'Ang^2', /,
     3 132('-'), /, F7.5, '(', F6.5, ')', F8.5, '(', F6.5, ')', F8.5,
     4 '(', F6.5, ')', 7X, 'T(1)', 3F10.5, 5X, F10.5, /, 15X, F8.5,
     5 '(', F6.5, ')', F8.5, '(', F6.5, ')', 7X, 'T(2)', 3F10.5, 5X,
     6 F10.5, /, 31X, F8.5, '(', F6.5, ')', 7X, 'T(3)', 3F10.5, F15.5/)
99996 FORMAT ('Cross Tensor, S(rad*Ang)', /, 132('-'), /, 3(F8.5, '(',
     1 F6.5, ')')/3(F8.5, '(', F6.5, ')')/3(F8.5, '(', F6.5, ')')/)
99995 FORMAT ('Calculation of the Origin Shift that Symmetrizes S',
     1 23X, '-  Trace old-T = ', F10.5, 7X, 'Trace new-T = ', F10.5, /,
     2 132('-'), /, 'Shift Origin in I', 17X, 'New S-Tensor', 17X,
     3 'New T-Tensor', 8X, 'Eigenvectors and Values of New-T in ',
     4 'I-System', /, 132('-'))
99994 FORMAT ('Rol(', I1, ')', F10.5, 3X, 3F10.5, 3X, 3F10.5, 1X,
     1 'New T(', I1, ')', 3F9.5, 4X, F9.5)
99993 FORMAT (/20X, 'Angular Relationships (Degrees)', /, 20X, 31('='))
99992 FORMAT ('Libration Axes', 4X, '-', 5X, 'Inertial  Axes', 6X,
     1 'Libration Axes - Crystal Axes', /, 73('-'), /, 20X, 'XI',
     2 6X, 'YI', 6X, 'ZI', 17X, 'X', 7X, 'Y', 7X, 'Z', /,
     3 3('L(', I1, ')', 10X, 3F8.2, 10X, 3F8.2, /))
99991 FORMAT ('Translation Axes   -    Inertial  Axes', 4X,
     1 'Translation Axes - Crystal Axes', /, 73('-'), /, 20X,
     2 'XI', 6X, 'YI', 6X, 'ZI', 17X, 'X', 7X, 'Y', 7X, 'Z')
99990 FORMAT ('New T(', I1, ')', 6X, 3F8.2, 10X, 3F8.2)
      END
      SUBROUTINE PLA027 (MODE, W, W2)
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118,
     1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP22=256,
     2 NP25=99,NP29=63,NP38=125,NP39=30,NP41=200,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9),
     1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10),
     2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10),
     3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770)
      DIMENSION W(3, 3), WO(3, 3), DY(3), Z(3), W2(3, 3), ANGL(3)
      CHARACTER XMRK*1
      NMAX = IPR(39)
      IF (MODE .NE. 0) THEN
        TRACE = W(1, 1) + W(2, 2) + W(3, 3)
        DO 20 I = 1, 3
          DO 10 J = 1, 3
            IF (I .EQ. J) THEN
              TADD = TRACE
            ELSE
              TADD = 0.0
            ENDIF
            WO(I, J) = (TADD - W(I, J)) / 2
   10     CONTINUE
   20   CONTINUE
      ELSE
        CALL GEN074 (ANGL, 0.0, 1, 3)
        CALL GEN074 (DY,   0.0, 1, 3)
      ENDIF
      IF (IGBL(63) .GT. 2) THEN
        CALL PLA269 (-7)
        WRITE (LU7, 99995)
        WRITE (LU7, 99994)
      ENDIF
      DELIJ = 0
      NRB   = 0
      NATR  = 0
      DO 90 I = 1, NMAX
        CALL GEN048 (-6, IFG(I), 9, IVAL)
        NADD = 0
        IF (RCONT(IVAL) .LT. IPR(487) .AND. IPR(75) .GT. 1) NADD = 1
        CALL GEN048 (-1, IFG(I), 19, IVALI)
        IF (IATP(I) .LE. NP1) THEN
          CALL PLA047 (XLAB(I), NQ1, IDUM, IENI, IPR(119), IGBL(55),
     1                 0, 0)
          RVLI   = REL(IENI)
          IATPRI = IATPR(IENI)
          NR1    = IATNR(IENI)
          NATR = NATR + 1
          DO 80 J = I, NMAX
            IF (I .NE. J .AND. IATP(J) .LE. NP1) THEN
              CALL PLA047 (XLAB(J), NQ2, IDUM, IENJ, IPR(119),
     1                     IGBL(55), 0, 0)
              IATPRJ = IATPR(IENJ)
              CALL GEN048 (-1, IFG(J), 31, IVAL)
              IF (IATPRI * IVAL .GT. 0) GOTO 80
              NR2  = IATNR(IENJ)
              IF (IATPRI .GT. 0 .AND. IATPRJ .GT. 0) THEN
                DMAX = 2.0
              ELSE
                DMAX = RVLI + REL(IENJ) + PAR(2)
              ENDIF
              S = 0.0
              DO 30 K = 1, 3
                DXI(K) = XXO(I, K) - XXO(J, K)
                S      = S + DXI(K)**2
   30         CONTINUE
              S = SQRT(S)
              IF (S .GT. 0.001 .AND. S .LT. DMAX) THEN
                SC = 0.0
                IF (MODE .NE. 0) CALL GEN002 (1, WO, DXI, DY, XLNG)
                DO 40 K = 1, 3
                  IF (MODE .NE. 0) THEN
                    Z(K)   = DXI(K) + DY(K)
                    SC     = SC + Z(K)**2
                  ENDIF
                  DXI(K) = DXI(K) / S
   40           CONTINUE
                IF (MODE .NE. 0) THEN
                  CALL GEN002 (1, W2, DXI, ANGL, XLNG)
                  DO 50 K = 1, 3
                    ANGL(K) = ACOS(ANGL(K)) * GL(5)
   50             CONTINUE
                  SC = SQRT(SC)
                ENDIF
                VI = 0.0
                VJ = 0.0
                DO 70 K = 1, 3
                  DO 60 L = 1, 3
                    M = K * L
                    IF (M .EQ. 6) M = 5
                    IF (M .EQ. 9) M = 6
                    VI = VI + DXI(K) * XSD(I, M) * DXI(L)
                    VJ = VJ + DXI(K) * XSD(J, M) * DXI(L)
   60             CONTINUE
   70           CONTINUE
                ISVI  = MAX (0, MIN (999, NINT(CON(I, 8) * 10000.0)))
                ISVJ  = MAX (0, MIN (999, NINT(CON(J, 8) * 10000.0)))
                DIJ   = ABS(VI - VJ)
                XMRK  = ' '
                IF (ISVI .GT. 0 .AND. ISVJ .GT. 0) THEN
                  IDIJ  = MIN (999, NINT(SQRT(CON(I, 8)**2 +
     1                         CON(J, 8)**2) * 10000.0))
                  THIRSH =  DIJ * 10000.0 / IDIJ
                  IF (THIRSH .GT. PAR(431)) XMRK = '#'
                ELSE
                  IDIJ = 0
                ENDIF
                DELIJ = DELIJ + DIJ**2
                NRB   = NRB + 1
                SDIJ  = SQRT(DIJ)
                IF (I .LE. IPR(37)) THEN
                  CALL GEN048 (-1, IFG(I), 6, IGEN)
                  IF (IGEN .EQ. 1) THEN
                    JUNK = IPR(37)
                  ELSE
                    JUNK = IPR(39)
                  ENDIF
                  IF (J .LE. JUNK .AND. NR2 .LE. NR1) THEN
                    IF (IGBL(63) .GT. 2) THEN
                      WRITE (PRBUF, 99993) NQ1, NQ2, S, SC, DY, VI,
     1                  ISVI, VJ, ISVJ, DIJ, IDIJ, XMRK, SDIJ, ANGL
                      CALL PLA067 (LU7, PRBUF, 132, 1, 3)
                    ENDIF
                    IF (IDIJ .NE. 0) THEN
                      IF (THIRSH .GT. PAR(431)) WRITE (LU6, 99991)
     1                  NQ1, NQ2, THIRSH
                      IF (THIRSH .GT. 2.0) THEN
                        CALL GEN048 (-1, IFG(J), 19, IVALJ)
                        NAD = NADD + 2 * MAX (IVALI, IVALJ)
                        WRITE (LU20, 99990)
     1                    '_23', NAD, THIRSH, THIRSH, NQ1, NQ2
                      ENDIF
                    ENDIF
                  ENDIF
                ENDIF
              ENDIF
            ENDIF
   80     CONTINUE
        ENDIF
   90 CONTINUE
      IF (NRB .GT. 0) DELIJ = SQRT(DELIJ / NRB)
      IF (IGBL(63) .GT. 2) THEN
        CALL PLA269 (5)
        WRITE (LU7, 99992) DELIJ, PAR(431)
      ENDIF
      IF (NATR .LE. 40) THEN
        IF (IGBL(63) .GT. 2) THEN
          CALL PLA269 (0)
          CALL PLA269 (5)
          WRITE (LU7, 99999) (J, J = 1, NATR)
          WRITE (LU7, 99998)
        ENDIF
        N0 = 0
        DO 160 I = 1, NMAX
          IF (IATP(I) .LE. NP1) THEN
            CALL PLA047 (XLAB(I), NQ1, IDUM, IENI, IPR(119),
     1        IGBL(55), 0, 0)
            RVLI = REL(IENI)
            N0 = N0 + 1
            N  = 0
            DO 150 J = 1, NMAX
              IF (IATP(J) .LE. NP1) THEN
                CALL GEN048 (-4, IFG(J), 15, IVLJ)
                DMAX = RVLI + REL(IEN(IVLJ + 1)) + PAR(2)
                S = 0
                V = 0
                IF (I .NE. J) THEN
                  DO 100 K = 1, 3
                    DXI(K) = XXO(I, K) - XXO(J, K)
                    S      = S + DXI(K)**2
  100             CONTINUE
                  S = SQRT(S)
                  V = S
                  IF (I .LT. J .AND. S .GT. 0.001) THEN
                    DO 110 K = 1, 3
                      DXI(K) = DXI(K) / S
  110               CONTINUE
                    V = 0
                    DO 130 K = 1, 3
                      DO 120 L = 1, 3
                        M = K * L
                        IF (M .EQ. 6) M = 5
                        IF (M .EQ. 9) M = 6
                        V = V + DXI(K) * XSD(I, M) * DXI(L)
     1                    - DXI(K) * XSD(J, M) * DXI(L)
  120                 CONTINUE
  130               CONTINUE
                    V = V * 1000.0
                  ENDIF
                ENDIF
                N = N + 1
                IATC(N) = MIN (99, NINT(ABS(V)))
                IF (S .LT. DMAX) IATC(N) = -IATC(N)
              ENDIF
  150       CONTINUE
            IF (IGBL(63) .GT. 2) THEN
              CALL PLA269 (1)
              WRITE (LU7, 99997) N0, NQ1(1:6), (IATC(K), K = 1, N)
            ENDIF
          ENDIF
  160   CONTINUE
        IF (IGBL(63) .GT. 2) THEN
          CALL PLA269(8)
          WRITE (LU7, 99996)
        ENDIF
      ENDIF
      RETURN
99999 FORMAT ('Test Matrix for Rigid-Body Vibrations - /Del(A,B)/ = ',
     1 '/Z(A,B)**2 - Z(B,A)**2/ Should be Near Zero (Acta Cryst A34,',
     2 '1978,828)', /, 132('='), //, 'Atom-Atom   ', 40I3)
99998 FORMAT (132('-'))
99997 FORMAT (I2, 1X, A, ' - ', 40I3)
99996 FORMAT (/, 'Remarks', /, 7('-'), /, '- Upper Triangle Entries ',
     1 'Represent /Del(A,B)/*1000 Values'//'- Lower Triangle Entries ',
     2 'Represent Distances (A-B) Angstrom'//'- Negative Entries ',
     3 'Indicate Bonded Atoms')
99995 FORMAT ('Rigid-Body Model Libration Corrections for Bond',
     1 ' Distances and "Hirshfeld Rigid-Bond" Test (Acta Cryst,(1976),',
     2 'A32,239-244)', /, 132('=')/)
99994 FORMAT (5X, 'Bond', 11X, 'Bond Distance   Components of the',
     1 ' Correction  Vibration Along the Interatomic Bond', 8X,
     2 'Angle with Lib. Axes', //, 'Atom(I)  Atom(J)', 6X, 'Obsd  ',
     3 '   Calcd', 4X, 'Del(L)  Del(M)  Del(N)', 4X, 'I to J', 6X,
     4 'J to I', 5X, 'Difference', 1X, 'Sqrt(Diff)    L(1)   L',
     5 '(2)   L(3)', /, 132('-'))
99993 FORMAT (A, '- ', A, 2F10.4, 2X, 3F8.4, 1X, 3(F6.4, '(',
     1 I3, ')', 1X), A, F9.4, 2X, 3F7.2)
99992 FORMAT (/, 59X , 'Sqrt(Sum(DelIJ**2)/Nrb) = ', F10.4, //,
     1 30X, '# - Indicates bonds exceeding the', F4.1,
     2 ' sigma test level')
99991 FORMAT (':: ', A, '-', A, 'fails Hirshfeld Rigid Bond test at',
     1 F6.2, ' sigma level')
99990 FORMAT (A, I1, 2F10.3, 2A)
      END
      SUBROUTINE PLA028 (NLT, NLTX, NEWLAT, NLTMAX)
      COMMON /LATICE/ TRNSX(3, 3, 128), ROT(3, 5, 5), TRDAT(3, 3, 8)
      DIMENSION NEWLAT(*), A(3, 20), B(3, 3), C(3, 3), NA(3)
      NLTX = 0
      IF (NLT .LE. NLTMAX - 3) THEN
        CALL GEN022 (NEWLAT, 1, NLT)
        L = 0
        NEWLAT(NLT + 1) = 240000
        NEWLAT(NLT + 2) = 2400
        NEWLAT(NLT + 3) = 24
        DO 20 I = 1, NLT + 3
          L     = L + 1
          NA(3) = NEWLAT(I)
          NA(1) = NA(3) / 10000
          NA(2) = NA(3) - NA(1) * 10000
          NA(3) = MOD(NA(2), 100)
          NA(2) = NA(2) / 100
          DO 10 J = 1, 3
            IF (NA(J) .GT. 12 .AND. NA(J) .LT. 24)
     1          NA(J) = NA(J) - 24
            A(J, L) = FLOAT(NA(J)) / 24.0
   10     CONTINUE
          IF (NEWLAT(I) .EQ. 121200) THEN
            L       = L + 1
            A(1, L) =   A(1, L - 1)
            A(2, L) = - A(2, L - 1)
            A(3, L) =   0.0
          ELSE IF (NEWLAT(I) .EQ. 1212) THEN
            L       = L + 1
            A(1, L) =   0.0
            A(2, L) =   A(2, L - 1)
            A(3, L) = - A(3, L - 1)
          ELSE IF (NEWLAT(I) .EQ. 120012) THEN
            L       = L + 1
            A(1, L) =   A(1, L - 1)
            A(2, L) =   0.0
            A(3, L) = - A(3, L - 1)
          ENDIF
   20   CONTINUE
        DO 100 I = 1, L - 2
          DO 30 N = 1, 3
            B(1, N) = A(N, I)
   30     CONTINUE
          DO 90 J = I + 1, L - 1
            DO 40 N = 1, 3
              B(2, N) = A(N, J)
   40       CONTINUE
            DO 80 K = J + 1, L
              DO 50 N = 1, 3
                B(3, N) = A(N, K)
   50         CONTINUE
              CALL GEN003 (B, C, DET, 0)
              IF (DET .NE. 0.0) THEN
                IF (NINT(1.0 / ABS(DET)) .EQ. NLT + 1) THEN
                  DO 70 N = 1, 3
                    IF (N .EQ. 1 .AND. DET .LT. 0.0) THEN
                      IS = -1
                    ELSE
                      IS = 1
                    ENDIF
                    DO 60 M = 1, 3
                      TRNSX(N, M, 128) = B(N, M) * IS
   60               CONTINUE
   70             CONTINUE
                  NLTX = 128
                  GOTO 110
                ENDIF
              ENDIF
   80       CONTINUE
   90     CONTINUE
  100   CONTINUE
      ENDIF
  110 RETURN
      END
      SUBROUTINE PLA029
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16,
     1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NPVD=40000000,
     2 NP22=256,NP23=18000,NP25=99,NP29=63,NP38=125,NP39=30,NP41=200,
     3 NP45=2048,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /Q/ ICL, IFL(NP17)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON // JNSC(2, NP23), VOID(NPVD)
      COMMON /ISCR/ RIK(3, 3), UKL(3, 3), INSCR(3)
      CALL GEN074 (UIJC, 0.0, 1, 9)
      NAT  = IPR(37)
      NATB = IPR(39)
      IPR(297) = NP1 * (NP4 + 15)
      IPR(298) = IPR(297) + NP1 * 21
      CALL PLA034 (1, NATB)
      WRITE (LU4) 6, (FN(K), K = 1, 9)
      CALL GEN108 (LU4, 0)
   10 READ (LU4) ICT, XNQNR, (FN(K), K = 1, 8)
      IF (ICT .NE. 6) THEN
        DO 50 I = 1, NAT
          IF (NINT(XLAB(I)) .EQ. NINT(XNQNR)) THEN
            IF (MOD(ICT, 10) .EQ. 1) THEN
              IF (FN(4) .GT. 0.0) THEN
                JM = 4
              ELSE
                JM = 3
              ENDIF
              DO 20 J = 1, JM
                CON(I, J) = FN(J)
                FNJP4 = FN(J + 4)
                IF (FNJP4 .LT. 0.0) FNJP4 = 0.0
                CON(I, J + 4) = FNJP4
   20         CONTINUE
              IF (ICT .EQ. 1) THEN
                XXO(I, 1) = 0.0
                XSD(I, 1) = 0.0
              ENDIF
            ELSE IF (ICT .EQ. 2) THEN
              DO 30 J = 1, 6
                XXO(I, J) = FN(J)
                XSD(I, J) = 0.0
   30         CONTINUE
              CALL GEN048 (1, IFG(I), 4, 1)
            ELSE IF (ICT .EQ. 3) THEN
              DO 40 J = 1, 6
                IF (FN(J) .GT. 0.0) XSD(I, J) = FN(J)
   40         CONTINUE
            ELSE IF (ICT .EQ. 4) THEN
              XXO(I, 1) = FN(1)
              IF (FN(2) .LE. 0.0) FN(2) = 0.0
              XSD(I, 1) = FN(2)
            ELSE
              N = NINT(FN(1))
              LRT = 1
              GOTO 90
            ENDIF
            GOTO 10
          ENDIF
   50   CONTINUE
        GOTO 10
      ENDIF
      I = NAT
   60 I = I + 1
      IF (I .GT. NATB) GOTO 160
      XLABM = - XLAB(I)
      CALL PLA047 (XLABM, NQ1, MNM, JDUM, IPR(119), IGBL(55), 0, 0)
      CALL GEN098 (MOL(MNM), PAR(42), N, MT1, MT2, MT3, MR1)
      FN(2) = MT1
      FN(3) = MT2
      FN(4) = MT3
      CALL PLA046 (2, NQ1, IENM, LBB, LBC, LBD, XLMP, YNQNR, J)
      IF (J .LT. 0) THEN
        WRITE (LU6, '(//, ''Label Problem #'', I3, '' for '', A)')
     1          J, NQ1
        CALL PLA004 (0)
        GOTO 160
      ENDIF
      DO 70 K = 1, NP4
        CON(I, K) = CON(J, K)
   70 CONTINUE
      DO 80 K = 1, 6
        XXO(I, K) = XXO(J, K)
        XSD(I, K) = XSD(J, K)
   80 CONTINUE
      CALL GEN048 (-1, IFG(J), 4, IVAL)
      CALL GEN048 ( 1, IFG(I), 4, IVAL)
      LRT = 2
   90 DO 100 J = 1, 3
        XJX(J)     = CON(I, J)
        XJX(J + 3) = FN(J + 1)
  100 CONTINUE
      CALL SGSM (ICL, N, XJX, LU7, 3, IERR)
      DO 110 J = 1, 3
        CON(I, J)  = XJX(J + 6)
        XJX(J)     = CON(I, J + 4)
        XJX(J + 3) = 0.0
  110 CONTINUE
      CALL SGSM (ICL, -N, XJX, LU7, 3, IERR)
      DO 120 J = 1, 3
        CON(I, J + 4) = XJX(J + 6)
  120 CONTINUE
      CALL GEN048 (-1, IFG(I), 4, IVAL)
      IF (IVAL .GT. 0) THEN
        IF (N .GT. 0) THEN
          CALL SGSM (ICL, N, XJX, LU7, 6, IERR)
          DO 130 K = 1, 9
            K0 = MOD (K - 1, 3) + 1
            K1 = ((K - 1) / 3)  + 1
            RIK(K0, K1) = XJX(K)
  130     CONTINUE
          CALL GEN005 (RIK, RIK)
          DO 140 K = 1, 6
            DUMA(K) = XXO(I, K)
  140     CONTINUE
          CALL GEN025 (UKL, DUMA, -1)
          CALL GEN001 (1, RIK, UKL, UIJ)
          CALL GEN025 (UIJ, DUMA, 1)
          DO 150 K = 1, 6
            XXO(I, K) = DUMA(K)
  150     CONTINUE
        ENDIF
      ENDIF
      IF (LRT .EQ. 1) THEN
        GOTO 10
      ELSE IF (LRT .EQ. 2) THEN
        GOTO 60
      ENDIF
  160 DO 230 I = 1, NP1
        CALL GEN048 (-1, IFG(I), 7, IHAT)
        CALL GEN048 (-1, IFG(I), 4, IVAL)
        IF (I .LE. NATB) THEN
          IF (XXO(I, 1) .LE. 0.0 .AND. IVAL .EQ. 0) THEN
            IF (IHAT .EQ. 0) THEN
              XXO(I, 1) = PAR(30)
              IPR(171)  = IPR(171) + 1
            ELSE
              XXO(I, 1) = PAR(30)
              IPR(172)  = IPR(172) + 1
            ENDIF
          ENDIF
          IF (IVAL .NE. 0) THEN
            DO 170 K = 1, 6
              DUMA(K) = XXO(I, K)
  170       CONTINUE
            CALL GEN025 (UIJ, DUMA, -1)
          ELSE
            UIJ(1, 1) = XXO(I, 1)
          ENDIF
        ELSE
          IVAL      = 0
          IHAT      = 0
          UIJ(1, 1) = - 0.1
        ENDIF
        IF (IVAL .EQ. 0) THEN
          T1 = UIJ(1, 1)
          IF (IPR(32) .EQ. 0 .OR. T1 .LE. 0 .OR. IHAT .EQ. 1) THEN
            IF (IHAT .EQ. 1) THEN
              T1 = PAR(265)
            ELSE
              T1 = PAR(266)
            ENDIF
          ELSE
            T1 = SQRT(T1)
          ENDIF
          DO 190 J = 1, 3
            DUMA(J) = T1
            DO 180 K = 1, 3
              DAM(J, K) = ROR(J, K)
              IF (J .EQ. K) THEN
                UIJC(J, K) = T1
              ELSE
                UIJC(J, K) = 0.0
              ENDIF
  180       CONTINUE
  190     CONTINUE
        ELSE
          CALL PLA210 (PAR, OR, UIJ, UIJC, DUMA, PAT, T1)
          CALL GEN019 (AA, BB, PAT(1, 1), PAT(1, 3), DAM(1, 1), -1)
          DO 200 J = 1, 3
            T2      = DUMA(J)
            DUMA(J) = SIGN(SQRT(ABS(T2)), T2)
  200     CONTINUE
        ENDIF
        DO 210 J = 1, 9
          K0 = MOD(J - 1, 3) + 1
          K1 = ((J - 1) / 3) + 1
          VOID(IPR(297) + I * 21 + J - 21) = DAM(K0, K1)
          VOID(IPR(297) + I * 21 + J -  9) = UIJC(K0, K1)
  210   CONTINUE
        DO 220 J = 1, 3
          VOID(IPR(297) + I * 21 + J - 12) = DUMA(J)
  220   CONTINUE
  230 CONTINUE
      IF (IPR(14) .EQ. 0 .OR. IPR(14) .EQ. 4 .OR.
     1    IPR(14) .EQ. 6) THEN
        CALL PLA024
        IF (IPR(504) .EQ. 0 .AND. IGBL(22) .NE. -1) THEN
          IF (IPR(14) .NE. 6) THEN
            IF (IPR(322) .EQ. 0 .AND. IPR(43) .EQ. 0) THEN
              CALL PLA025
            ELSE
              CALL PLA015 (0, 43)
              WRITE (LU6, 99999)
            ENDIF
          ENDIF
        ENDIF
      ENDIF
      CALL PLA034 (-1, NATB)
      IPR(85) = 1
      RETURN
99999 FORMAT (/,
     1      ':: No TLS-Analysis for Polymeric or Disordered Structures')
      END
      SUBROUTINE PLA030 (XXO, CON, NT, IFG, JFG, IPPR, BOND)
      PARAMETER (NP1=7000,NP4=9,NP9=118,NP10=16,NP12=600,NP13=500,
     2 NP17=99,NPVD=40000000,NP23=18000,NP38=125,NP39=30)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON // JNSC(2 * NP23), VOID(NPVD)
      COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9),
     1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10),
     2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10),
     3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770)
      DIMENSION XXO(NP1, 6), NT(NP1), CON(NP1, NP4),
     1 IFG(NP1), JFG(NP1), BOND(*), ISMLST(5), ITEMPP(NP1),
     2 ITMPL(4), IPRIOR(4), NPRIOR(4), WPRIOR(4), IFTM(4), ISHLPRI(4),
     3 IPADF(4), V1(3), V2(3), V3(3), V4(3), V5(3), V6(3), V7(3),
     4 JR(100), JLN(100), NCN(100), IPTR(2, NP1), INB(8), INE(8),
     5 INL(8), LST(8), DTC(NP10), ITC(NP10), IPPR(129, 3), IJKL(4)
      CHARACTER CHYB*3, NOTE1*1
      NAT  = IPR(39)
      NATO = IPR(39)
      NBD  = IPR(131)
      CALL PLA034 (1, NAT)
      DO 20 I = 1, NAT
        NC = - NINT(CON(I, NP4))
        IF (NC .GT. 0 .AND. NC .LT. NP4) THEN
          K0 = 0
          DO 10 J = 1, NC
            K = NINT(CON(I, J))
            CALL GEN048 (-7, JFG(K), 1, KP)
            KP = IPPR(KP + 1, 1) / IPR(582)
            IF (KP .GT. 0) THEN
              K0 = K0 + 1
              CON(I, K0) = CON(I, J)
            ENDIF
   10     CONTINUE
          CON(I, NP4) = - K0
        ENDIF
   20 CONTINUE
      DO 30 I = 1, NAT
        CALL GEN048 (-1, IFG(I), 19, IMET)
        CALL PLA099 (0, I, NANG, ANG1, ANG2, ANG3, NCEFF,
     1                     IMET, IHYB, CHYB, NATH, NOTE1)
        CALL GEN048 (4, IFG(I), 24, IHYB)
        CALL GEN048 (3, JFG(I), 24, NATH)
   30 CONTINUE
      DO 40 I = 1, IAN
        DTC(I) = ATWT(IEN(I))
        ITC(I) = I
   40 CONTINUE
      CALL GEN013 (DTC, ITC, 1, IAN)
      DO 50 I = 1, IAN
        DTC(I) = ITC(I)
        ITC(I) = I
   50 CONTINUE
      CALL GEN013 (DTC, ITC, 1, IAN)
      DO 60 I = 1, NAT
        CALL GEN048 (-4, IFG(I), 15, IDUM)
        NT(I) = ITC(IDUM + 1)
   60 CONTINUE
      DO 80 I = 1, NBD
        IPQ1 = NINT(BOND(I * 3 - 2))
        IPQ2 = NINT(BOND(I * 3 - 1))
        CALL PLA050 (IPQ1, IPQ2, 0, 0, DIST)
        CALL GEN048 (-4, IFG(IPQ1), 24, IHYA)
        CALL GEN048 (-4, IFG(IPQ2), 24, IHYB)
        CALL GEN048 (-4, IFG(IPQ1), 15, NOIP)
        CALL GEN048 (-4, IFG(IPQ2), 15, NOIQ)
        NOIP = IEN(NOIP + 1)
        NOIQ = IEN(NOIQ + 1)
        IF (IHYA .EQ. 1 .AND. IHYB .EQ. 1) THEN
          IBNDO = 3
        ELSE IF (IHYA * IHYB .EQ. 2) THEN
          IBNDO = 2
        ELSE IF (IHYA .EQ. 2 .AND. IHYB .EQ. 2) THEN
          IBNDO = 2
          IF (NOIP .EQ. 2 .AND. NOIQ .EQ. 2) THEN
            IF (DIST .GT. PAR(384)) IBNDO = 1
          ENDIF
        ELSE IF (NOIP .EQ. 8 .AND. NOIQ .EQ. 3 .AND.
     1           IHYA .EQ. 3 .AND. IHYB .EQ. 2) THEN
          IBNDO = 2
        ELSE
          IBNDO = 1
        ENDIF
        IF (IBNDO .GT. 1) THEN
          DO 70 J = 2, IBNDO
            ITMP1 = - NINT(CON(IPQ1, NP4)) + 1
            ITMP2 = - NINT(CON(IPQ2, NP4)) + 1
            IF (ITMP1 .LE. 4 .OR. ITMP2 .LE. 4) THEN
              IF (ITMP1 .LE. 4) THEN
                NATO             = NATO + 1
                NT(NATO)         = NT(IPQ2)
                CON(NATO, 1)     = IPQ1
                CON(NATO, NP4)   = - 1
                CON(IPQ1, ITMP1) = NATO
                CON(IPQ1, NP4)   = - ITMP1
              ENDIF
              IF (ITMP2 .LE. 4) THEN
                NATO             = NATO + 1
                NT(NATO)         = NT(IPQ1)
                CON(NATO, 1)     = IPQ2
                CON(NATO, NP4)   = - 1
                CON(IPQ2, ITMP2) = NATO
                CON(IPQ2, NP4)   = - ITMP2
              ENDIF
            ENDIF
   70     CONTINUE
        ENDIF
   80 CONTINUE
      DO 120 I = 1, NAT
        CALL GEN048 (-4, IFG(I), 24, IHYA)
        CALL GEN048 (-1, IFG(I), 19, IMET)
        NC = - NINT(CON(I, NP4))
        IF (NC .EQ. 4 .AND. IMET .EQ. 0 .AND. IHYA .EQ. 3) THEN
          JCAI = 2
        ELSE
          JCAI = 0
        ENDIF
        CALL GEN048 (2, IFG(I), 28, JCAI)
        IF (NC .GT. 1) THEN
          IF (NC .LT. 0) NC = NP4
          DO 110 J = 2, NC
            I1 = NINT(CON(I, J))
            DO 90 II = J - 1, 1, -1
              IF (NT(NINT(CON(I, II))) .GE. NT(I1)) GOTO 100
              CON(I, II + 1) = CON(I, II)
   90       CONTINUE
            II = 0
  100       CON(I, II + 1) = I1
  110     CONTINUE
        ENDIF
  120 CONTINUE
      NRTM   = IPR(492)
      NPK    = (NRTM + 1) * 4
      MAXPAD = NP23 * 2 / NPK
      DO 530 KCENT = 1, NAT
        CALL GEN048 (-2, IFG(KCENT), 28, JCAK)
        IF (JCAK .EQ. 2) THEN
          CALL GEN048 (2, IFG(KCENT), 28, 0)
          ICHIRAL    = 2
          DO 130 I = 1, 4
            NPRIOR(I) = NINT(CON(KCENT, I))
            WPRIOR(I) = NT(NINT(CON(KCENT, I)))
  130     CONTINUE
          CALL GEN013 (WPRIOR, NPRIOR, 1, 4)
          ISMPNTR = 1
  140     NSAME     = 1
          ISMLST(1) = NPRIOR(ISMPNTR)
          DO 150 I = 1, 4 - ISMPNTR
            IF (WPRIOR(ISMPNTR + I) .NE. WPRIOR(ISMPNTR)) GOTO 160
            ISMLST(I + 1) = NPRIOR(ISMPNTR + I)
            NSAME         = NSAME + 1
  150     CONTINUE
  160     IF (NSAME .NE. 1) THEN
            CALL GEN048 (-1, IFG(ISMLST(1)), 7,  IDUM)
            IF (IDUM .EQ. 1) GOTO 530
            MAXNUMPAD = 1
            CALL GEN097 (JNSC, 1, 2 * NP23, 0)
            DO 300 ISAM = 1, NSAME
              IHINP = 0
              ISMLST(NSAME + 1) = KCENT
              IPRIOR(ISAM) = 0
              IATOM        = ISMLST(ISAM)
              IPADNUM      = 0
              NRT          = 1
              JR(1)        = KCENT
              JR(2)        = IATOM
  170         IF (NRT .LT. 1) GOTO 220
              NRT          = NRT + 1
              IF (NRT .GT. NRTM) GOTO 200
              IF (NRT .GT. 3) THEN
                DO 180 K = NRT - 3, 1, -1
                  IF (JR(NRT) .EQ. JR(K)) GOTO 200
  180           CONTINUE
              ENDIF
              NC = - NINT(CON(JR(NRT), NP4))
              IF (NC .LT. 0) NC = NP4
              IF (NC .EQ. 1) THEN
                CALL GEN048 (-1, IFG(I), 7,  IHAT)
                IF (IHAT .EQ. 1) NRT = NRT -1
                GOTO 200
              ENDIF
              NCN(NRT)     = NC
              JLN(NRT)     = 0
  190         IF (NRT .LE. 1) GOTO 220
              JLN(NRT)     = JLN(NRT) + 1
              IF (JLN(NRT) .GT. NCN(NRT)) THEN
                IF (NRT .EQ. 2) GOTO 200
                NRT = NRT - 1
                GOTO 190
              ENDIF
              JR(NRT + 1) = NINT(CON(JR(NRT), JLN(NRT)))
              CALL GEN048 (-1, IFG(JR(NRT + 1)), 7,  IHAT)
              IF (IHAT .EQ. 1) THEN
                IF (NCN(NRT) .LE. 2) THEN
                  GOTO 200
                ELSE
                  GOTO 190
                ENDIF
              ENDIF
              IF (JR(NRT + 1) .EQ. JR(NRT - 1)) GOTO 190
              GOTO 170
  200         DO 210 I = 2, NRT
                JNSC(ISAM + IPADNUM * NPK + (I - 2) * 4) = JR(I)
  210         CONTINUE
              IPADNUM = IPADNUM + 1
              NRT = NRT - 1
              JNSC(ISAM + (IPADNUM - 1) * NPK + NRTM * 4) = NRT
              IHINP = MAX (IHINP, NRT)
              IF (IPADNUM .GT. MAXNUMPAD) MAXNUMPAD = IPADNUM
              IF (IPADNUM .EQ. MAXPAD) THEN
                IPR(126) = IPR(126) + 1
                WRITE (LU6, 99999) MAXPAD
                ISMLST(1) = -1
                GOTO 520
              ENDIF
              GOTO 190
  220         DO 290 ISHL = IHINP, 1, -1
                DO 280 J = 1, IPADNUM -1
                  I1 = JNSC(ISAM + J * NPK + (ISHL - 1) * 4)
                  I2 = JNSC(ISAM + J * NPK + NRTM * 4)
                  IF (I1 .GT. 0 .AND. I1 .LE. NATO) THEN
                    I3 = NT(I1)
                  ELSE
                    I3 = 0
                  ENDIF
                  DO 230 K = 1, IHINP
                    ITEMPP(K) = JNSC(ISAM + J * NPK + (K - 1) * 4)
  230             CONTINUE
                  DO 250 I = J, 1, -1
                    I4 = JNSC(ISAM + (I - 1) * NPK + (ISHL - 1) * 4)
                    IF (I4 .GT. 0 .AND. I4 .LE. NATO) THEN
                      I5 = NT(I4)
                    ELSE
                      I5 = 0
                    ENDIF
                    IF (I5 .GE. I3) GOTO 260
                    DO 240 K = 1, IHINP
                      JNSC(ISAM + I * NPK + (K - 1) * 4) =
     1                JNSC(ISAM + (I - 1) * NPK + (K - 1) * 4)
  240               CONTINUE
                    JNSC(ISAM + I * NPK + NRTM * 4)
     1                = JNSC(ISAM + (I - 1) * NPK + NRTM * 4)
  250             CONTINUE
                  I = 0
  260             JNSC(ISAM + I * NPK + (ISHL - 1) * 4) = I1
                  DO 270 K = 1, IHINP
                    JNSC(ISAM + I * NPK + (K - 1) * 4) = ITEMPP(K)
  270             CONTINUE
                  JNSC(ISAM + I * NPK + NRTM * 4) = I2
  280           CONTINUE
  290         CONTINUE
  300       CONTINUE
            DO 310 I = 1, NSAME
              IPADF(I) = 0
  310       CONTINUE
            DO 460 IPAD = 1, MAXNUMPAD
              IHINP = 0
              JDUM = (IPAD - 1) * NPK + NRTM * 4
              DO 320 I = 1, NSAME
                IHINP = MAX (IHINP, JNSC(I + JDUM))
  320         CONTINUE
              DO 450 ISHL = 1, IHINP
                IHINC = 0
                JDUM = (IPAD - 1) * NPK + (ISHL - 1) * 4
                DO 330 I = 1, NSAME
                  IPNTR = JNSC(I + JDUM)
                  IF (IPNTR .GT. 0) THEN
                    IF (NINT(CON(IPNTR, NP4)) .LT. - IHINC) THEN
                      IHINC = - NINT(CON(IPNTR, NP4))
                      IF (IHINC .GT. 6) GOTO 520
                    ENDIF
                  ENDIF
  330           CONTINUE
                DO 350 I = 1, NSAME
                  IF (IPADF(I) .EQ. 0) THEN
                    ISHLPRI(I) = 0
                    IPNTR = JNSC(I + (IPAD - 1) * NPK + (ISHL - 1) * 4)
                    IF (IPNTR .GT. 0) THEN
                      NC =  - NINT(CON(IPNTR, NP4))
                      IF (NC .LT. 0) NC = NP4
                      IJKL(I) = IPNTR
                      DO 340 J = 1, NC
                        ISHLPRI(I) = ISHLPRI(I) +
     1                    NT(NINT(CON(IPNTR, J))) *
     2                    (IAN + 1) ** (IHINC - J)
  340                 CONTINUE
                    ENDIF
                  ENDIF
  350           CONTINUE
                NFOUND = 0
                DO 370 I = 1, NSAME
                  IF (IPADF(I) .EQ. 1) THEN
                    NFOUND = NFOUND + 1
                  ELSE
                    DO 360 J = 1, NSAME
                      IF (I .NE. J) THEN
                        IF (IJKL(I) .EQ. IJKL(J)) GOTO 530
                        IF (ISHLPRI(I) .EQ. ISHLPRI(J)
     1                    .AND. IPADF(J) .EQ. 0) GOTO 370
                      ENDIF
  360               CONTINUE
                    IPADF(I) = 1
                    NFOUND   = NFOUND + 1
                    IFTM(I)  = ISHL
                  ENDIF
  370           CONTINUE
                DO 420 I = 1, NSAME
                  ILOWEST  = ISHLPRI(1) + 1
                  IHIGHEST = 0
                  IHI      = 1
                  ILO      = 1
                  DO 380 J = 1, NSAME
                    IF (ISHLPRI(J) .GT. IHIGHEST) THEN
                      IHI      = J
                      IHIGHEST = ISHLPRI(J)
                    ENDIF
                    IF (ISHLPRI(J) .LT. ILOWEST .AND.
     1                  ISHLPRI(J) .NE. -1) THEN
                      ILO     = J
                      ILOWEST = ISHLPRI(J)
                    ENDIF
  380             CONTINUE
                  IF (IHIGHEST .NE. 0 .AND. IPADF(IHI) .EQ. 1 .AND.
     1              IFTM(IHI) .EQ. ISHL) THEN
                    DO 390 J = 1, NSAME
                      IF (IPRIOR(J) .EQ. 0) THEN
                        IPRIOR(J)    = IHI
                        ISHLPRI(IHI) = -1
                        GOTO 400
                      ENDIF
  390               CONTINUE
                  ENDIF
  400             IF (ILOWEST .NE. 0 .AND. IPADF(ILO) .EQ. 1 .AND.
     1               IFTM(ILO) .EQ. ISHL) THEN
                    DO 410 J = NSAME, 1, -1
                      IF (IPRIOR(J) .EQ. 0) THEN
                        IPRIOR(J)    = ILO
                        ISHLPRI(ILO) = - 1
                        GOTO 420
                      ENDIF
  410               CONTINUE
                  ENDIF
  420           CONTINUE
                IF (NFOUND .EQ. NSAME) THEN
                  DO 430 I = 1, NSAME
                    IF (IPRIOR(I) .LT. 1 .OR. IPRIOR(I) .GT. 4)
     1                  GOTO 520
                    ITMPL(I) = ISMLST(IPRIOR(I))
  430             CONTINUE
                  DO 440 I = 1, NSAME
                    ISMLST(I) = ITMPL(I)
  440             CONTINUE
                  GOTO 480
                ENDIF
  450         CONTINUE
  460       CONTINUE
            GOTO 530
  480       DO 490 I = 1, NSAME
              IF (ISMLST(I) .LT. 0) GOTO 530
  490       CONTINUE
          ENDIF
          DO 500 I = 1, NSAME
            NPRIOR(ISMPNTR + I - 1) = ISMLST(NSAME    - I + 1)
            WPRIOR(ISMPNTR + I - 1) = NT(ISMLST(NSAME - I + 1))
  500     CONTINUE
          ISMPNTR = ISMPNTR + NSAME
          IF (ISMPNTR .LE. 4) GOTO 140
          DO 510 I = 1, 3
            V1(I) = XXO(NPRIOR(4), I + 3)
            V2(I) = XXO(NPRIOR(3), I + 3)
            V3(I) = XXO(NPRIOR(2), I + 3)
            V4(I) = XXO(NPRIOR(1), I + 3)
  510     CONTINUE
          CALL GEN008 (V2, V3, V5, 0)
          D =  GEN009 (V1, V5)
          CALL GEN008 (V1, V2, V6, 0)
          CALL GEN015 (V5, V6, V7)
          CALL GEN008 (V3, V1, V6, 0)
          CALL GEN015 (V6, V7, V5)
          IF (GEN009 (V4, V5) .LT. D) THEN
            ICHIRAL = 1
          ELSE
            ICHIRAL = 3
          ENDIF
          IF (IABS(2 - ICHIRAL) .EQ. 1) IPR(583) = IPR(583) + 1
  520     CALL GEN048 (2, IFG(KCENT), 28, ICHIRAL)
        ENDIF
  530 CONTINUE
      CALL GEN097 (JNSC, 1, 2 * NP23, 0)
      INB(1) = 1
      INE(1) = NATO
      DO 540 I = INB(1), INE(1)
        JNSC ((I - 1) * 8 + 1) = NT(I)
        IPTR (1, I) = NT(I)
        IPTR (2, I) = I
  540 CONTINUE
      CALL GEN037 (IPTR, INB(1), INE(1))
      MPG    = 0
  550 DO 580 I = INB(1), INE(1)
        NC = - NINT(CON(I, NP4))
        IF (NC .LT. 0 .OR. NC .GT. 6) NC = 6
        IF (NC .GT. 0) THEN
          DO 560 J = 1, NC
            LST(J) = NT(NINT(CON(I, J)))
  560     CONTINUE
          CALL GEN022 (LST, 1, NC)
          DO 570 K = 1, NC
            JNSC((I - 1) * 8 + K + 1) = LST (NC + 1 - K)
  570     CONTINUE
        ENDIF
  580 CONTINUE
      M          = 1
      MPRI       = 1
  590 INL(M)     = INB(M) - 1
      INB(M + 1) = INB(M)
      N          = JNSC((IPTR(2, INB(M)) - 1) * 8 + M)
      NVB        = JNSC((IPTR(2, INB(M)) - 1) * 8 + M + 1)
      ISORT      = 0
  600 INL(M) = INL(M)  + 1
      IF (INL(M) .LE. INE(M)) THEN
        IPTM = IPTR(2, INL(M))
        IF (JNSC((IPTM - 1) * 8 + M) .EQ. N) THEN
          NVX             = JNSC ((IPTM - 1) * 8 + M + 1)
          IPTR(1, INL(M)) = NVX
          IF (NVX .NE. NVB) ISORT = 1
          NT(IPTM) = MPRI
          GOTO 600
        ENDIF
      ENDIF
      INE(M + 1) = INL(M) - 1
      IF (ISORT .EQ. 1) THEN
        CALL GEN037 (IPTR, INB(M + 1), INE(M + 1))
      ELSE
        IF (NVB .EQ. 0) GOTO 640
      ENDIF
      DO 630 KKK = 1, NATO
        III = IPTR(2, KKK)
        DO 610 NNN = 1, 6
          IF (JNSC((III - 1) * 8 + NNN) .EQ. 0) GOTO 630
  610   CONTINUE
  630 CONTINUE
      IF (M .LT. 8) THEN
        M = M + 1
        GOTO 590
      ENDIF
  640 INB(M + 1) = INL(M)
      IF (INB(M + 1) .LE. INE(M)) THEN
        N      = JNSC((IPTR(2, INB(M + 1)) - 1) * 8 + M)
        NVB    = JNSC((IPTR(2, INB(M + 1)) - 1) * 8 + M + 1)
        ISORT  = 0
        MPRI   = MPRI + 1
        INL(M) = INL(M) - 1
        GOTO 600
      ELSE
        M = M - 1
        IF (M .EQ. 0) GOTO 650
        GOTO 640
      ENDIF
  650 IF (MPRI .GT. MPG) THEN
        MPG = MPRI
        GOTO 550
      ENDIF
      DO 660 K = 1, NAT
        IVAL = NT(K)
        CALL GEN048 (10, JFG(K), 14, IVAL)
  660 CONTINUE
      CALL PLA034 (-1, NAT)
      RETURN
99999 FORMAT (':: MAXPATH = ', I4, ' EXCEEDED')
      END
      SUBROUTINE PLA031
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16,
     1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NPVD=40000000,
     2 NP22=256,NP23=18000,NP25=99,NP29=63,NP38=125,NP39=30,NP41=200,
     3 NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON // JNSC(2, NP23), VOID(NPVD)
      DIMENSION XMD(9, 2), IXMD(9), ICSD(6)
      CHARACTER FORM*160, FORMI*79, FORMJ*68
      FORMI( 1:28) = '(''Centroid '',A,'': x ,y ,z '','
      FORMI(29:62) = 'F10.5,''('',I4,'')'',F10.5,''('',I4,'')'','
      FORMI(63:79) = 'F10.5,''('',I4,'')'')'
      FORMJ( 1:17) = '(16X,''XO,YO,ZO '','
      FORMJ(18:68) = FORMI(29:79)
      FORM(  1: 15) = '('' From: '',A   '
      FORM( 16: 31) = ',F8.4,''('',I3,'')'''
      FORM( 32: 79) = FORM(16:31)//FORM(16:31)//FORM(16:31)
      FORM( 80:127) = FORM(32:79)
      FORM(128:160) = FORM(16:31)//FORM(16:31)//')'
      NRAT     = IPR(12)
      NAT      = IPR(39)
      IPR(64)  = IPR(64) + 1
      KRC      = NAT + IPR(64)
      IFG(KRC) = IFG(JR(1))
      JFG(KRC) = JFG(JR(1))
      NTRNS(KRC) = NTRNS(JR(1))
      CALL GEN048 (-6, IFG(KRC), 9, NRES)
      CALL GEN040 (IPR(19) + IATP(KRC), NQ2, IP)
      NQ1(1:7)      = 'CG     '
      NQ1(3:2 + IP) = NQ2(1:IP)
      CALL PLA046 (1, NQ1, IENM, LBB, LBC, LBD,
     1             XNQNR, YNQNR, NIEN)
      CALL GEN048 (6, IFG(KRC), 15, NIEN)
      XLAB(KRC) = XNQNR
      CALL PLA047 (XNQNR, NQ1, MN, JDUM, IPR(119), IGBL(55), 0, 0)
      DO 10 K = 1, 3
        YUNK = SQRT(XSD(KRC, K))
        CALL GEN041 (XXO(KRC, K), YUNK, ICSD(K), IPR(183),
     1               NDEC, IPR(68))
        NDC           = K * 17 + 16
        YUNK = SQRT(XSD(KRC, K + 3))
        CALL GEN041 (XXO(KRC, K + 3), YUNK, ICSD(K + 3), 5, NDECJ,
     1       IPR(68))
        NDCJ          = K * 17 + 5
        FORMI(NDC:NDC)   = CHAR(ICHAR('0') + NDEC)
        FORMJ(NDCJ:NDCJ) = CHAR(ICHAR('0') + NDECJ)
        ICSD(K)          = MIN (99, ICSD(K))
        ICSD(K + 3)      = MIN (99, ICSD(K + 3))
   10 CONTINUE
      IF (IGBL(63) .GT. 2) THEN
        CALL PLA269 (1)
        WRITE (LU7, '(/)')
        WRITE (PRBUF, FORMI) NQ1(1:6), (XXO(KRC, K), ICSD(K), K = 1, 3)
        CALL PLA067 (LU7, PRBUF, 132, 1, 3)
        WRITE (PRBUF, FORMJ) (XXO(KRC, K), ICSD(K), K = 4, 6)
        CALL PLA067 (LU7, PRBUF, 132, 1, 3)
      ENDIF
      IF (NRAT .LE. 7) THEN
        NRAT          = NRAT + 1
        NAMS(NRAT, 1) = ' '//NQ1
        NRT           = NRAT + 1
        NAMS(NRT, 1)  = '  RING '
        NM = 0
        DO 120 I = 1, NAT
          CALL GEN048 (-1, IFG(I), 19, MET)
          IF (MET .EQ. 0) GOTO 120
          JR(NRAT)    = KRC
          CALL PLA050 (I, KRC, 0, 0, DCEN)
          IF (DCEN .GT. PAR(422)) GOTO 120
          CALL PLA047 (XLAB(I), NQ1, IDUM, JDUM, IPR(119), IGBL(55),
     1                 0, 0)
          CALL PLA055
          CALL PLA056 (XPV(1), I, XMD(NRT, 1), XMD(NRT, 2),
     1                 IDUM1, 5, IDUM2)
          XMD(NRT, 1) = ABS(XMD(NRT, 1))
          IXMD(NRT)   = MIN (999, NINT(10000 * XMD(NRT, 2)))
          DO 20 J = 1, NRAT
            CALL PLA053 (I, JR(J), 0, 0, XMD(J, 1), XMD(J, 2),
     1                  IXMD(J), NDEC, IER)
            IF (IER .EQ. 0) THEN
              IF (XMD(J, 1) .LT. PAR(12)) GOTO 120
              IFT = 4 + J * 16
              FORM(IFT : IFT) = CHAR(ICHAR('0') + NDEC)
            ENDIF
   20     CONTINUE
          DPERP = - XPV(4)
          DO 30 J = 1, 3
            DPERP = DPERP + XPV(J) * XXO(I, J + 3)
   30     CONTINUE
          DSH = SQRT (MAX(0.0, DCEN**2 - DPERP**2))
          IF (DSH .GT. PAR(423) .OR. ABS(DPERP) .LT. PAR(424)) GOTO 120
          IF (IGBL(63) .GT. 2) THEN
            NM = NM + 1
            IF (NM .EQ. 1) THEN
              WRITE (LU7, 99998) PAR(422), PAR(424), PAR(423)
              WRITE (LU7, 99997) (NAMS(II, 1)(2:7), II = 1, NRT)
              WRITE (LU7, 99996)
            ENDIF
            WRITE (PRBUF, FORM)
     1         NQ1(1:7), (XMD(J, 1), IXMD(J), J = 1, NRT)
            CALL PLA067 (LU7, PRBUF, 132, 1, 3)
            WRITE (LU7, 99999) DSH
          ENDIF
          IF (DSH .LT. PAR(70)) THEN
            JR(NRAT) = I
            DO 110 MM = 1, IPR(51)
              IF (MM .EQ. 1) THEN
                DO 40 J = 2, NRAT
                  CALL PLA100 (JR(NRAT), JR(J - 1), -2, -1.0)
   40           CONTINUE
                CALL PLA100 (JR(NRAT), KRC, 2, -1.0)
              ELSE
                CALL GEN098 (MOL(MM), PAR(42), IPR(54),
     1               ITR(1), ITR(2), ITR(3), IR)
                IF (NRES .EQ. IR) THEN
                  KAT       = IPR(39) + IPR(64) + 1
                  IF (MN .GT. IPR(463)) THEN
                    IPR(2) = 54
                    GOTO 130
                  ENDIF
                  XLAB(KAT) = XLAB(KRC) + MM - 1
                  DO 50 J = 1, IPR(64)
                    IF (XLAB(KAT) .EQ. XLAB(IPR(39) + J)) THEN
                      KAT = IPR(39) + J
                      GOTO 70
                    ENDIF
   50             CONTINUE
                  IPR(64) = IPR(64) + 1
                  CALL PLA059 (KRC, KAT)
                  IFG(KAT) = IFG(KRC)
                  JFG(KAT) = JFG(KRC)
                  DO 60 J = 1, 6
                    VOID((KAT - 1) * (NP4 + 15) + J)     = XXO(KAT, J)
                    VOID((KAT - 1) * (NP4 + 15) + J + 6) = XSD(KAT, J)
   60             CONTINUE
                  CALL GEN048 (6, IFG(KAT), 9, IR)
   70             DO 100 J = 1, NRAT
                    KAT1 = KAT + 1
                    CALL PLA059 (JR(NRAT + 1 - J), KAT1)
                    DO 80 K = 1, NAT
                      CALL PLA050 (K, KAT1, 0, 0, DIST)
                      IF (DIST .LT. 0.05) GOTO 90
   80               CONTINUE
                    GOTO 100
   90               IF (J .EQ. 1) THEN
                      KMETAL = K
                      CALL PLA100 (KMETAL, KAT, 2, -1.0)
                    ELSE
                      CALL PLA100 (KMETAL, K, -2, -1.0)
                    ENDIF
  100             CONTINUE
                ENDIF
              ENDIF
  110       CONTINUE
          ENDIF
  120   CONTINUE
      ENDIF
  130 RETURN
99999 FORMAT (/, 'Ring-Slippage: Distance Between Perpendicular ',
     1 'Projection of Heavy Atom on Ring L.S.-Plane and Ring ',
     2 'Centroid =', F6.3, ' Ang'/)
99998 FORMAT (///, 10X, 'Metal - Ring Geometry [d(Metal-Cg) .lt.',
     1 F5.1, ' Ang., d(perp) .gt. ', F5.1, ' Ang., Slippage .lt. ',
     2 F6.3, ' Ang.]', /, 10X, 102('='), /)
99997 FORMAT ('Distance (Ang) to:', 1X, A, 8(7X, A))
99996 FORMAT (132('-'))
      END
      SUBROUTINE PLA032 (NRSD)
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16,
     1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP22=256,NP25=99,
     2 NP29=63,NP38=125,NP39=30,NP41=200,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      CHARACTER FORM*73
      SA   = 0.0
      ISA  = 0
      NDEC = 0
      IF (IPR(8) .GT. 0) THEN
        IPR(60) = 0
        NAT     = IPR(37)
        MTL     = 3
        NTOR    = 0
        KB      = 0
        FORM(1 :4)  = '(1X,'
        FORM(5:24)  = '4(A),F8.2,''('',I3,'')'''
        FORM(25:48) = ',4X,'//FORM(5:24)
        FORM(49:73) = FORM(25:48)//')'
        DO 80 NHB = 1, 2
          IHB = NHB - 1
          IF (IHB .EQ. 1 .AND. IGBL(63) .GT. 2) THEN
            CALL PLA269 (1)
            WRITE (LU7, '( )')
          ENDIF
          DO 70 JAT = 1, NAT
            JR(2)   = JAT
            JATL    = INT(XLAB(JAT) / IPR(463))
            CALL GEN048 (-6, IFG(JAT), 9, IRESJ)
            IF (IRESJ .NE. NRSD) GOTO 70
            CALL GEN048 (-1, IFG(JAT), 7, IHJ)
            NJ = - NINT(CON(JAT, NP4))
            IF (NJ .LT. 0) THEN
              NJ = NP4
              CALL GEN048 (-1, IFG(JAT), 8, IVAL)
              IF (IVAL .GT. 0) NJ = NJ + IPR(76)
            ENDIF
            IF (NJ .LE. 1) GOTO 70
            DO 60 KJ = 1, NJ
               IF (KJ .LE. NP4) THEN
                 KAT = NINT(CON(JAT, KJ))
               ELSE
                 IF (IBON(KJ - NP4, 1) .NE. JAT) GOTO 60
                 KAT = IBON(KJ - NP4, 2)
               ENDIF
               JR(3) = KAT
               KATL = INT(XLAB(KAT) / IPR(463))
               IF (JATL .GT. KATL) GOTO 60
               NK = - NINT(CON(KAT, NP4))
               IF (NK .LT. 0) THEN
                 NK = NP4
                 CALL GEN048 (-1, IFG(KAT), 8, IVAL)
                 IF (IVAL .GT. 0) NK = NK + IPR(76)
               ENDIF
               IF (NK .LE. 1) GOTO 60
               CALL GEN048 (-1, IFG(KAT), 7,  IHK)
               IF (NJ .LE. IPR(163) .AND. NK .LE. IPR(163))
     1            CALL PLA033 (NJ, NK)
               DO 50 KI = 1, NJ
                  IF (KI .LE. NP4) THEN
                    IAT = NINT(CON(JAT, KI))
                  ELSE
                    IF (IBON(KI - NP4, 1) .NE. JAT) GOTO 50
                    IAT = IBON(KI - NP4, 2)
                  ENDIF
                  JR(1) = IAT
                  IF (IAT .EQ. KAT) GOTO 50
                  CALL GEN048 (-1, IFG(IAT), 7,  IHI)
                  DO 40 KK = 1, NK
                     IF (KK .LE. NP4) THEN
                       LAT = NINT(CON(KAT, KK))
                     ELSE
                       IF (IBON(KK - NP4, 1) .NE. KAT) GOTO 40
                       LAT = IBON(KK - NP4, 2)
                     ENDIF
                     JR(4) = LAT
                     IF (LAT .EQ. JAT) GOTO 40
                     IF (IAT .EQ. LAT) GOTO 40
                     CALL GEN048 (-1, IFG(LAT), 7, IHL)
                     IHA = IHI + IHJ + IHK + IHL
                     IF (IHB .EQ. 0) THEN
                       IF (IHA .GT. 0) GOTO 40
                     ELSE
                       IF (IHA .EQ. 0) GOTO 40
                     ENDIF
                     KB1 = KB + 1
                     CALL PLA036 (IAT, KB1, 1, IDS1, MNUM1, ISP1,
     1                            IPR(119), IGBL(55))
                     IF (IDS1 .LT. 500) GOTO 50
                     CALL PLA036 (JAT, KB1, 2, IDS2, MNUM2, ISP2,
     1                            IPR(119), IGBL(55))
                     IF (IDS2 .LT. 500) GOTO 70
                     CALL PLA036 (KAT, KB1, 3, IDS3, MNUM3, ISP3,
     1                            IPR(119), IGBL(55))
                     IF (IDS3 .LT. 500) GOTO 60
                     CALL PLA036 (LAT, KB1, 4, IDS4, MNUM4, ISP4,
     1                            IPR(119), IGBL(55))
                     IF (IDS4 .LT. 500) GOTO 40
                     IVLT = 0
                     IF (MNUM1 .GT. 1) THEN
                       IVLT = IVLT + 1
                     ENDIF
                     IF (MNUM2 .GT. 1) THEN
                       IVLT = IVLT + 1
                     ENDIF
                     IF (MNUM3 .GT. 1) THEN
                       IVLT = IVLT + 1
                     ENDIF
                     IF (MNUM4 .GT. 1) THEN
                       IVLT = IVLT + 1
                     ENDIF
                     ITEST = (4 - ISP1 - ISP2 - ISP3 - ISP4) / 2
                     IF (IVLT .GT. ITEST) GOTO 40
                     CALL PLA050 (IAT, JAT, KAT, 0, A)
                     IF (A .GT. PAR(15)) GOTO 40
                     CALL PLA050 (JAT, KAT, LAT, 0, A)
                     IF (A .GT. PAR(15)) GOTO 40
                     CALL PLA053 (IAT, JAT, KAT, LAT, A, SA, ISA,
     1                            NDEC, IER)
                     IF (IER .NE. 0) GOTO 40
                     KB        = KB + 1
                     NTOR      = NTOR + 1
                     DBUF(KB)  = A
                     IDBUF(KB) = ISA
                     IFT       = -11 + KB * 24
                     FORM(IFT : IFT) = CHAR(ICHAR('0') + NDEC)
                     IF (IPR(438) .EQ. 1 .AND. IHA .EQ. 0) THEN
                       IPR(253) = IPR(253) + 1
                       WRITE (LU2, 99998)
     1                  (NAMS(KB, M)(2:8), M = 1, 4), A, SA
                     ENDIF
                     CALL GEN048 (-3, JFG(KAT), 24, KMET)
                     CALL GEN048 (-4, IFG(KAT), 24, KHYB)
                     NCK = NINT(CON(KAT, NP4))
                     CALL GEN048 (-3, JFG(JAT), 24, JMET)
                     CALL GEN048 (-4, IFG(JAT), 24, JHYB)
                     NCJ = NINT(CON(JAT, NP4))
                     IF (NCK .EQ. -4) THEN
                       IF (KMET .EQ. 3 .AND. JHYB .EQ. 2) THEN
                         IF (180.0 - ABS(A) .LT. 0.15) THEN
                           WRITE (LU20, 99999)
     1                            '_380',  1.0, 1.0, NAMS(KB, 3)(2:8)
                         ENDIF
                       ENDIF
                     ENDIF
                     IF (NCJ .EQ. -4) THEN
                       IF (JMET .EQ. 3 .AND. KHYB .EQ. 2) THEN
                         IF (180.0 - ABS(A) .LT. 0.15) THEN
                           WRITE (LU20, 99999)
     1                            '_380',  1.0, 1.0, NAMS(KB, 2)(2:8)
                         ENDIF
                       ENDIF
                     ENDIF
                     IF (NTOR .EQ. 1) THEN
                       IF (IPR(134) .EQ. 1) THEN
                         IF (IGBL(63) .GT. 2) THEN
                           CALL PLA269 (4)
                           WRITE (LU7, 99996) NRSD
                         ENDIF
                         IPR(134) = 0
                       ENDIF
                       IF (IGBL(63) .GT. 2) THEN
                         CALL PLA269 (3)
                         WRITE (LU7, 99997) '>', PAR(15)
                       ENDIF
                     ENDIF
                     IF (KB .LT. MTL) GOTO 40
                     IF (IGBL(63) .GT. 2) THEN
                       WRITE (PRBUF, FORM) ((NAMS(L, M)(2:8), M = 1, 4),
     1                        DBUF(L), IDBUF(L), L = 1, MTL)
                       CALL PLA067 (LU7, PRBUF, 132, 1, 3)
                     ENDIF
                     KB = 0
   40             CONTINUE
   50          CONTINUE
   60       CONTINUE
   70     CONTINUE
          IF (KB .GT. 0) THEN
            IF (IGBL(63) .GT. 2) THEN
              WRITE (PRBUF, FORM) ((NAMS(L, M)(2:8), M = 1, 4),
     1               DBUF(L), IDBUF(L), L = 1, KB)
              CALL PLA067 (LU7, PRBUF, 132, 1, 3)
            ENDIF
            KB = 0
          ENDIF
   80   CONTINUE
        IF (IPR(60) .NE. 0) CALL PLA033 (0, 0)
      ENDIF
      RETURN
99999 FORMAT (A, 2F10.2, A)
99998 FORMAT ('TORS ', 4(A, 2X), 2F7.2)
99997 FORMAT (/, 'Torsion/Dihedral Angles (Deg.) - Klyne & Prelog',
     1 ' Convention (Dunitz, p241) - (Excl. Minor Disorder & Embedded',
     2 ' Bond Angl. ', A, F5.0, ' Deg.)', /, 132('='))
99996 FORMAT (/, 57X, 13('='), /, 56('*'), ' Residue =', I4, 1X,
     1 61('*'), /, 57X, 13('='))
      END
      SUBROUTINE PLA033 (NJ, NK)
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16,
     1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP25=99,NP29=63,
     2 NP38=125,NP39=30,NP41=200,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      NTYP = -1
      IF (NJ .NE. 0) THEN
        IPR(60) = IPR(60) + 1
        J       = JR(2)
        K       = JR(3)
        CALL PLA227 (K, J, RMAT(1, 3))
        DEN = SQRT(RMAT(1, 3)**2 + RMAT(2, 3)**2)
        IF (DEN .LT. PAR(12)) THEN
          RMAT(1, 2) = 0.0
          RMAT(2, 2) = 1.0
        ELSE
          RMAT(1, 2) =  RMAT(2, 3) / DEN
          RMAT(2, 2) = -RMAT(1, 3) / DEN
        ENDIF
        RMAT(3, 2) = 0.0
        CALL GEN008 (RMAT(1, 2), RMAT(1, 3), RMAT(1, 1), 1)
        CALL GEN005 (RMAT, RMAT)
        JJ = 0
        DO 30 I = 1, NJ
          I1 = NINT(CON(J, I))
          IF (I1 .NE. K) THEN
            JJ = JJ + 1
            IATC(JJ) = I1 + NP1
          ENDIF
   30   CONTINUE
        DO 40 I = 1, NK
          I1 = NINT(CON(K, I))
          IF (I1 .NE. J) THEN
            JJ = JJ + 1
            IATC(JJ) = I1
          ENDIF
   40   CONTINUE
        CALL PLA044 (RMAT, J, XR0, YR0, ZR0, 0.0, 0.0, 0.0, 1.0, 0.0)
        DO 50 I = 1, JJ
          DATC(I) = 90.0
          L = MOD(IATC(I), NP1)
          CALL PLA044 (RMAT, L, XR, YR, ZR, XR0, YR0, ZR0, 1.0, 0.0)
          IF (ABS(XR) .GT. 0.00001) THEN
            DATC(I) = ATAN2(YR, XR) * GL(5)
            IF (DATC(I) .LT. 0.0) DATC(I) = DATC(I) + 360.0
          ENDIF
   50   CONTINUE
        CALL GEN013 (DATC, IATC, 1, JJ)
        ISH           = (IPR(60) - 1) * 60
        IATP(1 + ISH) = JJ
        IATP(2 + ISH) = J
        IATP(3 + ISH) = K
        DO 60 I = 1, JJ
          IATP(I + 3  + ISH) = IATC(I)
          IATP(I + 20 + ISH) = NINT(100.0 * (DATC(I) - DATC(1)))
          IATP(I + 38 + ISH) = NINT(100.0 * (DATC(I) - DATC(1)))
   60   CONTINUE
        DO 80 I = 2, JJ
          DO 70 J = 1, 6
            DELX = PAR(24) * ABS(COS(IATP(I + 38 + ISH) / GL(5))
     1       -COS(IATP(I + 37 + ISH) / GL(5)))
            DELY = PAR(24) * ABS(SIN(IATP(I + 38 + ISH) / GL(5))
     1       -SIN(IATP(I + 37 + ISH) / GL(5)))
            IF (4.5 * DELX .GT. 6.0 * PAR(25) .OR.
     1          4.5 * DELY .GT. PAR(25)) GOTO  80
            IATP(I + 38 + ISH) = IATP(I + 38 + ISH) + 1
            IATP(I + 37 + ISH) = IATP(I + 37 + ISH) - 1
   70     CONTINUE
   80   CONTINUE
        IATP(JJ + 4  + ISH) = IATC(1)
        IATP(JJ + 21 + ISH) = IATP(21 + ISH) + 36000
        IF (IPR(60) .NE. 4) GOTO 100
      ENDIF
      WRITE (LU8) NTYP, IPR(60), JR, RMAT
      WRITE (LU8) (IATP(L4), L4 = 1, 240)
      IPR(60) = 0
  100 RETURN
      END
      SUBROUTINE PLA034 (MODE, NAT)
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16,
     1 NP11=128,NP19=31,NPVD=40000000,NP23=18000,NP25=99,NP29=63,
     2 NP41=200,NP47=9)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON // JNSC(2, NP23), VOID(NPVD)
      K = 0
      IF (MODE .EQ. 1) THEN
        DO 30 I = 1, NAT
          DO 10 J = 1, 6
            VOID(K + J)     = XXO(I, J)
            VOID(K + J + 6) = XSD(I, J)
   10    CONTINUE
          DO 20 J = 1, NP4
            VOID(K + J + 12) = CON(I, J)
   20     CONTINUE
          K = K + NP4 + 15
   30   CONTINUE
      ELSE IF (MODE .EQ. -1) THEN
        DO 60 I = 1, NAT
          DO 40 J = 1, 6
            XXO(I, J) = VOID(K + J)
            XSD(I, J) = VOID(K + J + 6)
   40     CONTINUE
          DO 50 J = 1, NP4
            CON(I, J) = VOID(K + J + 12)
   50     CONTINUE
          K = K + NP4 + 15
   60   CONTINUE
      ENDIF
      RETURN
      END
      SUBROUTINE PLA035 (MODE)
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16,
     1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP22=256,NP25=99,
     2 NP29=63,NP38=125,NP39=30,NP41=200,NP45=2048,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /Q/ ICL, IFL(NP17)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      DIMENSION ISPV(8)
      CHARACTER INQ1*1, FORMA*48, FORMB*48, FORMT*48, FORMC*35,
     1 FORMD*34, FORME*40, FORML*58, FORM*87, FORMH*36
      COMMON /PAGENM/ PAGET, PAGEIND(25)
      CHARACTER PAGET*8, PAGEIND*8
      COMMON /CGG11/ BCD, SBCD
      CHARACTER BCD*132, SBCD*132
      COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0
      IWIN = IGBL(25) * IGBL(32)
      FORM(1:28)   = '(''P ='',F8.4,''('',I4,''), Q ='','
      FORM(29:61)  = 'F8.4,''('',I4,''), R ='',F8.4,''('',I4,'
      FORM(62:86)  = '''), S ='',F8.4,''('',I4,'')'')'
      FORMB( 1:11) = '( ''DIST '',1'
      FORMB(12:48) = '( A ,''.. ''), A ,'' ='',F9.4,''('',I3,'')'')'
      FORMA( 1:48) = '(''ANGLE '',2'//FORMB(12:48)
      FORMT( 1:48) = '( ''TORS '',3'//FORMB(12:48)
      FORMC( 1:35) = '(1X,A,'' -- '',A,11X,F8.4,''('',I3,'')'')'
      FORMD( 1:34) = '(1X,2(A,'' -- ''),A,F8.2,''('',I3,'')'')'
      FORME( 1:40) = '(A,1X,A,'' : '',F10.0,''('',I2,'')   '',6F8.4)'
      FORML( 1:30) = '( ''ANGLE '',A,''- '',A,''with '',A,'
      FORML(31:58) = '''- '',A,'' ='',F9.3,''('',I3,'')'')'
      FORMH( 1:36) = '(''Dihedral Angle ='',F7.0,''('',I2,'')'')'
      ANG   = 0.0
      SANG  = 0.0
      D     = 0.0
      SD    = 0.0
      ISANG = 0
      ISD   = 0
      PAGET = 'SelGeom'
      NAT     = IPR(39)
      NMAX    = NAT + IPR(64)
      N       = IPR(81)
      IPR(97) = IPR(97) + 1
      IF (IPR(97) .EQ. 1 .AND. IGBL(63) .GT. 1 .AND. MODE .EQ. 1) THEN
        CALL PLA269 (-3)
        WRITE (LU7, 99997)
      ENDIF
      IF (N .LT. 0) THEN
        IPR(12) = 0
        N       = - N
        NANAL = 0
        IF (IFL(1) .EQ. 'FIT') THEN
    5     IF (N .EQ. 1) THEN
            IF (IPR(221) .EQ. 0) THEN
              FN(1)    = 2
              FN(2)    = 1
              IPR(221) = 2
            ENDIF
            IF (IPR(221) .EQ. 2) THEN
              NRES1 = NINT(FN(1))
              NRES2 = NINT(FN(2))
              N2    = 0
              DO 30 I = 1, NAT
                CALL GEN048 (-1, IFG(I), 7, IHAT)
                IF (IHAT .EQ. 0) THEN
                  CALL GEN048 (-6, IFG(I), 9, NRESI)
                  IF (NRESI .EQ. NRES1) THEN
                    CALL GEN048 (-10, JFG(I), 14, LBN1)
                    IF (I .LT. NAT) THEN
                      DO 10 J = 1, NAT
                        IF (J .NE. I) THEN
                          CALL GEN048 (-10, JFG(J), 14, LBN2)
                          IF (LBN1 .EQ. LBN2) THEN
                            CALL GEN048 (-6, IFG(J), 9, NRESJ)
                            IF (NRESI .EQ. NRESJ) GOTO 30
                          ENDIF
                        ENDIF
   10                 CONTINUE
                    ENDIF
                    DO 20 J = 1, NAT
                      CALL GEN048 (-1, IFG(J), 7, IHAT)
                      IF (IHAT .EQ. 0) THEN
                        CALL GEN048 (-6, IFG(J), 9, NRESJ)
                        IF (NRESJ .EQ. NRES2) THEN
                          CALL GEN048 (-10, JFG(J), 14, LBN2)
                          IF (LBN1 .EQ. LBN2) THEN
                            N2         = N2 + 2
                            JR(N2 - 1) = I
                            JR(N2)     = J
                            GOTO 30
                          ENDIF
                        ENDIF
                      ENDIF
   20               CONTINUE
                  ENDIF
                ENDIF
   30         CONTINUE
              IF (N2 .GE. IPR(28) * 2) THEN
                IPR(12) = N2
                WRITE (LU6, 99994) NRES1, NRES2, N2 / 2
              ELSE
                N = -3
                GOTO 5
              ENDIF
            ELSE
              GOTO 280
            ENDIF
          ELSE IF (ABS(N) .EQ. 3) THEN
            NANAL = 1
            IF (N .EQ. 3) THEN
              CALL PLA046 (4, IFL(2), IENM, LBB, LBC, LBD,
     1                     XNQNR, YNQNR, N1)
              IF (N1 .LT. 0) THEN
                IF (N1 .EQ. -4) THEN
                  GOTO 280
                ELSE
                  GOTO 270
                ENDIF
              ENDIF
              CALL GEN048 (-6, IFG(N1), 9, NRES1)
              CALL PLA046 (4, IFL(3), IENM, LBB, LBC, LBD,
     1                     XNQNR, YNQNR, N2)
              IF (N2 .LT. 0) THEN
                IF (N2 .EQ. -4) THEN
                  GOTO 280
                ELSE
                  GOTO 270
                ENDIF
              ENDIF
              CALL GEN048 (-6, IFG(N2), 9, NRES2)
            ENDIF
            N1 = -1
            N2 =  0
            DO 40 I = 1, NAT
              CALL GEN048 (-1, IFG(I), 7, IHAT)
              IF (IHAT .EQ. 0) THEN
                CALL GEN048 (-6, IFG(I), 9, NRES)
                IF (NRES .EQ. NRES1) THEN
                  N1     = N1 + 2
                  JR(N1) = I
                ELSE IF (NRES .EQ. NRES2) THEN
                  N2     = N2 + 2
                  JR(N2) = I
                ENDIF
              ENDIF
   40       CONTINUE
            DO 50 K = 1, N2 - 1, 2
              JCA(JR(K)) = JR(K + 1)
   50       CONTINUE
            IPR(12) = N2
            WRITE (LU6, 99994) NRES1, NRES2, N2 / 2
            IF (N2 .NE. N1 + 1) THEN
              WRITE (LU6, 99993)
              GOTO 260
            ENDIF
          ELSE
            DO 60 I = 2, N
              CALL PLA046 (4, IFL(I), IENM, LBB, LBC, LBD,
     1                     XNQNR, YNQNR, NIEN)
              IF (NIEN .LT. 0) THEN
                IF (NIEN .EQ. -4) THEN
                  GOTO 280
                ELSE
                  GOTO 270
                ENDIF
              ENDIF
              IPR(12)     = IPR(12) + 1
              JR(IPR(12)) = NIEN
   60       CONTINUE
          ENDIF
          IF (IPR(12) .GE. IPR(28) * 2) THEN
            VARDIST = 999.0
            CALL PLA085 (1, VARDIST)
            IF (NANAL .NE. 0) CALL PLA084 (NRES1, NRES2)
          ELSE
            CALL PLA015 (0, 31)
            WRITE (LU6, 99998)
          ENDIF
        ELSE
          LOOP = 1
          NW   = 0
          DO 70 I = 2, N
            IF (IFL(I) .EQ. 'WITH') THEN
              NW   = I
              LOOP = 2
            ENDIF
   70     CONTINUE
          DO 160 ILP = 1, LOOP
            IF (LOOP .EQ. 1) THEN
              IBEG = 2
              IEND = N
            ELSE
              IF (ILP .EQ. 1) THEN
                IBEG = 2
                IEND = NW - 1
              ELSE
                IBEG = NW + 1
                IEND = N
              ENDIF
            ENDIF
C * LEAST-SQUARES PLANE REQUESTED
            DO 80 I = 1, NMAX
              IATP(I) = I + 2 * NP1
   80       CONTINUE
            IMODE   = 0
            NDIST   = 0
            DO 90 I = IBEG, IEND
              IF (IFL(I) .EQ. 'DIST') THEN
                IMODE = 1
              ELSE
                CALL PLA046 (4, IFL(I), IENM, LBB, LBC, LBD,
     1                       XNQNR, YNQNR, NIEN)
                IF (NIEN .LT. 0) THEN
                  IF (NIEN .EQ. -4) THEN
                    GOTO 280
                  ELSE
                    GOTO 270
                  ENDIF
                ENDIF
                IPR(12)    = IPR(12) + 1 - IMODE
                NDIST      = NDIST + 1
                IATP(NIEN) = NIEN + IMODE * NP1
              ENDIF
   90       CONTINUE
            CALL GEN022 (IATP, 1, NMAX)
            IF (IEND - IBEG .GT. 1) THEN
              CALL PLA055
              DO 100 I = 1, 4
                XLS(I, ILP)     = XPV(I)
                XLS(I + 4, ILP) = XSPV(I)
  100         CONTINUE
              IFT = -10
              DO 110 I = 5, 8
                CALL GEN041 (XPV(I), XSPV(I), ISPV(I), 4, NDEC, IPR(68))
                IFT = IFT + 21
                FORM(IFT : IFT) = CHAR(ICHAR('0') + NDEC)
  110         CONTINUE
            ELSE
              CALL PLA227 (IATP(1), IATP(2), VECN)
              CALL PLA053 (IATP(1),IATP(2), 0, 0, D, SD, IDUM1,
     1          IDUM2, IER)
            ENDIF
            IF (IWIN .EQ. 1) THEN
              IF (ILP .EQ. 1) THEN
                CALL GGIP (HORS, VERT, 0.0, 1)
                VRT = VERT - 0.7
                WRITE (PRBUF, 99990)
                CALL GGIP20 (0.0, PRBUF, 80, 0.35, 5 + IGBL(68), 2,
     1                       1.0, VRT)
                VRT = VRT - 0.7
                WRITE (PRBUF, 99989)
                CALL GGIP20 (0.0, PRBUF, 80, 0.35, 5 + IGBL(68), 2,
     1                       1.0, VRT)
                WRITE (LU6, 99986)
                WRITE (LU6, 99990)
                WRITE (LU6, 99989)
              ELSE
                VRT = VRT - 1.0
                WRITE (LU6, 99987)
              ENDIF
              IF (IEND - IBEG .GT. 1) THEN
                WRITE (PRBUF, FORM) (XPV(I), ISPV(I), I = 5, 8)
                VRT = VRT - 0.6
                CALL GGIP20 (0.0, PRBUF, 80, 0.35, 1, 2, 1.0, VRT)
                WRITE (PRBUF, 99991)
                VRT = VRT - 0.7
                CALL GGIP20 (0.0, PRBUF, 80, 0.35, 5 + IGBL(68), 2,
     1                       1.0, VRT)
              ELSE IF (IEND - IBEG .EQ. 1) THEN
                CALL GGIP20 (0.0, '  Bond', 6, 0.35, 5 + IGBL(68), 2,
     1                       1.0, VRT)
              ENDIF
              VRT = VRT - 0.2
            ENDIF
            IF (IEND - IBEG .GT. 1) THEN
              WRITE (LU6, FORM) (XPV(I), ISPV(I), I = 5, 8)
              WRITE (LU6, 99987)
              WRITE (LU6, 99991)
              IF (IGBL(63) .GT. 1) THEN
                CALL PLA269 (8)
                WRITE (LU7, 99986)
                WRITE (LU7, 99990)
                WRITE (LU7, 99989)
                WRITE (LU7, FORM) (XPV(I), ISPV(I), I = 5, 8)
                WRITE (LU7, 99987)
                WRITE (LU7, 99991)
              ENDIF
            ENDIF
            CALL GEN003 (OR, UIJ, DET, 0)
            IF (DET .LE. 0.0) STOP 'CANNOT INVERT OR'
            IF (IEND - IBEG .GT. 1) THEN
              DO 130 I = 1, NDIST
                IF (I .GT. IPR(12)) THEN
                  INQ1 = ' '
                ELSE
                  INQ1 = '*'
                ENDIF
                IATPI = MOD(IATP(I), NP1)
                CALL PLA047 (XLAB(IATPI), NQ1, IDUM, JDUM, IPR(119),
     1                       IGBL(55), 0, 1 - IGBL(55))
                CALL PLA056 (XPV(1), IATPI, DIS, SDIS, ISDIS, 5, NDEC)
                ISDIS = MIN (99, ISDIS)
                FORME(19:19) = CHAR(ICHAR('0') + NDEC)
                DO 120 J = 1, 3
                  V2(J) = XXO(IATPI, J + 3)
  120           CONTINUE
                CALL GEN002 (1, UIJ, V2, V1, YUNK)
                WRITE (PRBUF, FORME) INQ1, NQ1, DIS, ISDIS,
     1                (V1(J), J = 1, 3), (V2(J), J = 1, 3)
                CALL GEN065 (LU6, PRBUF, 80, 1)
                IF (IWIN .EQ. 1) THEN
                  VRT = VRT - 0.45
                  CALL GGIP20 (0.0, PRBUF, 80, 0.35, 1, 2, 1.0, VRT)
                ENDIF
                IF (IGBL(63) .GT. 1) THEN
                  CALL PLA269 (1)
                  WRITE (LU7, 99999) PRBUF
                ENDIF
  130         CONTINUE
            ELSE IF (IEND - IBEG .EQ. 1) THEN
              DO 150 I = 1, 2
                CALL PLA047 (XLAB(IATP(I)), NQ1, IDUM, JDUM, IPR(119),
     1                       IGBL(55), 0, 1 - IGBL(55))
                DO 140 J = 1, 3
                  V2(J) = XXO(IATP(I), J + 3)
  140           CONTINUE
                CALL GEN002 (1, UIJ, V2, V1, YUNK)
                WRITE (PRBUF, 99985) NQ1,
     1                (V1(J), J = 1, 3), (V2(J), J = 1, 3)
                CALL GEN065 (LU6, PRBUF, 80, 1)
                IF (IWIN .EQ. 1) THEN
                  VRT = VRT - 0.45
                  CALL GGIP20 (0.0, PRBUF, 80, 0.35, 1, 2, 1.0, VRT)
                ENDIF
                IF (IGBL(63) .GT. 1) THEN
                  CALL PLA269 (1)
                  WRITE (LU7, 99999) PRBUF
                ENDIF
  150         CONTINUE
            ENDIF
  160     CONTINUE
          IF (LOOP .EQ. 2) THEN
            IF (IEND - IBEG .GT. 1) THEN
              ANG = GL(5) * ACOS(MIN(ABS(XLS(1, 1) * XLS(1, 2) +
     1          XLS(2, 1) * XLS(2, 2) + XLS(3, 1) * XLS(3, 2)), 1.0))
                SANG = 0
              DO 170 I = 5, 7
                SANG = SANG + XLS(I, 1)**2 + XLS(I, 2)**2
  170         CONTINUE
              SANG = GL(5) * SQRT(SANG)
              FORMH(3:10) = 'Dihedral'
            ELSE IF (IEND - IBEG .EQ. 1) THEN
              ANG = 90.0 - ACOS(MIN(ABS(XLS(1, 1) * VECN(1) +
     1          XLS(2, 1) * VECN(2) + XLS(3, 1) * VECN(3)), 1.0)) *
     2          GL(5)
              SANG = 0.0
              DO 180 L = 1, 3
                SANG = SANG + XLS(L + 4, 1)**2 + (VECN(L) * SD / D)**2
  180         CONTINUE
              SANG = GL(5) * SQRT(SANG)
              FORMH(3:10) = 'LsplBond'
            ENDIF
            IF (IEND - IBEG .GT. 0) THEN
              CALL GEN041 (ANG, SANG, ISANG, 2, NDEC, IPR(68))
              ISANG        = MIN (99, ISANG)
              FORMH(24:24) = CHAR(ICHAR('0') + NDEC)
              WRITE (PRBUF, FORMH) ANG, ISANG
              CALL GEN065 (LU6, PRBUF, 80, 1)
              IF (IWIN .EQ. 1) THEN
                VRT = VRT - 1.00
                CALL GGIP20 (0.0, PRBUF, 80, 0.35, 1, 2, 1.0, VRT)
              ENDIF
            ENDIF
          ENDIF
          IF (IPR(41) .EQ. 0) THEN
            PRBUF = 'UNIT WEIGHTS'
          ELSE IF (IPR(41) .EQ. 1) THEN
            PRBUF = 'ATWT WEIGHTS'
          ELSE
            PRBUF = 'ESD/SU WEIGHTS'
          ENDIF
          WRITE (LU6, 99988) PRBUF
          IF (IGBL(63) .GT. 1) THEN
            CALL PLA269 (2)
            WRITE (LU7, 99988) PRBUF
          ENDIF
          IF (IWIN .EQ. 1) THEN
            VRT = VRT - 1.0
            CALL GGIP20 (0.0, PRBUF, 30, 0.35, 5 + IGBL(68), 2,
     1                   1.0, VRT)
            CALL PLA297 (0)
          ENDIF
        ENDIF
C * DISTANCES & ANGLES
      ELSE
        DO 220 I = 2, N
          NQ2 = IFL(I)
          DO 200 J = 1, 2
            CALL PLA046 (4, NQ2, IENM, LBB, LBC, LBD,
     1                   XNQNR, YNQNR, NIEN)
            IF (NIEN .LT. 0) THEN
              IF (NIEN .EQ. -4) THEN
                DO 190 L = 1, 6
                  IF (NQ2(7-L:7-L) .NE. ' ') THEN
                    NQ2(8-L:8-L) = NQ2(7-L:7-L)
                    NQ2(7-L:7-L) = '_'
                    GOTO 200
                  ENDIF
  190           CONTINUE
              ENDIF
              GOTO 270
            ENDIF
            CALL PLA047 (XNQNR, NQ1, IDUM, JDUM, IPR(119), IGBL(55),
     1                   0, 1 - IGBL(55))
            NAMS(I, 1) = ' '//NQ1
            GOTO 210
  200     CONTINUE
          GOTO 280
  210     JATC(I) = NIEN
  220   CONTINUE
        IF (N .EQ. 2) THEN
          I   = JATC(2)
          NC  = - NINT(CON(I, NP4))
          IF (NC .LT. 0) NC = NP4
          DO 240 J = 1, NC
            J0 = NINT(CON(I, J))
            CALL PLA053 (I, J0, 0, 0, D, SD, ISD, NDEC, IER)
            IF (IER .EQ. 0) THEN
              FORMC(23:23) = CHAR(ICHAR('0') + NDEC)
              ISD = MIN (999, ISD)
              CALL PLA047 (XLAB(J0), NQ2, IDUM, JDUM, IPR(119),
     1                     IGBL(55), 0, 1 - IGBL(55))
              IF (MODE .EQ. 0) CALL PLA269 (1)
              WRITE (PRBUF, FORMC) NQ2, NQ1, D, ISD
              IF (MODE .EQ. 1) CALL GEN065 (LU6, PRBUF, 80, 1)
              IF (IGBL(63) .GT. 1) CALL GEN065 (LU7, PRBUF, 80, 1)
              DO 230 K = J + 1, NC
                IF (K .LE. NC) THEN
                  K0 = NINT(CON(I, K))
                  CALL PLA053 (K0, I, J0, 0, ANG, SANG, ISANG, NDEC,
     1                         IER)
                  IF (IER .EQ. 0) THEN
                    FORMD(22:22) = CHAR(ICHAR('0') + NDEC)
                    ISANG = MIN (999, ISANG)
                    CALL PLA047 (XLAB(K0), NQ3, IDUM, JDUM, IPR(119),
     1                           IGBL(55), 0, 1 - IGBL(55))
                    IF (MODE .EQ. 0) CALL PLA269 (1)
                    WRITE (PRBUF, FORMD) NQ2, NQ1, NQ3, ANG, ISANG
                    IF (MODE .EQ. 1) CALL GEN065 (LU6, PRBUF, 80, 1)
                    IF (IGBL(63) .GT. 1)
     1                CALL GEN065 (LU7, PRBUF, 80, 1)
                  ENDIF
                ENDIF
  230         CONTINUE
            ENDIF
  240     CONTINUE
        ELSE IF (N .EQ. 3) THEN
          CALL PLA053 (JATC(2), JATC(3), 0, 0, D, SD, ISD, NDEC, IER)
          IF (IER .EQ. 0) THEN
            ISD          = MIN (99, ISD)
            FORMB(36:36) = CHAR(ICHAR('0') + NDEC)
            WRITE (PRBUF, FORMB) (NAMS(I, 1)(2:8), I = 2, 3), D, ISD
            CALL GEN065 (LU6, PRBUF, 80, 1)
            IF (IGBL(63) .GT. 1) CALL PLA067 (LU7, PRBUF, 80, 1, 1)
          ELSE
            WRITE (LU6, 99995)
          ENDIF
        ELSE IF (N .EQ. 4) THEN
          CALL PLA053 (JATC(2), JATC(3), JATC(4), 0, ANG, SANG,
     1                 ISANG, NDEC, IER)
          IF (IER .EQ. 0) THEN
            ISANG        = MIN (999, ISANG)
            FORMA(36:36) = CHAR(ICHAR('0') + NDEC)
            WRITE (PRBUF, FORMA) (NAMS(I, 1)(2:8), I = 2, 4),
     1             ANG, ISANG
            CALL GEN065 (LU6, PRBUF, 80, 1)
            IF (IGBL(63) .GT. 1) CALL PLA067 (LU7, PRBUF, 80, 1, 1)
          ELSE
            WRITE (LU6, 99995)
          ENDIF
        ELSE IF (N .EQ. 5) THEN
          IF (IFL(1)(1:3) .EQ. 'ANG' .OR. IPR(341) .EQ. 5) THEN
            NEX = NMAX + 1
            DO 250 I = 4, 6
              XXO(NEX, I) = XXO(JATC(5), I) + XXO(JATC(2), I)
     1                    - XXO(JATC(4), I)
              XSD(NEX, I) = XSD(JATC(5), I)
  250       CONTINUE
            CALL PLA053 (JATC(3), JATC(2), NEX, 0, ANG, SANG,
     1                   ISANG, NDEC, IER)
            IF (IER .EQ. 0) THEN
              ISANG        = MIN (999, ISANG)
              FORML(46:46) = CHAR(ICHAR('0') + NDEC)
              WRITE (PRBUF, FORML) (NAMS(I, 1)(2:8), I = 2, 5),
     1             ANG, ISANG
              CALL GEN065 (LU6, PRBUF, 80, 1)
              IF (IGBL(63) .GT. 1) CALL PLA067 (LU7, PRBUF, 80, 1, 1)
            ENDIF
          ELSE
            CALL PLA053 (JATC(2), JATC(3), JATC(4), JATC(5),
     1                   ANG, SANG, ISANG, NDEC, IER)
            IF (IER .EQ. 0) THEN
              ISANG        = MIN (999, ISANG)
              FORMT(36:36) = CHAR(ICHAR('0') + NDEC)
              CALL PLA050 (JATC(2), JATC(3), JATC(4), 0, ANG1)
              CALL PLA050 (JATC(3), JATC(4), JATC(5), 0, ANG2)
              CALL PLA050 (JATC(2), JATC(3), 0, 0, DIS1)
              CALL PLA050 (JATC(3), JATC(4), 0, 0, DIS2)
              CALL PLA050 (JATC(4), JATC(5), 0, 0, DIS3)
              WRITE (PRBUF, FORMT) (NAMS(I, 1)(2:8), I = 2, 5),
     1               ANG, ISANG
              CALL GEN065 (LU6, PRBUF, 80, 1)
              WRITE (LU6, 99996) ANG1, ANG2, DIS1, DIS2, DIS3
              IF (IGBL(63) .GT. 1) THEN
                CALL PLA067 (LU7, PRBUF, 80, 1, 1)
                CALL PLA269 (2)
                WRITE (LU7, 99996) ANG1, ANG2, DIS1, DIS2, DIS3
              ENDIF
            ENDIF
          ENDIF
        ELSE
          GOTO 280
        ENDIF
      ENDIF
  260 IF (MODE .EQ. 1) THEN
        IF (IFL(1)(1:3) .EQ. 'DIS' .OR. IFL(1)(1:3) .EQ. 'ANG'
     1      .OR. IFL(1)(1:3) .EQ. 'TOR' .OR. IPR(341) .NE. 0) THEN
          IF (IPR(2) .NE. 0) THEN
            PRBUF = 'Label Error :  '//IFL(I)
            IPR(2)   = 0
            WRITE (LU6, 99999) PRBUF(1:50)
          ENDIF
          IF (IGBL(25) * IGBL(32) .EQ. 1) THEN
            IGBL(23) = - IABS(IGBL(23))
            SBCD = PRBUF(1:60)//CHAR(0)
          ENDIF
        ENDIF
      ENDIF
      RETURN
  270 IPR(2) = 3
      GOTO 260
  280 IPR(2) = 7
      GOTO 260
99999 FORMAT (A)
99998 FORMAT (/, ':: Not Enough Atoms to Fit on', /)
99997 FORMAT ('Selected Geometrical Data', /, 132('=')/)
99996 FORMAT ('ANGLE', 6X, F9.2, F10.2, /, 'BOND', 2X, 3(F10.4))
99995 FORMAT (':: Input Error, Try again')
99994 FORMAT (/, ':: Fit for RESD =', I3,
     1        ' and RESD =', I3, ' [N(fit) =', I3, ']')
99993 FORMAT (/, ':: Residues contain unequal number of atoms, nofit')
99991 FORMAT  (2X, 'Atom', 12X, 'Distance', 8X, 'x', 7X,
     1        'y', 7X, 'z', 6X, 'X', 7X, 'Y', 7X, 'Z')
99990 FORMAT ('The equation of the plane is of the form:',
     1           ' P * x + Q * y + R * z - S = 0')
99989 FORMAT ('where P, Q, R, S are constants and x, y, z',
     1           ' are fractional coordinates.')
99988 FORMAT (/, A)
99987 FORMAT (1X)
99986 FORMAT (//)
99985 FORMAT (2X, A, 20X, 6F8.4)
      END
      SUBROUTINE PLA036 (IAT, KB, NA, IDS, MNUM, ISPOS, IPAR, IALIAS)
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16,
     1 NP11=128,NP19=31,NP22=256,NP25=99,NP29=63,NP41=200,NP47=9)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      CHARACTER NQ*7
      I = IABS(IAT)
      IF (IAT .GT. 0) THEN
        XLABI =   XLAB(I)
      ELSE
        XLABI = - XLAB(I)
      ENDIF
      CALL GEN048 (-1, IFG(I), 6, ISPOS)
      CALL GEN048 (-7, JFG(I), 1, IDS)
      IDS = IPPR(IDS + 1, 1)
      IF (IDS .EQ. 1000) THEN
        NAMDIS = ICHAR(' ')
      ELSE IF (IDS .GT. 500) THEN
        NAMDIS = ICHAR('>')
      ELSE IF (IDS .EQ. 500) THEN
        NAMDIS = ICHAR('*')
      ELSE
        NAMDIS = ICHAR('<')
      ENDIF
      CALL PLA047 (XLABI, NQ, MNUM, JDUM, IPAR, IALIAS, 0, 1 - IALIAS)
      NAMS(KB, NA) = CHAR(NAMDIS)//NQ
      RETURN
      END
      SUBROUTINE PLA037 (K, N, M)
      PARAMETER (NP4=9,NP9=118,NP10=16,NP12=600,NP13=500,NP17=99,
     1 NP22=256,NP38=125,NP39=30,NP45=2048)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /Q/ ICL, IFL(NP17)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9),
     1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10),
     2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10),
     3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770)
      NQ3 = IFL(K)
      IF (NQ3(3:3) .EQ. ' ') THEN
        DO 20 I = 1, 26
          IF (NQ3(1:1) .EQ. CHAR(ICHAR('A') + I - 1)) THEN
            N = I * 100
            IF (NQ3(2:2) .EQ. ' ') GOTO 30
            DO 10 J = 1, 26
              IF (NQ3(2:2) .EQ. CHAR(ICHAR('A') + J - 1)) THEN
                N =  N + J
                GOTO 30
              ENDIF
   10       CONTINUE
            GOTO 50
          ENDIF
   20   CONTINUE
   30   DO 40 J = 1, IAN
          IF (N .EQ. IEL(IEN(J))) THEN
            N = J
            GOTO 70
          ENDIF
   40   CONTINUE
      ENDIF
   50 N = 0
      CALL PLA046 (M, NQ3, IENM, LBB, LBC, LBD,
     1             XNQNR, YNQNR, NIEN)
      IF (NIEN .LT. 0) THEN
        IPR(2) = 3
      ELSE
        N = - NIEN
      ENDIF
   70 RETURN
      END
      SUBROUTINE PLA038 (IAT, JAT, IFIN)
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118,
     1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP22=256,
     2 NP25=99,NP29=63,NP38=125,NP39=30,NP41=200,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9),
     1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10),
     2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10),
     3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770)
      COMMON /PL38/ IENI, KI, IMET, JMET, LABI, NC, IATNRI, IXX, NAT
C * SUBROUTINE GENERATES SEQUENCE OF UNIQUE BONDS (IAT, JAT)
C * INITIALIZED BY IFIN = -3, -2, -1 ; END SIGNAL WITH IFIN = 1 ON RETURN
      IF (IFIN .EQ. 0) THEN
        GOTO 40
      ELSE IF (IFIN .EQ. -3) THEN
        NAT = IPR(39)
        IXX = 0
      ELSE IF (IFIN .EQ. -2) THEN
        NAT = IPR(39)
        IXX = 1
      ELSE
        NAT = IPR(37)
        IXX = 0
      ENDIF
      IFIN = 0
      IAT  = 0
      IMET = 0
      JMET = 0
      IENI = 0
   10 IAT  = IAT + 1
      IF (IAT .GT. NAT) THEN
        IFIN = 1
        GOTO 90
      ENDIF
      CALL GEN048 (-1, IFG(IAT), 7, IHA)
      IF (IHA .EQ. 1) GOTO 10
      CALL GEN048 (-1, IFG(IAT), 19, IMET)
      CALL PLA047 (XLAB(IAT), NQ1, IDUM, IENI, IPR(119), IGBL(55),
     1  0, 1 - IGBL(55))
      IF (IXX .EQ. 0) THEN
        IATNRI = IATNR(IENI)
        LABI   = NINT(XLAB(IAT)) / IPR(463)
      ENDIF
      NC = - NINT(CON(IAT, NP4))
      IF (NC .EQ. 0) THEN
        GOTO 10
      ELSE IF (NC .LT. 0) THEN
        NC = NP4
        CALL GEN048 (-1, IFG(IAT), 8, IVAL)
        IF (IVAL .GT. 0) NC = NC + IPR(76)
      ENDIF
      KI = 0
   40 KI = KI + 1
      IF (KI .GT. NC) GOTO 10
      IF (KI .LE. NP4) THEN
        JAT = NINT(CON(IAT, KI))
      ELSE
        IF (IBON(KI - NP4, 1) .EQ. IAT) THEN
          JAT = IBON(KI - NP4, 2)
        ELSE
          GOTO 40
        ENDIF
      ENDIF
      IF (IPR(133) .GE. 0) THEN
        CALL GEN048 (-1, IFG(JAT), 7, IHA)
        IF (IHA .NE. IPR(133)) GOTO 40
      ENDIF
      CALL PLA047 (XLAB(JAT), NQ2, IDUM, IENJ, IPR(119), IGBL(55),
     1     0, 1 - IGBL(55))
      CALL GEN048 (-1, IFG(JAT), 19, JMET)
      IF (IMET .EQ. 1 .AND. IENJ .EQ. 2 .OR.
     1    JMET .EQ. 1 .AND. IENI .EQ. 2) THEN
        NDIST = 0
        IF (IENJ .EQ. 2) THEN
          NCJ   = - NINT(CON(JAT, NP4))
          DO 50 KJ = 1, NCJ
            KAT = NINT(CON(JAT, KJ))
            CALL GEN048 (-4, IFG(KAT), 15, NEL)
            NEL = IEN(NEL + 1)
            IF (NEL .EQ. 3) THEN
              CALL PLA050 (IAT, KAT, 0, 0, DIST)
              IF (IENI .GT. 0) THEN
                IF (DIST .LT. REL(IENI) + 1.10) NDIST = NDIST + 1
              ENDIF
            ENDIF
   50     CONTINUE
          IF (NDIST .GE. 2) GOTO 40
        ELSE
          NCI = - NINT(CON(IAT, NP4))
          DO 60 K = 1, NCI
            KAT = NINT(CON(IAT, K))
            CALL GEN048 (-4, IFG(KAT), 15, NEL)
            NEL = IEN(NEL + 1)
            IF (NEL .EQ. 3) THEN
              CALL PLA050 (JAT, KAT, 0, 0, DIST)
              IF (DIST .LT. REL(IENJ) + 1.20) NDIST = NDIST + 1
            ENDIF
   60     CONTINUE
          IF (NDIST .GE. 2) GOTO 40
        ENDIF
      ENDIF
      IF (IXX .EQ. 0) THEN
        JUNK = IATNRI - IATNR(IENJ)
        IF (JUNK .LT. 0) THEN
          GOTO 40
        ELSE IF (JUNK .EQ. 0) THEN
          LABJ = NINT(XLAB(JAT)) / IPR(463)
          IF (LABI .GT. LABJ) GOTO 40
        ENDIF
      ENDIF
   90 RETURN
      END
      SUBROUTINE PLA039 (IAT, JAT, KAT, NRSD, A, SA, ISA, ND, KB, IFIN)
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16,
     1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP25=99,NP29=63,
     2 NP38=125,NP39=30,NP41=200,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /PL39/ NAT, NC, KI, KJ, IHI, IHJ, IHK
      IF (IFIN .EQ. 0) THEN
        GOTO 50
      ELSE IF (IFIN .EQ. -1) THEN
        NAT = IPR(37)
      ENDIF
      IFIN = 0
      JAT  = 0
   10 JAT  = JAT + 1
      IF (JAT .GT. NAT) THEN
        IFIN = 1
        GOTO 250
      ENDIF
      CALL GEN048 (-1, IFG(JAT), 7,  IHJ)
      IF (IHJ .EQ. 1) GOTO 10
      CALL GEN048 (-6, IFG(JAT), 9, IRESJ)
      IF (IRESJ .NE. NRSD) GOTO 10
      NC = - NINT(CON(JAT, NP4))
      IF (NC .LT. 0) THEN
        NC = NP4
        CALL GEN048 (-1, IFG(JAT), 8, IVAL)
        IF (IVAL .GT. 0) NC = NC + IPR(76)
      ENDIF
      IF (NC .LE. 1) GOTO 10
      KI = 0
   40 KI = KI + 1
      IF (KI .GE. NC) GOTO 10
      IF (KI .LE. NP4) THEN
        IAT = NINT(CON(JAT, KI))
      ELSE
        IF (IBON(KI - NP4, 1) .NE. JAT) GOTO 40
        IAT = IBON(KI - NP4, 2)
      ENDIF
      KJ = KI
      CALL GEN048 (-1, IFG(IAT), 7,  IHI)
   50 KJ = KJ + 1
      IF (KJ .GT. NC) GOTO 40
      IF (KJ .LE. NP4) THEN
        KAT = NINT(CON(JAT, KJ))
      ELSE
        IF (IBON(KJ - NP4, 1) .NE. JAT) GOTO 50
        KAT = IBON(KJ - NP4, 2)
      ENDIF
      CALL GEN048 (-1, IFG(KAT), 7,  IHK)
      IHA  = IHI + IHJ + IHK
      IF (IPR(133) .EQ. 0) THEN
        IF (IHA .GT. 0) GOTO 50
      ELSE
        IF (IHA .EQ. 0) GOTO 50
      ENDIF
      KB1 = KB + 1
      CALL PLA036 (IAT, KB1, 1, IDS1, MNUM1, ISP1, IPR(119), IGBL(55))
      CALL PLA036 (JAT, KB1, 2, IDS2, MNUM2, ISP2, IPR(119), IGBL(55))
      CALL PLA036 (KAT, KB1, 3, IDS3, MNUM3, ISP3, IPR(119), IGBL(55))
      IF (IDS1 .LT. 1000 .AND. IDS3 .LT. 1000) THEN
        IF (IDS1 .NE. IDS3) GOTO 50
        IF (IDS2 .LT. 1000) THEN
          IF (IDS1 .NE. IDS2 .OR. IDS2 .NE. IDS3) GOTO 50
        ENDIF
      ENDIF
      CALL PLA053 (IAT, JAT, KAT, 0, A, SA, ISA, ND, IER)
      IF (IER .NE. 0) GOTO 50
      IF (ISP2 .EQ. 1 .AND. MNUM3 .GT. 1) THEN
        CALL PLA050 (IAT, JAT, KAT, 0, A1)
        IF (ABS(A1) .GT. 179.9) THEN
          A  = 180.0
          SA = 0.0
        ENDIF
      ENDIF
  250 RETURN
      END
      SUBROUTINE PLA040 (MODE, MD1, MD2, MD3, MD4)
      PARAMETER (NP12=600,NP13=500,NP17=99,NP38=125,NP39=30)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /PL40/ LHNT(4, 3, 5), NETH(64, 3), MXL
      DIMENSION KVEC(4)
      IF (IPR(17) .LT. 0) THEN
        NRX = 0
      ELSE
        NRX = IPR(75)
      ENDIF
      IF (MODE .LT. 0) THEN
        MXL = 0
      ELSE IF (MODE .EQ. 0) THEN
        IF (MXL .GT. 0) THEN
          IPRINT = 0
          N = -1
   10     N = N + 1
          IF (N .GT. NRX) GOTO 70
          DO 60 L = 1, MXL
            IF (NETH(L, 1) .EQ. N) THEN
              IF (IGBL(63) .GT. 2) CALL PLA269 (2)
              IF (NETH(L, 2) .EQ. 1) THEN
                WRITE (LU6, 99995) NETH(L, 1),
     1             (LHNT(1, J, L), J = 1, 3)
                IF (IGBL(63) .GT. 2) THEN
                  IPRINT = IPRINT + 1
                  IF (IPRINT .EQ. 1) THEN
                    IF (IPR(51) .GT. 1) THEN
                      WRITE (LU7, 99990)
                      CALL PLA269 (2)
                    ENDIF
                    CALL PLA269 (2)
                    WRITE (LU7, 99991)
                  ENDIF
                  WRITE (LU7, 99999) NETH(L, 1),
     1               (LHNT(1, J, L), J = 1, 3)
                  CALL PLA269 (1)
                ENDIF
              ELSE IF (NETH(L, 2) .EQ. 2) THEN
                LHNT(3, 1, L) = LHNT(1, 2, L) * LHNT(2, 3, L)
     1                        - LHNT(1, 3, L) * LHNT(2, 2, L)
                LHNT(3, 2, L) = LHNT(1, 3, L) * LHNT(2, 1, L)
     1                        - LHNT(1, 1, L) * LHNT(2, 3, L)
                LHNT(3, 3, L) = LHNT(1, 1, L) * LHNT(2, 2, L)
     1                        - LHNT(1, 2, L) * LHNT(2, 1, L)
                DO 40 I = 1, 3
                  IVL = LHNT(3, I, L)
                  IF (IVL .NE. 0) THEN
                    DO 20 J = 1, 3
                      IVL1 = LHNT(3, J, L) / IVL
                      IF (IVL1 * IVL .NE. LHNT(3, J, L)) GOTO 40
   20               CONTINUE
                    DO 30 J = 1, 3
                      LHNT(3, J, L) = LHNT(3, J, L) / IVL
   30               CONTINUE
                    GOTO 50
                  ENDIF
   40           CONTINUE
   50           WRITE (LU6, 99994) NETH(L, 1),
     1             (I, (LHNT(I, J, L), J = 1, 3), I = 1, 2),
     2                            (LHNT(3, J, L), J = 1, 3)
                IF (IGBL(63) .GT. 2) THEN
                  IPRINT = IPRINT + 1
                  IF (IPRINT .EQ. 1) THEN
                    IF (IPR(51) .GT. 1) THEN
                      WRITE (LU7, 99990)
                      CALL PLA269 (2)
                    ENDIF
                    CALL PLA269 (2)
                    WRITE (LU7, 99991)
                  ENDIF
                  WRITE (LU7, 99998) NETH(L, 1),
     1             (I, (LHNT(I, J, L), J = 1, 3), I = 1, 2),
     2                            (LHNT(3, J, L), J = 1, 3)
                  CALL PLA269 (1)
                ENDIF
              ELSE IF (NETH(L, 2) .EQ. 3) THEN
                WRITE (LU6, 99993) NETH(L, 1), NETH(L, 3),
     1                        (I, (LHNT(I, J, L), J = 1, 3), I = 1, 3)
                IF (IGBL(63) .GT. 2) THEN
                  IPRINT = IPRINT + 1
                  IF (IPRINT .EQ. 1) THEN
                    IF (IPR(51) .GT. 1) THEN
                      WRITE (LU7, 99990)
                      CALL PLA269 (2)
                    ENDIF
                    CALL PLA269 (2)
                    WRITE (LU7, 99991)
                  ENDIF
                  WRITE (LU7, 99997) NETH(L, 1), NETH(L, 3),
     1                        (I, (LHNT(I, J, L), J = 1, 3), I = 1, 3)
                  CALL PLA269 (1)
                ENDIF
              ENDIF
              IF (IPR(17) .EQ. 0) THEN
                IPR(322) = MXL
              ELSE IF (IPR(17) .LT. 0) THEN
              ENDIF
              NETH(L, 2) = 0
              NETH(L, 3) = 0
            ENDIF
   60     CONTINUE
          GOTO 10
   70     CONTINUE
        ENDIF
      ELSE
        IF (MXL .GT. 0) THEN
          DO 80 L = 1, MXL
            IF (NETH(L, 1) .EQ. MD4) GOTO 90
   80     CONTINUE
        ENDIF
        IF (MXL .LT. 5) THEN
          MXL = MXL + 1
        ELSE
          WRITE (LU6, 99996)
          GOTO 260
        ENDIF
        NETH(MXL, 1) = MD4
        NETH(MXL, 2) = 0
        NETH(MXL, 3) = 99999
        L            = MXL
   90   K1           = MD1
        K2           = MD2
        K3           = MD3
        IF (K1 .EQ. 0) THEN
          GOTO 120
        ELSE IF (K1 .GT. 0) THEN
          GOTO 130
        ENDIF
        K1           = - K1
  100   K2           = - K2
  110   K3           = - K3
        GOTO 130
  120   IF (K2 .LT. 0) THEN
          GOTO 100
        ELSE IF (K2 .GT. 0) THEN
          GOTO 130
        ENDIF
        IF (K3 .LT. 0) GOTO 110
  130   LHNT(NETH(L, 2) + 1, 1, L) = K1
        LHNT(NETH(L, 2) + 1, 2, L) = K2
        LHNT(NETH(L, 2) + 1, 3, L) = K3
        NDIM = NETH(L, 2)
        IF (NDIM .EQ. 2) THEN
          DO 150 I = 1, 3
            IF (LHNT(1, I, L) .EQ. 1) THEN
              N = LHNT(2, I, L)
              IF (N .NE. 0) THEN
                DO 140 J = 1, 3
                  LHNT(2, J, L) = LHNT(2, J, L) - N * LHNT(1, J, L)
  140           CONTINUE
                GOTO 160
              ENDIF
            ENDIF
  150     CONTINUE
  160     CONTINUE
        ENDIF
        IF (NETH(L, 2) .EQ. 1) THEN
          IF ((LHNT(1, 1, L) * LHNT(2, 2, L) -
     1         LHNT(2, 1, L) * LHNT(1, 2, L) .EQ. 0) .AND.
     2        (LHNT(1, 1, L) * LHNT(2, 3, L) -
     3         LHNT(2, 1, L) * LHNT(1, 3, L) .EQ. 0) .AND.
     4        (LHNT(1, 2, L) * LHNT(2, 3, L) -
     5         LHNT(2, 2, L) * LHNT(1, 3, L) .EQ. 0)) THEN
            IF ((IABS(LHNT(2, 1, L)) + IABS(LHNT(2, 2, L)) +
     1           IABS(LHNT(2, 3, L))) .LT.
     2          (IABS(LHNT(1, 1, L)) + IABS(LHNT(1, 2, L)) +
     3           IABS(LHNT(1, 3, L)))) THEN
              DO 170 K = 1, 3
                LHNT(1, K, L) = LHNT(2, K, L)
  170         CONTINUE
            ENDIF
            GOTO 260
          ENDIF
        ELSE IF (NETH(L, 2) .EQ. 2) THEN
          CALL PLA058 (1, 2, 3, L, IDET)
          NETH(L, 3) = IDET
          IF (NETH(L, 3) .EQ. 0) GOTO 260
        ELSE IF (NETH(L, 2) .EQ. 3) THEN
          IF (NETH(L, 3) .GT. 1) THEN
            CALL PLA058 (1, 2, 4, L, IDET)
            IF (IDET .GT. 0 .AND. IDET .LT. NETH(L, 3)) THEN
              NETH(L, 3) = IDET
              DO 180 K = 1, 3
                LHNT(3, K, L) = LHNT(4, K, L)
  180         CONTINUE
              GOTO 260
            ENDIF
            CALL PLA058 (1, 3, 4, L, IDET)
            IF (IDET .GT. 0 .AND. IDET .LT. NETH(L, 3)) THEN
              NETH(L, 3) = IDET
              DO 190 K = 1, 3
                LHNT(2, K, L) = LHNT(4, K, L)
  190         CONTINUE
              GOTO 260
            ENDIF
            CALL PLA058 (2, 3, 4, L, IDET)
            IF (IDET .GT. 0 .AND. IDET .LT. NETH(L, 3)) THEN
              NETH(L, 3) = IDET
              DO 200 K = 1, 3
                LHNT(1, K, L) = LHNT(4, K, L)
  200         CONTINUE
              GOTO 260
            ENDIF
          ENDIF
          GOTO 260
        ENDIF
        NETH(L, 2) = NETH(L, 2) + 1
        NRDIM = NETH(L, 2)
        IF (NRDIM .GT. 1) THEN
  210     DO 230 K = 1, NRDIM
            KVEC(K) = 0
            DO 220 I = 1, 3
              KVEC(K) = KVEC(K) + 10**(3 - I) * LHNT(K, I, L)
  220       CONTINUE
            N = IABS(KVEC(K))
            IF (N .EQ. 1 .OR. N .EQ. 10 .OR. N .EQ. 100) THEN
              IF (KVEC(K) .LT. 0) THEN
                LHNT(K, 1, L) = IABS(LHNT(K, 1, L))
                LHNT(K, 2, L) = IABS(LHNT(K, 2, L))
                LHNT(K, 3, L) = IABS(LHNT(K, 3, L))
                GOTO 210
              ENDIF
            ENDIF
  230     CONTINUE
          DO 250 I = 1, NRDIM
            N = KVEC(I)
            IF (N .EQ. 1) THEN
              K = 3
            ELSE IF (N .EQ. 10) THEN
              K = 2
            ELSE IF (N .EQ. 100) THEN
              K = 1
            ELSE
              GOTO 250
            ENDIF
            DO 240 J = 1, NRDIM
              IF (J .NE. I) THEN
                IF (LHNT(J, K, L) .NE. 0) THEN
                  LHNT(J, K, L) = 0
                  GOTO 210
                ENDIF
              ENDIF
  240       CONTINUE
  250     CONTINUE
        ENDIF
      ENDIF
  260 RETURN
99999 FORMAT (/,':: Resd #', I2,
     1 ' - Infinite One-Dimensional Chain   :: Base Vector: [',
     2   3I3, ']')
99998 FORMAT (/,':: Resd #', I2,
     1 ' - Infinite Two-Dimensional Network :: Base Vectors',
     1 ':', 2(' #', I1, ' = [', 3I3, '], '), ' - Plane: (', 3I3, ')')
99997 FORMAT (/,':: Resd #', I2,
     1 ' - Infinite Three-Dimensional Framework :: Det =',
     2 I2, ', Base Vectors: ', 3(' #', I1, ' =[', 3I3, '], '))
99996 FORMAT (/, ':: Maximum number of Polymeric Residues Exceeded')
99995 FORMAT (/, ':: Resd #', I2, ' - Infinite One-Dimensional Chain',
     1   /, ':: Base Vector: ', 3I3)
99994 FORMAT (/, ':: Resd #', I2,
     1   ' - Infinite Two-Dimensional Network', /,
     2   ':: Base Vectors: ', 2(I5, ' : [', 3I3, '], '),
     3   ' Plane: (', 3I3, ')')
99993 FORMAT (/, ':: Resd #', I2,
     1 ' - Infinite Three-Dimensional Framework : Det =',
     2 I2, /, ':: Base Vectors: ', 3(I5, ' : ', 3I3, ' , '))
99991 FORMAT (/, ':: Analysis of Polymeric Structure(s)')
99990 FORMAT (/, ':: Starred ARUs belong (chemically) to the ',
     1           'previous ARU')
      END
      SUBROUTINE PLA041 (MODE, I, J, IVAL)
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16,
     1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP25=99,NP29=63,
     2 NP38=125,NP39=30,NP41=200,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      IF (MODE .LT. 0) THEN
        NC = - NINT(CON(I, NP4))
        IF (NC .EQ. 0) THEN
          GOTO 30
        ELSE IF (NC .GT. 0) THEN
          GOTO 10
        ENDIF
        NC = NP4
        CALL GEN048 (-1, IFG(I), 8, IVL)
        IF (IVL .GT. 0) NC = NC + IPR(76)
   10   DO 20 L = 1, NC
          IF (L .GT. NP4) THEN
            IF (IBON(L - NP4, 1) .NE. I) GOTO 20
            IF (IBON(L - NP4, 2) .EQ. IVAL) GOTO 40
          ELSE
            IF (NINT(CON(I, L)) .EQ. IVAL) GOTO 40
          ENDIF
   20   CONTINUE
   30   J = 0
        GOTO 60
   40   J = L
      ELSE IF (MODE .EQ. 0) THEN
        DO 50 K = I, J
          CON(K, NP4) = IVAL
   50   CONTINUE
      ELSE
        J = 0
        IPR(147) = IPR(147) + 1
        IF (CON(I, NP4) .GT. 0) THEN
          CALL GEN048 (1, IFG(I), 8, 1)
          IF (IPR(76) .NE. IPR(96)) THEN
            IPR(76)          = IPR(76) + 1
            IBON(IPR(76), 1) = I
            IBON(IPR(76), 2) = IVAL
            J                = NP4 + IPR(76)
          ENDIF
        ELSE
          CON(I, NP4) =   CON(I, NP4) - 1
          J           = - NINT(CON(I, NP4))
          CON(I, J)   =   IVAL
        ENDIF
      ENDIF
   60 RETURN
      END
      SUBROUTINE PLA042 (MODE)
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16,
     1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP22=256,NP25=99,
     2 NP29=63,NP38=125,NP39=30,NP41=200,NP45=2048,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /Q/ ICL, IFL(NP17)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      CHARACTER FCELA*120, FCELB*89, FCELC*89, FCELV*94
      COMMON /TODAY/ DATIJD
      CHARACTER DATIJD*25
      FCELA(  1: 38) = '( ''a ='',F9.4,''('',I3,'')  Angstrom'',16X,'
      FCELA( 39: 75) = '''alpha ='',F9.3,''('',I3,'') Degree'',13X,'
      FCELA( 76:106) = '''a  ='',F9.3,5X,''alpha  ='',F8.2,'
      FCELA(107:120) = '''  V  ='',F8.1)'
      FCELB(  1: 28) = '( ''b ='',F9.4,''('',I3,'')'',26X,'
      FCELB( 29: 58) = ''' beta ='',F9.3,''('',I3,'')'',20X,'
      FCELB( 59: 89) = '''b  ='',F9.3,5X,''beta   ='',F8.2)'
      FCELC(  1: 28) = '( ''c ='',F9.4,''('',I3,'')'',26X,'
      FCELC( 29: 58) = '''gamma ='',F9.3,''('',I3,'')'',20X,'
      FCELC( 59: 89) = '''c  ='',F9.3,5X,''gamma  ='',F8.2)'
      FCELV(  1: 40) = '( ''V ='',F9.2,''('',I3,'')  Cubic-Angstrom'','
      FCELV( 41: 63) = '9X,''d(100) ='',F12.4,3X,'
      FCELV( 64: 94) = '''Angstrom'',24X,''Niggli Values'')'
      IF (MODE .NE. 2) THEN
        IF (SPGRNM(1)(12:12) .EQ. 'a') THEN
          IF (ABS(PAR(101) - PAR(123)) .GT. 0.01 .OR.
     1        ABS(PAR(102) - PAR(124)) .GT. 0.01 .OR.
     2        ABS(PAR(103) - PAR(125)) .GT. 0.01 .OR.
     3        ABS(PAR(104) - PAR(126)) .GT. 0.1  .OR.
     4        ABS(PAR(105) - PAR(127)) .GT. 0.1  .OR.
     5        ABS(PAR(106) - PAR(128)) .GT. 0.1)
     6        WRITE (LU20, 99992) '_155         1         1'
        ENDIF
      ENDIF
      IF (IGBL(63) .GT. 2) THEN
        CALL PLA269 (-5)
        WRITE (LU7, 99999) IGBL(9), JID(1:71), DATIJD(5:24)
      ENDIF
      IF (IPR(23) .NE. 0) THEN
        WRITE (LU6, 99995) PAR(11)
      ELSE
        IF (SPGRNM(1)(8:11) .EQ. '    ') THEN
          II = ICHAR(' ')
        ELSE
          II = ICHAR('.')
        ENDIF
        WRITE (LU6, 99998) JID(1:70), (PAR(100 + I), I = 1, 6), PAR(98),
     1              SPGRNM(1)(1:7), CHAR(II), SPGRNM(1)(8:11), CHSG
        IPR(83) = 34
        IF (IGBL(63) .GT. 2) THEN
          WRITE (LU7, 99993) SPGRNM(1)(13:13), MAX (0, IPR(310))
          FCELA(12 : 12) = CHAR(ICHAR('0') + IPR(287))
          FCELA(52 : 52) = CHAR(ICHAR('0') + IPR(290))
          WRITE (PRBUF, FCELA) PAR(101), IPR(281), PAR(104), IPR(284),
     1           PAR(123), PAR(126), PAR(99)
          CALL GEN065 (LU7, PRBUF, 132, 3)
          FCELB(12 : 12) = CHAR(ICHAR('0') + IPR(288))
          FCELB(42 : 42) = CHAR(ICHAR('0') + IPR(291))
          WRITE (PRBUF, FCELB) PAR(102), IPR(282), PAR(105), IPR(285),
     1           PAR(124), PAR(127)
          CALL GEN065 (LU7, PRBUF, 132, 3)
          FCELC(12 : 12) = CHAR(ICHAR('0') + IPR(289))
          FCELC(42 : 42) = CHAR(ICHAR('0') + IPR(292))
          WRITE (PRBUF, FCELC) PAR(103), IPR(283), PAR(106), IPR(286),
     1           PAR(125), PAR(128)
          CALL GEN065 (LU7, PRBUF, 132, 3)
          WRITE (LU7, 99991)
          FCELV(12 : 12) = CHAR(ICHAR('0') + IPR(294))
          WRITE (PRBUF, FCELV) PAR(98), IPR(293), 1.0 / PAR(113)
          CALL GEN065 (LU7, PRBUF, 132, 3)
          WAVL = MAX (0.0, PAR(17))
          WRITE (LU7, 99990) 1.0 / PAR(114), (PAR(150 + J), J = 1, 3),
     1           KRAD, WAVL, 1.0 / PAR(115), (PAR(150 + J), J = 4, 6)
          CALL PLA269 (1)
          WRITE (LU7, 99997)
          WRITE (LU7, 99994)
          WRITE (PRBUF, 99989) (OR(1, J), J = 1, 3),
     1                        (ROR(1, K), K = 1, 3)
          CALL GEN065 (LU7, PRBUF, 132, 2)
          WRITE (PRBUF, 99988) (OR(2, J), J = 1, 3),
     1                        (ROR(2, K), K = 1, 3)
          CALL GEN065 (LU7, PRBUF, 132, 2)
          WRITE (PRBUF, 99987) (OR(3, J), J = 1, 3),
     1                        (ROR(3, K), K = 1, 3)
          CALL GEN065 (LU7, PRBUF, 132, 2)
          IF (MODE .GT. 0) THEN
            WRITE (LU7, 99996)
            IF (SPGRNM(1)(1:1) .NE. ' ') THEN
              NRXX = 0
              IF (INDEX (SPGRNM(1)(1:11), ':') .NE. 0) THEN
                WRITE (ICL, '(''SPGR '', A, 64X)') SPGRNM(1)(1:11)
              ELSE
                WRITE (ICL, '(''SPGR '' , A, 63X)')
     1          SPGRNM(1)(1:7)//' '//SPGRNM(1)(8:11)
                IF (SPGRNM(1)(13:13) .NE. ' ') ICL(13:13) = '.'
              ENDIF
              CALL SGSM (ICL, NRXX, XJX, LU6, 0, IERR)
            ENDIF
            CALL SGSM (ICL, 0, XJX, LU7, 2, IERR)
          ENDIF
        ENDIF
        IPPR(1, 3) = IPR(48)
      ENDIF
      RETURN
99999 FORMAT ('PLATON(V-', I6, ')-Run for: ', A, 9X, 'TIME: ', A, /,
     1 132('='), /, 110X, '(C) 1980-2006 A.L.Spek')
99998 FORMAT (/, ':: TITL ', A, /,
     1        ':: CELL ', 3F10.4, 3F10.3, F10.1, /,
     2        ':: SPGR ', 3A, 2X, A)
99997 FORMAT (48X, 26('=')/, 47('='), ' Orthogonalization Matrices ',
     1 57('='), /, 48X, 26('='))
99996 FORMAT (/, 50X, 20('='), /, 49('='), ' Space Group Symmetry ',
     1 61('='), /, 50X, 20('='), //, '(See e.g. G. Burns & A.M. ',
     2 'Glazer, Space Groups for Solid State Scientists, ',
     3 'Academic Press, 1990 or Int. Tables A)', /)
99995 FORMAT (':: Angstrom Coordinate Data Scale = ', F10.4, /)
99994 FORMAT (/, '(See e.g. J.D.Dunitz, Xray Analysis and Structure',
     1 ' Determination of Organic Molecules, Cornell Univ. Press,',
     2 ' 1979, P236)', /)
99993 FORMAT (55X, 12('='), /, 54('='), ' Crystal Data ', 64('='), /,
     1 55X, 12('=') / 24X, 'Input Cell', 2X, '(Lattice Type: ', A1,')',
     2 3X, '-   Temp =', I4, 'K', 13X, 'Reduced Cell', 5X,
     3 '(Acta Cryst.(1976),A32,297-298)', /, 81('-'), 3X, 48('-'))
99992 FORMAT (A)
99991 FORMAT (1X)
99990 FORMAT (42X, 'd(010) =', F12.4, 26X, 3F10.3, /,
     1        'Lambda(', A, ') =', F10.5, ' Angstrom', 9X,
     2        'd(001) =', F12.4, 26X, 3F10.3, /)
99989 FORMAT ('(XO)   (', 3F10.5, ' ) (X)   ,   (X)   (', 3F10.5,
     1 ' ) (XO)', 5X, ' Orthogonal Axes AO, BO and CO')
99988 FORMAT ('(YO) = (', 3F10.5, ' )*(Y)   ,   (Y) = (', 3F10.5,
     1 ' )*(YO)', 13X, 'are defined as:')
99987 FORMAT ('(ZO)   (', 3F10.5, ' ) (Z)   ,   (Z)   (', 3F10.5,
     1 ' ) (ZO)', 5X, 'AO // A, CO // C*, BO // CO X AO')
      END
      SUBROUTINE PLA043 (MODE, ITYPE, LU, NWIN)
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16,
     1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP22=256,NP25=99,
     2 NP29=63,NP38=125,NP39=30,NP41=200,NP45=2048,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /Q/ ICL, IFL(NP17)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      CHARACTER ILTR*3, FORMA*53
      COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0
      FORMA(1:40)  = '(   A,  ''['',F9.2,'' ]  = '',A,'' = [ '',5I3,'
      FORMA(41:53) = ''' ] '',3F11.3)'
      IHOR  = -1
      IF (IWIN .EQ. 1) THEN
        IF (NWIN .EQ. 1) CALL GGIP (HORS, VERT, 0.0, 1)
        IF (ITYPE .NE. 0) VRT   = VERT - 0.6
      ENDIF
      IF (ITYPE .EQ. 0) THEN
        FORMA(14:14) = '7'
        FORMA(16:16) = '0'
      ELSE
        IF (PAR(42) .LT. 100.0) FORMA(16:16) = '1'
      ENDIF
      IF (MODE .GE. 0) THEN
        NMOL = IPR(13)
        IF (NMOL .GT. 1) THEN
          NPRNT = 0
          DO 30 I = 1, NMOL
            IF (ITYPE .EQ. 0) THEN
              IF (MP(I) .EQ. 0) GOTO 30
            ENDIF
            ML = MOL(I)
            IF (ML .NE. 0) THEN
              XML = ML / PAR(42)
              IF (I .GT. 1 .AND. ITYPE .LE. 0) THEN
                XML = INT(XML)
                DO 10 J = 1, I - 1
                  IF (MP(J) .EQ. 1) THEN
                    YML = INT (MOL(J) / PAR(42))
                    IF (XML .EQ. YML) GOTO 30
                  ENDIF
   10           CONTINUE
              ENDIF
              CALL GEN098 (ML, PAR(42), MOL1, MOL2, MOL3, MOL4, IRS0)
              IF (IRS0 .GT. 0)THEN
                IF (MOL1 .GT. IPR(48)) THEN
                  IF (I .EQ. (IPR(13) - IPR(101) + 1) .AND.
     1                      IGBL(63) .GT. 2) THEN
                    IF (LU .EQ. LU7) CALL PLA269 (4)
                    WRITE (LU, 99996)
                  ENDIF
                  MOL1 = MOL1 - IPR(48)
                  ILTR = '* ='
                  XML  = XML - IPR(48) * 1000
                ENDIF
                IF (I .GT. 1) THEN
                  IF (IPR(17) .EQ. 0 .OR. ITYPE .LT. 0) THEN
                    IF (I .LE. 27) THEN
                      ILTR = CHAR(ICHAR('a') + I - 2)//' ='
                    ELSE
                      ILTR = '* ='
                    ENDIF
                  ELSE
                    ILTR = '   '
                  ENDIF
                  XJX(4) = MOL2
                  XJX(5) = MOL3
                  XJX(6) = MOL4
                  CALL SGSM (ICL, MOL1, XJX, 0, 20, IERR)
                  DO 20 K = 1, 3
                    XJX(K) = XXO(NP1 + 1 - IRS0, K)
   20             CONTINUE
                  CALL SGSM (ICL, MOL1, XJX, LU, 3, IERR)
                  IF (IGBL(63) .GT. 2) THEN
                    IF (NPRNT .EQ. 0 .AND. LU .GT. 0) THEN
                      IF (ITYPE .EQ. 1) THEN
                        IF (LU .EQ. LU7) CALL PLA269 (7)
                        WRITE (LU, 99998)
                      ELSE IF (ITYPE .EQ. 0) THEN
                        IF (LU .EQ. LU7) CALL PLA269 (3)
                        WRITE (LU, 99997)
                      ENDIF
                      NPRNT = 1
                    ENDIF
                  ENDIF
                  IF (IGBL(63) .GT. 2 .OR. LU .NE. LU7) THEN
                    CALL GEN020 (-1, ICL, 1, 33)
                    WRITE (PRBUF, FORMA) ILTR, XML, ICL(1:33),
     1                 MOL1, MOL2, MOL3, MOL4, IRS0, (XJX(K), K = 7, 9)
                    CALL GEN065 (0, PRBUF, 132, 7)
                    IF (LU .EQ. LU7) CALL PLA269 (1)
                    IF (ITYPE .EQ. 1) THEN
                      WRITE (LU, 99995) PRBUF
                    ELSE
                      IF (LU .GT. 0) THEN
                        WRITE (LU, 99995) PRBUF(1:50)
                        IF (IWIN .EQ. 1 .AND. ITYPE .NE. 0) THEN
                          VRT = VRT - 0.45
                          CALL GGIP20 (0.0, PRBUF, 50, 0.30,
     1                                 5 + IGBL(68), 2, 1.0, VRT)
                        ENDIF
                      ELSE
                        IF (IWIN .EQ. 1) THEN
                          IHOR = MOD(IHOR + 1, 3)
                          IF (IHOR .EQ. 0) VRT  = VRT - 0.45
                          HOR = IHOR * HORS / 3 - 0.5
                          CALL GGIP20 (0.0, PRBUF, 50, 0.28, 1, 2,
     1                                 HOR, VRT)
                        ENDIF
                      ENDIF
                    ENDIF
                  ENDIF
                ENDIF
              ENDIF
            ENDIF
   30     CONTINUE
          IF (ITYPE .EQ. 1 .AND. IGBL(63) .GT. 2) THEN
            IF (LU .EQ. LU7) CALL PLA269 (7)
            WRITE (LU, 99999)
          ENDIF
          IF (MODE .NE. 0) CALL PLA040 (0, 0, 0, 0, 0)
        ENDIF
      ENDIF
      RETURN
99999 FORMAT (/, 'Note: Symmetry Operations Refer to the Coordinates ',
     1 'listed in the Fractional Coordinate Table given above',
     2 //, 65X, 'SYM', 9X, '-  Number of the Symmetry Operator.',
     3 /, 'X(J) = X(sym) + TX , Y(J) = Y(sym) + TY , ',
     4 'Z(J) = Z(sym) + TZ,', 4X, 'Ires', 8X, '-  Residue Number.', /,
     5 65X, 'TX, TY, TZ  -  Unit Cell Translations.')
99998 FORMAT (/, 42X, 'Asymmetric Residue Unit (= ARU) Code List', /,
     1 42X, 41('='), //, 5X, 'ARU-CODE', 6X, 'Symmetry-Code', 26X,
     2 'sym TX TY TZ', ' Ires', 5X, 'x(cen)', 5X, 'y(cen)', 5X,
     3 'z(cen)', /, 132('-'))
99997 FORMAT (/, 'Translation of ARU-code to Equivalent Position ',
     1        'Code', /, 51('='))
99996 FORMAT (/, 37X, 'Detected and Excluded Disorder Asymmetric ',
     1 'Residue Units', /, 37X, 55('='), /)
99995 FORMAT (A)
      END
      SUBROUTINE PLA044 (R, IAT, XR, YR, ZR, SX, SY, SZ, SC, SXY)
      DIMENSION R(3, 3)
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16,
     1 NP11=128,NP19=31,NP25=99,NP29=63,NP41=200,NP47=9)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      IF (IAT .LT. 0) THEN
        N   = - IAT
        XOR = XLS(1, N) * XLS(4, N)
        YOR = XLS(2, N) * XLS(4, N)
        ZOR = XLS(3, N) * XLS(4, N)
      ELSE
        XOR = XXO(IAT, 4)
        YOR = XXO(IAT, 5)
        ZOR = XXO(IAT, 6)
      ENDIF
      XR = SC * (R(1, 1) * XOR + R(1, 2) * YOR + R(1,3) * ZOR -SX) + SXY
      YR = SC * (R(2, 1) * XOR + R(2, 2) * YOR + R(2,3) * ZOR -SY) + SXY
      ZR = SC * (R(3, 1) * XOR + R(3, 2) * YOR + R(3,3) * ZOR -SZ) + SXY
      RETURN
      END
      SUBROUTINE PLA045 (NTYP)
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16,
     1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP25=99,NP29=63,
     2 NP38=125,NP39=30,NP41=200,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      IF (IPR(52) .LT. NP2) THEN
        NMAX  = IPR(39)
        IPR52 = IPR(52)
        CALL PLA054 (0)
        DO 10 I = 1, 4
          XLS(I, IPR52 + 1) = XPV(I)
   10   CONTINUE
        IF (NTYP .EQ. 1) THEN
          IF (IPR52 .GT. 0) THEN
            DO 30 J = 1, IPR52
              DMIN = 0
              DO 20 K = 1, 4
                DMIN = DMIN + ABS(XLS(K, IPR52 + 1) - XLS(K, J))
   20         CONTINUE
              IF (DMIN .LT. 0.00001) GOTO 50
   30       CONTINUE
          ENDIF
        ENDIF
        CALL GEN022 (IATP, 1, NMAX)
        IPR(52) = IPR(52) + 1
        IF (NTYP .EQ. 3) THEN
          CALL GEN004 (ROR, DUMV, ORRES)
          CALL GEN003 (ORRES, RMAT, DET, 0)
        ENDIF
        CALL GEN005 (DUMV, RMAT)
        DO 40 K = 1, 3
          TEMP = RMAT(1, K)
          RMAT(1, K) = - RMAT(3, K)
          RMAT(3, K) = TEMP
   40   CONTINUE
        IF (NTYP .EQ. 2) THEN
          IPR(69)  = IPR(69) + 1
          IF (IPR(12) .GT. 4 .AND. IPR(12) .LT. 8) THEN
            IYUNK = 2 * (IPR(12) - 5)
            IPR(496) = IPR(496) + 10 ** IYUNK
          ENDIF
        ENDIF
        WRITE (LU8) NTYP, IPR(12), JR, RMAT
        WRITE (LU8) (IATP(L4), L4 = 1, IPR(39))
      ENDIF
   50 RETURN
      END
      SUBROUTINE PLA046 (MODUS, NQ, IENM, LBB, LBC, LBD, XNQNR, YNQNR,
     1                   NIEN)
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118,
     1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP22=256,
     2 NP25=99,NP29=63,NP36=1000,NP38=125,NP39=30,NP41=200,NP45=2048,
     3 NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9),
     1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10),
     2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10),
     3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770)
      COMMON /Q/ ICL, IFL(NP17)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      CHARACTER NQ*7, ICH*1, NQJ*2
      COMMON /ALIASES/ ALAB(NP36), BLAB(NP36)
      CHARACTER ALAB*7, BLAB*7
      III = 0
      NAT = 0
      MODE = MODUS
      MODX = 0
      IF (MODUS .GT. 98) THEN
        MODE = MODUS - 100
        MODX = 1
      ENDIF
      IF (MODE .NE. -1) THEN
        IF (MODE .EQ. -2) THEN
          N    = 0
          MODE = 2
        ELSE
          N = INDEX (NQ, '_')
          IF (N .LT. 5) THEN
            M = INDEX (NQ(N +1: 7), '_')
            N = N + M
          ENDIF
          IF (N .LT. 7) THEN
            IF (N .NE. 0) THEN
              ICH = NQ(N+1:N+1)
              DO 10 I = 1, 10
                IF (ICH .EQ. CHAR(ICHAR('0') + I - 1)) THEN
                  N = 0
                  GOTO 20
                ENDIF
   10         CONTINUE
              NQJ = NQ(N:N+1)
              NQ(N:) = ' '
            ENDIF
          ELSE
            NIEN = -15
            GOTO 140
          ENDIF
        ENDIF
   20   IF (IGBL(71) .GT. 0) THEN
          DO 30 I = 1, IGBL(71)
            IF (NQ .EQ. ALAB(I)) THEN
              IF (N .EQ. 0) THEN
                NQ = BLAB(I)
              ELSE
                M = INDEX (BLAB(I), ' ')
                NQ = BLAB(I)(1:M-1)//NQJ
              ENDIF
              GOTO 50
            ENDIF
   30     CONTINUE
        ENDIF
        IF (N .NE. 0) NQ(N:) = NQJ
      ENDIF
      IF (MODX .EQ. 1 .AND. IABS(IGBL(8)) .EQ. 3) THEN
        KL = IPR(220)
        IF (KL .EQ. 3) THEN
          IF (IFL(3)(2:2) .EQ. ' ') THEN
            N = 1
          ELSE
            N = 2
          ENDIF
          IF (NQ(1:N) .NE. IFL(3)(1:N)) GOTO 40
          IF (N .EQ. 1) THEN
            IF (ICHAR(NQ(2:2)) .GE. 65 .AND. ICHAR(NQ(2:2)) .LE. 90)
     1          GOTO 40
          ENDIF
        ENDIF
        IF (NQ(1:2) .EQ. 'HO' .AND. IPR(435) .EQ. 0) THEN
          GOTO 40
        ELSE IF (NQ(1:2) .EQ. 'HN') THEN
          GOTO 40
        ELSE IF (NQ(2:2) .EQ. '0') THEN
          GOTO 40
        ELSE IF (NQ(2:3) .EQ. '00') THEN
          GOTO 40
        ENDIF
        GOTO 50
   40   IF (KL .EQ. 3) THEN
          IF (IFL(3)(1:2) .NE. 'HO') THEN
            NIEN = -8
            GOTO 140
          ELSE
            IPR(435) = 1
          ENDIF
        ENDIF
      ENDIF
   50 LBA   = 0
      LBC   = 0
      NR    = 0
      NCH   = 0
      ITEL  = 0
      NIEN  = 0
      XNQNR = 0.0
      YNQNR = 0.0
      IF (MODE .EQ. 8)  THEN
        LBB = -1
        LBD = 27
      ELSE
        LBB = 0
        LBD = 0
      ENDIF
      LEV = 1
      NB  = 1
      NE  = 7
      CALL GEN039 (1, NQ, 1, 7, NB, NE)
      DO 80 I = 1, NE
        ICH = NQ(I : I)
        IF (ICH .EQ. '*') THEN
          NIEN = -14
          GOTO 140
        ELSE IF (ICH .EQ. CHAR(92)) THEN
          NIEN = -10
          GOTO 140
        ELSE IF (ICH .EQ. '(')  THEN
          LBB = 0
          LEV = 2
        ELSE IF (ICH .EQ. ')') THEN
          LEV = 4
        ELSE IF (ICH .EQ. '_') THEN
          IF (MODE .NE. 0) THEN
            LEV = 4
          ELSE
            NIEN = -11
            GOTO 140
          ENDIF
        ELSE IF (ICH .EQ. '''') THEN
          IF (LBC .EQ. 0) THEN
            LBC  = 1
            LEV  = 3
          ELSE
            NIEN = -9
            GOTO 140
          ENDIF
        ELSE IF (ICH .EQ. '"') THEN
          IF (LBC .EQ. 0) THEN
            LBC  = 2
            LEV  = 3
          ELSE
            NIEN = -9
            GOTO 140
          ENDIF
        ELSE IF (ICH .EQ. '#') THEN
          IF (MODE .GT. 0) THEN
            LBC = 3
            LEV = 3
          ELSE
            GOTO 90
          ENDIF
        ELSE
          DO 60 J = 1, 26
            IF (ICH .EQ. CHAR(ICHAR('A') + J - 1) .OR.
     1          ICH .EQ. CHAR(ICHAR('a') + J - 1)) THEN
              IF (LEV .EQ. 1) THEN
                NR = NR + 1
                IF (NR .EQ. 1) THEN
                  NQJ = ' '//CHAR(ICHAR('A') + J - 1)
                  LBA = J * 100
                ELSE IF (NR .EQ. 2) THEN
                  NQJ(1:1) = NQJ(2:2)
                  NQJ(2:2) = CHAR(ICHAR('a') + J - 1)
                  LBA      = LBA + J
                ELSE
                  LBA = -1
                  GOTO 90
                ENDIF
                GOTO 80
              ELSE IF (LEV .EQ. 2) THEN
                IF (NCH .EQ. 0 .AND. LBC .EQ. 0 .AND.
     1              IGBL(61) .EQ. 0) THEN
                  NCH = NCH + 1
                  LBC = 3 + J
                  LEV = 3
                ELSE
                  NIEN = -8
                  GOTO 140
                ENDIF
              ELSE IF (LEV .EQ. 3) THEN
                NIEN = -8
                GOTO 140
              ELSE
                IF (MODE .LE. 0) THEN
                  GOTO 90
                ELSE
                  LBD = J
                  GOTO 80
                ENDIF
              ENDIF
            ENDIF
   60     CONTINUE
          DO 70 J = 1, 10
            IF (ICH .EQ. CHAR(ICHAR('0') + J - 1)) THEN
              IF (LEV .LE. 2) THEN
                IF (MODE .EQ. 8 .AND. LBB .EQ. -1) LBB = 0
                LBB  = LBB * 10 + J - 1
                IF (LBB .EQ. 0) THEN
                  NIEN = -13
                  NQ(I:) = ' '
                  GOTO 140
                ENDIF
                ITEL = ITEL + 1
                LEV  = 2
                GOTO 80
              ELSE
                NIEN = -8
                GOTO 140
              ENDIF
            ENDIF
   70     CONTINUE
        ENDIF
   80 CONTINUE
   90 ITEL = ITEL + NR
      IF (LBC .GT. 0)  ITEL = ITEL + 1
      IENM = 0
      IF (IAN .GT. 0) THEN
        DO 100 I = 1, IAN
          IF (LBA .EQ. IEL(IEN(I))) THEN
            IENM = I
            GOTO 120
          ENDIF
  100   CONTINUE
      ENDIF
      DO 110 III = 1, NP9
        IF (LBA .EQ. IEL(III)) GOTO 120
  110 CONTINUE
      III = 0
  120 IF (MODE .EQ. 8) THEN
        IF (IENM .GT. 0) GOTO 140
        IF (III .GE. NP9 - 3 .AND. III .LE. NP9) IENM = III
      ELSE IF (MODE .LT. 8) THEN
        IF (IENM .EQ. 0) THEN
          IF (IABS(IGBL(8)) .NE. 2 .OR. NQJ .EQ. 'Cg' .OR.
     1                          NQJ .EQ. ' Q') THEN
            IF (III .GT. 0) THEN
              IAN = IAN + 1
              IF (IAN .GT. NP10) THEN
                NIEN = -2
                GOTO 140
              ENDIF
              IEN(IAN)    = III
              JJ          = IABS(IATPR(III))
              LMT(IAN, 2) = JTP(JJ)
              LMT(IAN, 1)  = NQJ
              RADR(IAN, 3) = REL(III)
              RADR(IAN, 4) = ABS(VDWR(III))
              IF (III .EQ. 3) THEN
                IACL(IAN) = 2
              ELSE IF (III .EQ. 4) THEN
                IACL(IAN) = 4
              ELSE IF (IATPR(III) .EQ. -7) THEN
                IACL(IAN) = 3
              ELSE IF (III .GT. 2) THEN
                IF (ICLR .LT. 8) ICLR = ICLR + 1
                IACL(IAN) = ICLR
              ENDIF
              IENM = IAN
            ENDIF
          ELSE
            NIEN = -3
            GOTO 140
          ENDIF
        ENDIF
        IF (IENM .LE. 0) THEN
          NIEN = -5
          GOTO 140
        ENDIF
        IF (MODE .LT. 0 .OR. (MODE .EQ. 0 .AND. ITEL .GT. 4)) THEN
          LBC  = 3
          ITEL = 3
          IF (MOD(LBA, 100) .NE. 0) ITEL = ITEL + 1
          IF (IGBL(71) .GE. NP36) THEN
            NIEN = -7
          ELSE
            IGBL(71) = IGBL(71) + 1
          ENDIF
          IENLB(IENM) = IENLB(IENM) + 1
          LBB         = IENLB(IENM)
          IF (LBB .GT. 10)  ITEL = ITEL + 1
          IF (LBB .GT. 99 .AND. IGBL(61) .EQ. 0) THEN
            NIEN = -12
            GOTO 140
          ENDIF
          IF (ITEL .GT. 4) IPR(119) = 0
        ENDIF
        YNQNR = (120 - IATNR(IEN(IENM))) * 40000 + LBB * 40 + LBC
        IF (IGBL(61) .EQ. 0) THEN
          IF (LBC .GT. 0) LBC = LBC + 10
          IF (LBB .GE. 10 ** (3 - NR) .AND. LBC .EQ. 0) THEN
            LBB1 = LBB / 10
            LBC  = LBB - LBB1 * 10 + 1
            LBB  = LBB1
          ENDIF
          NQX = LBB * 40 + LBC
        ELSE
          NQX = LBB * 4 + LBC
        ENDIF
        IF (LBD .GE. 128) THEN
          NIEN = -6
          GOTO 140
        ENDIF
        XNQNR = FLOAT(IENM * 512000 + NQX * 128 + LBD)
        IF (MODE .GT. 1) THEN
          IF (MODE .EQ. 2) THEN
            NAT = IPR(37)
          ELSE IF (MODE .EQ. 3) THEN
            NAT = IPR(39)
          ELSE IF (MODE .EQ. 4) THEN
            NAT = IPR(39) + IPR(64)
          ENDIF
          DO 130 I = 1, NAT
            IF (NINT(XNQNR) .EQ. NINT(XLAB(I))) THEN
              NIEN = I
              GOTO 140
            ENDIF
  130     CONTINUE
          NIEN = - 4
        ELSE
          NIEN = IENM - 1
        ENDIF
C * PLUTON PACK MODE
      ELSE IF (MODE .EQ. 9 .OR. MODE .EQ. 10) THEN
        IF (IENM .EQ. 0) THEN
          IF (III .EQ. 0) THEN
            NIEN = -1
            GOTO 140
          ELSE
            IAN = IAN + 1
            IF (IAN .GT. NP10) THEN
              NIEN = -2
              GOTO 140
            ENDIF
            RADR(IAN, 3) = REL(III)
            RADR(IAN, 4) = ABS(VDWR(III))
            IEN(IAN) = III
            IENM     = IAN
          ENDIF
        ENDIF
        IF (ITEL .GT. 4 .OR. MODE .EQ. 10) THEN
          LBC         = 3
          IENLB(IENM) = IENLB(IENM) + 1
          LBB         = IENLB(IENM)
        ENDIF
        NQX   = LBB * 32 + LBC
        XNQNR = (IENM - 1) * 32000 + NQX
        YNQNR = (120 - IATNR(IEN(IENM))) * 32000 + NQX
      ENDIF
  140 RETURN
      END
      SUBROUTINE PLA047 (XL, NQ, MN, IENR, IPAR, IALIAS, IPDB, IMU)
      PARAMETER (NP9=118,NP10=16,NP12=600,NP13=500,NP17=99,NP36=1000,
     1 NP38=125,NP39=30)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9),
     1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10),
     2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10),
     3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770)
      COMMON /ALIASES/ ALAB(NP36), BLAB(NP36)
      CHARACTER ALAB*7, BLAB*7
      DIMENSION NUM(3)
      CHARACTER NQ*(*), NQ1*9, NQ2*9, NQ3*9
      K = 0
      JPAR = IPAR
      IF (IGBL(71) .GT. 0 .AND. IALIAS .EQ. 0 .AND. JPAR .EQ. 1)
     1    JPAR = 0
      NQ   = ' '
      NQ3  = ' '
      IENR = 0
      MN   = 0
      JX3  = NINT(ABS(XL))
      IF (JX3 .GT. 0) THEN
        JX1 = JX3 / 512000
        JX3 = MOD(JX3, 512000)
        JX2 = JX3 / 128
        JX3 = MOD(JX3, 128)
        IF (IGBL(61) .EQ. 0) THEN
          JX4 = MOD(JX2, 40)
          JX2 = JX2 / 40
          IF (JX4 .GT. 0 .AND. JX4 .LT. 11) THEN
            JX2 = JX2 * 10 + JX4 - 1
            JX4 = 0
          ELSE
            JX4 = JX4 - 10
          ENDIF
        ELSE
          JX4 = MOD(JX2, 4)
          JX2 = JX2 / 4
        ENDIF
        MN  = JX3 + 1
        IF (JX2 .EQ. 0) JPAR = MIN (JPAR, 0)
        IF (XL  .LT. 0) JX3  = 0
        IENR = IEN(JX1)
        JX1  = IEL(IENR)
        J1   = JX1 / 100
        J2   = MOD(JX1, 100)
        K    = 1
        IF (IPDB .EQ. 1 .AND. J2 .EQ. 0) K = 2
        NQ3(K : K) = CHAR(ICHAR('A') + J1 - 1)
        K = K + 1
        IF (J2 .GT. 0) THEN
          IF (IPDB .LE. 0) THEN
            NQ3(K : K) = CHAR(ICHAR('a') + J2 - 1)
          ELSE
            NQ3(K : K) = CHAR(ICHAR('A') + J2 - 1)
          ENDIF
          K = K + 1
        ENDIF
        IF (JPAR .GT. 0) THEN
          NQ3(K : K) = '('
          K = K + 1
        ENDIF
        J2     = JX2 / 10
        NUM(3) = MOD(JX2, 10)
        NUM(1) = J2 / 10
        NUM(2) = MOD(J2, 10)
        J2     = 0
        DO 10 J = 1,  3
          IF (NUM(J) .GT. 0 .OR. J2 .GT. 0) THEN
            NQ3(K : K) = CHAR(ICHAR('0') + NUM(J))
            K  = K  + 1
            J2 = J2 + 1
          ENDIF
   10   CONTINUE
        IF (JX4 .GT. 0) THEN
          IF (JX4 .EQ. 1) THEN
            NQ3(K : K) = ''''
          ELSE IF (JX4 .EQ. 2) THEN
            NQ3(K : K) = '"'
          ELSE IF (JX4 .EQ. 3) THEN
            NQ3(K : K) = '#'
          ELSE IF (JX4 .GT. 3) THEN
            NQ3(K : K) = CHAR(ICHAR('A') + JX4 - 4)
          ENDIF
          K  = K  + 1
        ENDIF
        IF (JPAR .GT. 0) THEN
          NQ3(K : K) = ')'
          K = K + 1
        ENDIF
        IF (JX3 .GT. 0) THEN
          IF (JPAR .EQ. 0) THEN
            NQ3(K : K) = '_'
            K         = K + 1
          ENDIF
          IF (JX3 .LT. 27) THEN
            NQ3(K : K) = CHAR(ICHAR('a') + JX3 - 1)
          ELSE
            NQ3(K : K) = '*'
          ENDIF
          K           = K + 1
        ENDIF
        NQ3(K : K)     = ' '
      ENDIF
      IF (K .GT. 1 .AND. IGBL(71) .GT. 0 .AND. IALIAS .EQ. 0) THEN
        NQ1 = NQ3(1 : K)
        K0  = K
        IF (JX3 .GT. 0) THEN
          K0  = K0 - 1
          NQ3(K0:K0) = ' '
          IF (JPAR .EQ. 0) K0 = K0 - 1
          NQ3(K0:K0) = ' '
        ENDIF
        DO 20 I = 1, IGBL(71)
          IF (IPR(501) .EQ. 0) THEN
            N = INDEX (BLAB(I), '#')
          ELSE
            N = INDEX (BLAB(I), ' ')
          ENDIF
          IF (N .GT. 0) THEN
            IF (NQ3(1:N) .EQ. BLAB(I)(1:N)) THEN
              M  = INDEX (ALAB(I), ' ') - 1
              IF (IMU .EQ. 0) THEN
                IF (INDEX (ALAB(I), '_') .NE. 0) GOTO 30
              ENDIF
              IF (M .LT. 1 .OR. M .GT. (7 + K0 - K)) GOTO 30
              NQ2 = ALAB(I)(1:M)//NQ1(K0:K)
              CALL GEN020 (2, NQ3, 1, 2)
              IF (NQ2(1:2) .EQ. NQ3(1:2)) NQ2(1:2) = BLAB(I)(1:2)
              NQ3 = NQ2(1:7)
              GOTO 40
            ENDIF
          ENDIF
   20   CONTINUE
   30   NQ3 = NQ1
      ENDIF
   40 NQ = NQ3(1:7)
      RETURN
      END
      SUBROUTINE PLA048
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16,
     1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP22=256,NP25=99,
     2 NP29=63,NP38=125,NP39=30,NP41=200,NP45=2048,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /Q/ ICL, IFL(NP17)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      DIMENSION B(3, 3), C(3, 3), XXX(12), ICSD(6), UVIJ(3)
      CHARACTER FORMI*119, FORMJ*116, FORMK*75
      FORMI( 1:31)  = '(A           ,F10.6,''('',I4,'')'','
      FORMI(32:68)  = 'F10.6,''('',I4,'')'',F10.6,''('',I4,'')'',7X,'
      FORMI(69:119) = FORMI(15:64)//')'
      FORMJ(1:30)   = '(A,''-'',A,''['',I2,''] -> '',A,''['','
      FORMJ(31:69)  = 'F9.2,'']'',F7.3,''('',I3,'')  '',3F7.4, F9.4,'
      FORMJ(70:95)  = 'F7.3,F7.2,F8.2,''('',I3,'')'','
      FORMJ(96:116) = 'F8.4,''('',I3,'')'',F7.0)'
      FORMK(1:33)   = '(A,''['',I2,''] -> '',A,''['',F9.2,'']'','
      FORMK(34:75)  = 'F7.4,''('',I3,'')  '',3F7.4,F10.4,3F8.2,3F8.3)'
      DMIN  = 0.0
      ANG2M = 0.0
      NTMP  = 0
      NPRT  = 0
      NSYM    = IPR(48)
      NRING   = IPR(64)
      NMAX    = IPR(39)
      IRMST   = 0
      ISANG1  = 0
      ISDIST1 = 0
      ISDIST3 = 0
      NDEC0   = 0
      NDEC1   = 0
      NDEC3   = 0
      SANG1   = 0
      SDIST1  = 0
      SDIST3  = 0
      DIST4   = 0.0
      DO 210 MODE = 1, 5
        CALL PLA068 (0, 0.0)
        IF (MODE .EQ. 1) THEN
          DMAX = PAR(36)
          DMIN = 2.5
        ELSE IF (MODE .EQ. 2) THEN
          DMAX = PAR(69)
          DMIN = 2.0
          ANG2M = 45.0
        ELSE IF (MODE .EQ. 3) THEN
          DMAX = 3.0
          DMIN = 1.5
        ELSE IF (MODE .EQ. 4) THEN
          DMAX  = PAR(263)
          DMIN  = 2.0
          ANG3M = PAR(264)
        ELSE IF (MODE .EQ. 5) THEN
          DMAX = PAR(447)
          DMIN = 2.5
          ANG3M = PAR(448)
        ENDIF
        DO 10 I = 1, 3
          V3(I) = DMAX * PAR(112 + I)
   10   CONTINUE
        IF (MODE .GT. 2) THEN
          NBEG = 1
          NEND = IPR(37)
          NTMP = 0
          NPRT = 0
        ELSE
          NBEG = NMAX + 1
          NEND = NMAX + NRING
        ENDIF
        NR = 0
        DO 200 N = NBEG, NEND
          NEWTMP = NMAX + NRING
          CALL GEN048 (-1, IFG(N), 19, MET)
          CALL GEN048 (-1, IFG(N), 7, NHAT)
          IF (MODE .EQ. 3) THEN
            IF (MET .EQ. 0) GOTO 200
            NTMP = 0
          ELSE IF (MODE .EQ. 4) THEN
            IF (NHAT .EQ. 0) GOTO 200
            NTMP = 0
          ELSE IF (MODE .EQ. 5) THEN
            IF (NINT(CON(N, NP4)) .NE. -1 .OR.
     1          MET .NE. 0 .OR. NHAT .NE. 0) GOTO 200
            NTMP = 0
          ENDIF
          CALL GEN048 (-6, IFG(N), 9, IRES)
          CALL PLA047 (XLAB(N), NQ1, IDUM, JDUM, IPR(119), IGBL(55),
     1                 0, 0)
          IF (MODE .EQ. 2) THEN
            JBEG = 1
            JEND = IPR(37)
          ELSE
            JBEG = NMAX + 1
            JEND = NMAX + NRING
          ENDIF
          DO 140 J = JBEG, JEND
            IF (MODE .EQ. 2) THEN
              CALL GEN048 (-1, IFG(J), 19, MET)
              IF (MET .EQ. 0) GOTO 140
            ENDIF
            CALL GEN048 (-6, IFG(J), 9, JRES)
            DO 130 NSM = 1, NSYM
              IF (J .EQ. N .AND. NSM .EQ. 1) GOTO  130
              DO 20 K0 = 1, 3
                XXX(K0) = XXO(J, K0)
                XXX(K0 + 3) = 0.0
                V4(K0) = 0.0
   20         CONTINUE
              NS = NSM
              CALL SGSM (LINE, NS, XXX, 6, 3, IERR)
              IF (MODE .EQ. 3 .AND. NSM .EQ. 1) THEN
                K = 3
                GOTO 60
              ELSE
                K = 1
              ENDIF
   30         IF ((XXO(N, K) - XXX(6 + K)) .GT. V3(K)) GOTO 50
              XXX(6 + K) = XXX(6 + K) - 1.0
              V4(K) = V4(K) - 1.0
              GOTO 30
   40         K = K - 1
   50         XXX(6 + K) = XXX(6 + K) + 1.0
              V4(K) = V4(K) + 1.0
              IF ((XXO(N, K)  - XXX(6 + K)) .GE. V3(K)) GOTO 50
              IF ((XXX(6 + K) - XXO(N, K))  .LE. V3(K)) GOTO 60
              K = K - 1
              IF (K .GT. 0) THEN
                GOTO 50
              ELSE
                GOTO 130
              ENDIF
   60         K = K + 1
              IF (K .GT. 3) THEN
                DO 70 L = 1, 3
                  V5(L) = XXX(6 + L) - XXO(N, L)
   70           CONTINUE
                CALL GEN002 (1, OR, V5, V6, DUM)
                CALL GEN002 (2, OR, V5, DXI, DIST1)
                IF (IATP(N) .LE. 0) THEN
                  WRITE (LU6, 99993) IATP(N)
                  GOTO 240
                ENDIF
                IF (DIST1 .LT. DMAX .AND. DIST1 .GT. DMIN) THEN
                  NEWTMP = NEWTMP + 1
                  IF (NEWTMP .EQ. 0) GOTO 40
                  IPR(54) = NS
                  DO 80 III = 1, 3
                    ITR(III) = NINT(V4(III))
   80             CONTINUE
                  CALL PLA059 (J, NEWTMP)
                  IFG(NEWTMP) = IFG(J)
                  JFG(NEWTMP) = JFG(J)
                  IF (MODE .LT. 3) THEN
                    NPL = IPR(19) + IATP(N)
                    IF (NPL .GT. NP2) THEN
                      WRITE (LU6, 99993) IATP(N)
                      GOTO 240
                    ENDIF
                    DIST3 = ABS(XLS(1, NPL) * XXO(NEWTMP, 4)
     1                    + XLS(2, NPL)     * XXO(NEWTMP, 5)
     2                    + XLS(3, NPL)     * XXO(NEWTMP, 6)
     3                    - XLS(4, NPL))
                  ENDIF
                  IF (MODE .EQ. 3) THEN
                    IF (IATP(J) .GT. 0) THEN
                      NPL = IPR(19) + IATP(J)
                      IF (NPL .GT. NP2) THEN
                        WRITE (LU6, 99993) IATP(J)
                        GOTO 240
                      ENDIF
                      DIST3 = ABS(XLS(1, NPL) * XXO(N, 4)
     1                      + XLS(2, NPL)     * XXO(N, 5)
     2                      + XLS(3, NPL)     * XXO(N, 6)
     3                      - XLS(4, NPL))
                      IF (ABS(DIST3) .LT. DMIN) THEN
                        NEWTMP = NEWTMP -1
                        GOTO 140
                      ENDIF
                    ENDIF
                  ENDIF
                  ARUJ = NS * 1000.0 + V4(1) * 100 + V4(2) * 10 + V4(3)
     1                + 555 + JRES / PAR(42)
                  CALL PLA047 (XLAB(J), NQ2, IDUM, JDUM, IPR(119),
     1                         IGBL(55), 0, 0)
                  XLAB(NEWTMP) = XLAB(J)
                  IF (MODE .LT. 3) THEN
                    NPL = IPR(19) + IATP(N)
                    V8(1) = XLS(1, NPL)
                    V8(2) = XLS(2, NPL)
                    V8(3) = XLS(3, NPL)
                    ANG2  = GEN027 (V8, DXI, GL(5))
                    IF (ANG2 .GT. 90.0) ANG2 = 180.0 - ANG2
                  ENDIF
                  IF (MODE .EQ. 1 .OR. MODE .EQ. 4
     1                            .OR. MODE .EQ. 5) THEN
                    IF (IATP(J) .LE. 0 .OR. IATP(J) .GT. NP2) THEN
                      WRITE (LU6, 99993) IATP(J)
                      GOTO 240
                    ENDIF
                    NPL   = IPR(19) + IATP(J)
                    V5(1) = XLS(1, NPL)
                    V5(2) = XLS(2, NPL)
                    V5(3) = XLS(3, NPL)
                    V1(4) = XLS(4, NPL)
                    CALL SGSM (LINE, NS, XJS, 6, 6, IERR)
                    K0 = 0
                    DO 100 I1 = 1, 3
                      V2(I1) = V4(I1) + XJS(I1 + 9)
                      DO 90 J1 = 1, 3
                        K0 = K0 + 1
                        UIJ(I1, J1) = XJS(K0)
   90                 CONTINUE
  100               CONTINUE
                    CALL GEN005 (OR, B)
                    CALL GEN004 (UIJ, B, C)
                    CALL GEN005 (ROR, B)
                    CALL GEN004 (B, C, UIJ)
                    CALL GEN002 (1, UIJ, V5, V1, DUM)
                    CALL GEN002 (-1, OR, V1, V6, DUM)
                    V1(4) = V1(4) + GEN009(V6, V2)
                    ANG3  = GEN027 (V1, DXI, GL(5))
                    IF (ANG3 .GT. 90.0) ANG3 = 180.0 - ANG3
                    DIST2 = ABS(XXO(N, 4) * V1(1) + XXO(N, 5) * V1(2)
     1                    + XXO(N, 6) * V1(3) - V1(4))
                    ANG1  = GEN027 (V8, V1, GL(5))
                    IF (ANG1 .GT. 90.0) ANG1 = 180.0 - ANG1
                    IF (MODE .EQ. 1) THEN
                      IF (ANG2 .LT. PAR(62)) THEN
                        NR = NR + 1
                        IF (NR .EQ. 1) THEN
                          CALL PLA269 (-14)
                          WRITE (LU7, 99999) PAR(36), PAR(62)
                          CALL GEN074 (DUMA, 99999.0, 1, 6)
                          DUMA(4) = 0.0
                        ENDIF
                        CALL PLA053 (N, NEWTMP, 0, 0, DIST1, SDIST1,
     1                               ISDIST1, NDEC1, IER)
                        IF (IER .NE. 0) DIST1 = 0.0
                        FORMK(37:37) = CHAR(ICHAR('0') + NDEC1)
                        IF (ANG1 .LT. 0.05) THEN
                          DIST4 = DIST1 * SIN (ANG2 / GL(5))
                          WRITE (PRBUF, FORMK) NQ1, IRES, NQ2, ARUJ,
     1                    DIST1, ISDIST1, (V1(L), L = 1, 4), ANG1,
     2                    ANG2, ANG3, DIST2, DIST3, DIST4
                        ELSE
                          WRITE (PRBUF, FORMK) NQ1, IRES, NQ2, ARUJ,
     1                    DIST1, ISDIST1, (V1(L), L = 1, 4), ANG1,
     2                    ANG2, ANG3, DIST2, DIST3
                        ENDIF
                        CALL PLA067 (LU7, PRBUF, 132, 1, 3)
                        CALL PLA068 (1, ARUJ)
                        DUMA(1) = MIN (DUMA(1), DIST1)
                        DUMA(2) = MIN (DUMA(2), ANG1)
                        DUMA(3) = MIN (DUMA(3), ANG2)
                        DUMA(4) = MAX (DUMA(4), ANG3)
                        DUMA(5) = MIN (DUMA(5), DIST2)
                        DUMA(6) = MIN (DUMA(6), DIST3)
                      ENDIF
                    ELSE
                      IF (ANG3 .LT. ANG3M) THEN
                        IF (NINT(CON(N, NP4)) .EQ. -1) THEN
                          I = NINT(CON(N, 1))
                          CALL PLA047 (XLAB(I), NQ3, IDUM, JDUM,
     1                      IPR(119), IGBL(55), 0, 0)
                          CALL PLA227 (I, N, UVIJ)
                          ANG4  = GEN027 (V1, UVIJ, GL(5))
                          IF (ANG4 .GT. 90.0) ANG4 = 180.0 - ANG4
                          ANG4 = 90.0 - ANG4
                          IF (MODE .EQ. 4) ANG4 = NINT(ANG4)
                          CALL PLA053 (I, N, NEWTMP, 0, ANG1, SANG1,
     1                                 ISANG1, NDEC0, IER)
                          IF (IER .NE. 0) ANG1 = 0
                          IF (ISANG1 .EQ. 0) THEN
                            NDEC0 = 0
                            ANG1  = NINT (ANG1)
                          ENDIF
                          FORMJ(83:83) = CHAR(ICHAR('0') + NDEC0)
                          CALL PLA053 (N, NEWTMP, 0, 0, DIST1, SDIST1,
     1                                 ISDIST1, NDEC1, IER)
                          IF (IER .NE. 0) DIST1 = 0.0
                          FORMJ(43:43) = CHAR(ICHAR('0') + NDEC1)
                          CALL PLA053 (I, NEWTMP, 0, 0, DIST3, SDIST3,
     1                                 ISDIST3, NDEC3, IER)
                          IF (IER .NE. 0) DIST3 = 0.0
                          FORMJ(99:99) = CHAR(ICHAR('0') + NDEC3)
                          NR = NR + 1
                          IF (NR .EQ. 1) THEN
                            CALL PLA269 (-6)
                            IF (MODE .EQ. 4) THEN
                              WRITE (LU7, 99992) DMAX, ANG3M
                            ELSE
                              WRITE (LU7, 99987) DMAX, ANG3M
                            ENDIF
                            CALL GEN074 (DUMA, 99999.0, 1, 5)
                            DUMA(4) = 0.0
                            DUMA(6) = 0.0
                          ENDIF
                          IF (MODE .EQ. 5) THEN
                            FORMJ(112:115) = 'F7.2'
                            WRITE (PRBUF, FORMJ) NQ3, NQ1, IRES, NQ2,
     1                        ARUJ, DIST1, ISDIST1, (V1(L), L = 1, 4),
     2                        DIST2, ANG3, ANG1, ISANG1, DIST3, ISDIST3,
     3                        ANG4
                          ELSE
                            FORMJ(112:115) = 'I7  '
                            WRITE (PRBUF, FORMJ) NQ3, NQ1, IRES, NQ2,
     1                        ARUJ, DIST1, ISDIST1, (V1(L), L = 1, 4),
     2                        DIST2, ANG3, ANG1, ISANG1, DIST3, ISDIST3,
     3                        NINT(ANG4)
                          ENDIF
                          CALL PLA067 (LU7, PRBUF, 132, 1, 3)
                          CALL PLA068 (1, ARUJ)
                          DUMA(1) = MIN (DUMA(1), DIST1)
                          DUMA(2) = MIN (DUMA(2), DIST2)
                          DUMA(5) = MIN (DUMA(5), DIST3)
                          DUMA(3) = MIN (DUMA(3), ANG3)
                          DUMA(4) = MAX (DUMA(4), ANG1)
                          DUMA(6) = MAX (DUMA(6), ANG4)
                        ENDIF
                      ENDIF
                    ENDIF
                  ELSE IF (MODE .EQ. 2) THEN
                    IF (ANG2 .LT. ANG2M) THEN
                      NR = NR + 1
                      IF (NR .EQ. 1) THEN
                         CALL PLA269 (8)
                         WRITE (LU7, 99997) DMAX
                      ENDIF
                      CALL PLA269 (1)
                      WRITE (LU7, 99996) NQ1, IRES, NQ2, ARUJ, DIST1,
     1                  DIST3, ANG2
                      CALL PLA068 (1, ARUJ)
                    ENDIF
                  ELSE IF (MODE .EQ. 3) THEN
                    IF (NTMP .LT. NP4 - 1) THEN
                      NTMP = NTMP + 1
                      IATC(NTMP) = NEWTMP
                    ELSE
                      IRMST = IRMST + 1
                    ENDIF
                  ENDIF
                ENDIF
                GOTO 40
              ENDIF
              GOTO 30
  130       CONTINUE
  140     CONTINUE
          IF (MODE .EQ. 3) THEN
            IF (NTMP .GT. 0) THEN
              DO 150 I = 1, NP4
                DATC(I) = CON(N, I)
  150         CONTINUE
              NC = - NINT (CON(N, NP4))
              IF (NC .LT. 0) THEN
                NC = NP4
                CALL GEN048 (-1, IFG(N), 8, IVAL)
                IF (IVAL .GT. 0) NC = NC + IPR(76)
              ENDIF
              DO 160 I = 1, NTMP
                CON(N, I) = IATC(I)
  160         CONTINUE
              NTMPC = NTMP
              DO 180 I = 1, NC
                IF (I .LE. NP4) THEN
                  K = NINT(DATC(I))
                ELSE
                  IF (IBON(I - NP4, 1) .NE. N) GOTO 180
                  K = IBON(I - NP4, 2)
                ENDIF
                DO 170 L = 1, NTMPC
                  CALL PLA050 (IATC(L), K, 0, 0, DIST2)
                  IF (DIST2 .LT. 1.5) GOTO 180
  170           CONTINUE
                IF (NTMP .LT. NP4 - 1) THEN
                  NTMP = NTMP + 1
                  CON(N, NTMP) = K
                ELSE
                  IRMST = IRMST + 1
                ENDIF
  180         CONTINUE
              CON(N, NP4) = - NTMP
              IF (NPRT .EQ. 0) THEN
                CALL PLA269 (0)
                NPRT = 1
                CALL PLA269 (3)
                WRITE (LU7, 99995)
              ENDIF
              IPR(81) = 2
              IFL(2)  = NQ1
              CALL PLA035 (0)
              DO 190 I = 1, NP4
                CON(N, I) = DATC(I)
  190         CONTINUE
            ENDIF
          ENDIF
  200   CONTINUE
        IF (MODE .EQ. 1 .AND. NR .GT. 0) THEN
          CALL PLA269 (2)
          WRITE (LU7, 99989) (DUMA(L), L = 1, 6)
        ELSE IF ((MODE .EQ. 4 .OR. MODE .EQ. 5) .AND. NR .GT. 0) THEN
          CALL PLA269 (2)
          WRITE (LU7, 99990) (DUMA(L), L = 1, 6)
        ENDIF
        CALL PLA068 (-1, 0.0)
  210 CONTINUE
      CALL PLA269 (5)
      WRITE (LU7, 99988)
      DO 230 I = NMAX + 1, NMAX + NRING
        CALL PLA269 (1)
        DO 220 K = 1, 3
          YUNK = SQRT(XSD(I, K))
          CALL GEN041 (XXO(I, K), YUNK, ICSD(K), IPR(183),
     1                 NDEC, IPR(68))
          NDC           = K * 17 + 2
          YUNK = SQRT(XSD(I, K + 3))
          CALL GEN041 (XXO(I, K + 3), YUNK, ICSD(K + 3), 5, NDECJ,
     1       IPR(68))
          NDCJ          = K * 17 + 56
          FORMI(NDC:NDC)   = CHAR(ICHAR('0') + NDEC)
          FORMI(NDCJ:NDCJ) = CHAR(ICHAR('0') + NDECJ)
          ICSD(K)          = MIN (99, ICSD(K))
          ICSD(K + 3)      = MIN (99, ICSD(K + 3))
  220   CONTINUE
        CALL PLA047 (XLAB(I), NQ2, IDUM, JDUM, IPR(119),
     1                         IGBL(55), 0, 0)
        WRITE (PRBUF, FORMI) NQ2(1:6), (XXO(I, K), ICSD(K), K = 1, 6)
        CALL PLA067 (LU7, PRBUF, 132, 1, 3)
  230 CONTINUE
      IF (IRMST .GT. 0) THEN
        WRITE (LU6, 99994)
        WRITE (LU7, 99994)
      ENDIF
  240 RETURN
99999 FORMAT ('Analysis of Short Ring-Interactions with ',
     1 'Cg-Cg Distances < ', F5.1, ' Angstrom and Beta <', F5.1,
     2 ' Deg.', /, 132('='), /,
     3 '- Cg(I)    = Plane number I (= ring number in () above)', /,
     4 '- Alpha    = Dihedral Angle between Planes I and J (Deg)', /,
     5 '- Beta     = Angle Cg(I)-->Cg(J) or Cg(I)-->Me vector and',
     6 ' normal to plane I (Deg)', /,
     7 '- Gamma    = Angle Cg(I)-->Cg(J) vector and normal to',
     8 ' plane J (Deg)', /,
     9 '- Cg-Cg    = Distance between ring Centroids (Ang.)', /,
     * '- CgI_Perp = Perpendicular distance of Cg(I) on',
     1 ' ring J (Ang.)', /,
     2 '- CgJ_Perp = Perpendicular distance of Cg(J) on',
     3 ' ring I (Ang.)', /,
     4 '- Slippage = Distance between Cg(I) and Perpendicular',
     5 ' Projection of Cg(J) on Ring I (Ang).', /,
     6 '- P,Q,R,S  = J-Plane Parameters for Carth. Coord.',
     7 ' (Xo, Yo, Zo)', //, 'Cg(I) Res(I)', 3X,
     8 'Cg(J)  [', 3X, 'ARU(J)] ', 6X, 'Cg-Cg', 3X,
     9 'Transformed J-Plane P, Q, R, S', 3X, 'Alpha', 4X,
     * 'Beta', 3X, 'Gamma', 1X, 'CgI_Perp CgJ_Perp Slippage', /)
99997 FORMAT (//, 'Ring-Metal Interactions with Cg-Me < ', F5.1,
     1 ' Ang.', /, 132('='), //,
     2 'Cg(I) Res(I)', 3X, 'Me(J)   [', 3X, 'ARU(J)]  Cg(I)-Me(J)',
     3 ' MeJ_Perp    Beta', /)
99996 FORMAT (A, '[', I2, '] -> ', A, ' [', F9.2, '] ', 2F10.3, F9.2)
99995 FORMAT ('Geometry around Metals Involving Ring centroids', /,
     1        132('='), /)
99994 FORMAT (/, 'W: Ring-Metal Search Truncated', /)
99993 FORMAT (/, 'W: Problem - Ring-(Ring/Metal) search aborted', I5,/)
99992 FORMAT (/, 'Analysis of X-H...Cg(Pi-Ring) Interactions',
     1 ' (H..Cg <', F4.1, ' Ang. - Gamma < ', F5.1, ' Deg)', /,
     2         132('='), //, '   X--H(I)    Res(I)', 3X,
     3 'Cg(J)  [', 3X, 'ARU(J)]', 7X, 'H..Cg', 2X,
     4 'Transformed J-Plane P, Q, R, S  H-Perp Gamma', 6X,
     5 'X-H..Cg', 8X, 'X..Cg X-H,Pi', /)
99990 FORMAT (46X, 7('-'), 33X, 46('-'), /, 36X, 'Min or Max',
     1        F7.3, 32X, F7.3, F7.2, 5X, F8.2, 5X, F8.3, F7.2)
99989 FORMAT (38X, 7('-'), 33X, 40('-'), /, 28X, 'Min or Max',
     1        F7.3, 33X, F8.2, F8.2, F8.2, F8.3, F8.3)
99988 FORMAT (/, 'The Cg(I) refer to the Ring Centre-of-Gravity ',
     1        'numbers given in () in the Ring-Analysis above', //,
     2        'Cg(I)', 11X, 'x', 15X, 'y', 15X, 'z', 20X,
     3        'Xo', 14X, 'Yo', 14x, 'Zo', /)
99987 FORMAT (/, 'Analysis of Y-X...Cg(Pi-Ring) Interactions',
     1 ' (X..Cg <', F4.1, ' Ang. - Gamma < ', F5.1, ' Deg)', /,
     2         132('='), //, '   Y--X(I)    Res(I)', 3X,
     3 'Cg(J)  [', 3X, 'ARU(J)]', 7X, 'X..Cg', 2X,
     4 'Transformed J-Plane P, Q, R, S  X-Perp Gamma', 6X,
     5 'Y-X..Cg', 8X, 'Y..Cg Y-X,Pi', /)
      END
      SUBROUTINE PLA049 (IFUN, D)
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16,
     1 NP11=128,NP19=31,NP25=99,NP29=63,NP41=200,NP47=9)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /DERIV/ NDIR, VIJ(3), VJK(3)
      DIMENSION DSV(8), VIJK(3), VIJKD(3)
      KM     = 1
      DSV(1) = D
      DSV(2) = XPV(1)
      IF (IFUN .EQ. 2) THEN
        CALL GEN008 (VIJ, VJK, VIJK, 0)
      ELSE IF (IFUN .EQ. 4) THEN
        DO 10 I = 1, 8
          DSV(I) = XPV(I)
   10   CONTINUE
        KM = 4
      ENDIF
      DO 50 I = 1, NDIR
        ITP = IDIR(I)
        DO 40 J = 1, 3
          ITEK = 1
          SINC = SQRT(XSD(ITP, J + 3))
          XXO(ITP, J + 3) = XXO(ITP, J + 3) + SINC
          IF (IFUN .EQ. 1) THEN
            CALL PLA050 (IDIR(1), IDIR(2), 0, 0, XPV(1))
          ELSE IF (IFUN .EQ. 2) THEN
            CALL PLA050 (IDIR(1), IDIR(2), IDIR(3), 0, XPV(1))
            CALL GEN008 (VIJ, VJK, VIJKD, 0)
            IF (GEN009 (VIJK, VIJKD) .LT. 0.0) XPV(1) = 360.0 - XPV(1)
          ELSE IF (IFUN .EQ. 3) THEN
            CALL PLA050 (IDIR(1), IDIR(2), IDIR(3), IDIR(4), XPV(1))
            IF ((DSV(1) - XPV(1)) .GT. 180.0)  THEN
              XPV(1) = XPV(1) + 360.0
            ELSE IF ((DSV(1) - XPV(1)) .LT. -180.0) THEN
              XPV(1) = XPV(1) - 360.0
            ENDIF
          ELSE IF (IFUN .EQ. 4) THEN
            CALL PLA054 (0)
            ITEK = NINT(GEN009(XPV, DSV))
          ENDIF
          XXO(ITP, J + 3) = XXO(ITP, J + 3) - SINC
          DO 30 K = 1, KM
            XDIR(I, J, K) = ITEK * XPV(K) - DSV(K)
   30     CONTINUE
   40   CONTINUE
   50 CONTINUE
      D      = DSV(1)
      XPV(1) = DSV(2)
      IF (IFUN .EQ. 4) THEN
        DO 60 I = 1, 8
          XPV(I) = DSV(I)
   60   CONTINUE
      ENDIF
      RETURN
      END
      SUBROUTINE PLA050 (I, J, K, L, D)
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16,
     1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP25=99,NP29=63,
     2 NP38=125,NP39=30,NP41=200,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /DERIV/ NDIR, VIJ(3), VJK(3)
      DIMENSION VKL(3), R(3), S(3), T(3)
      IF (I .LE. 0   .OR. J .LE. 0)   GOTO 40
      IF (I .GT. NP1 .OR. J .GT. NP1) GOTO 40
      IF (K .EQ. 0) THEN
        D = 0
        DO 10 KK = 1, 3
          DK = XXO(I, KK + 3) - XXO(J, KK + 3)
          D = D + DK**2
   10   CONTINUE
        D = SQRT(D)
      ELSE IF (K .GT. 0 .AND. L .EQ. 0) THEN
        IF (K .GT. NP1) GOTO 40
        DAK = 0
        DBK = 0
        DAB = 0
        DO 20 KK = 1, 3
          VIJ(KK)  = XXO(I, KK + 3) - XXO(J, KK + 3)
          VJK(KK)  = XXO(K, KK + 3) - XXO(J, KK + 3)
          DAK      = DAK + VIJ(KK)**2
          DBK      = DBK + VJK(KK)**2
          DAB      = DAB + VIJ(KK)*VJK(KK)
   20   CONTINUE
        IF (DAK .LE. 0.0 .OR. DBK .LE. 0.0) THEN
          D = 0
        ELSE
          C = DAB / SQRT(DAK * DBK)
          C = MAX (-1.0, MIN (1.0, C))
          D = ACOS(C) * GL(5)
        ENDIF
      ELSE IF (L .GT. 0) THEN
        IF (L .GT. NP1) GOTO 40
        DO 30 N = 1, 3
          VIJ(N) = XXO(J, N + 3) - XXO(I, N + 3)
          VJK(N) = XXO(K, N + 3) - XXO(J, N + 3)
          VKL(N) = XXO(L, N + 3) - XXO(K, N + 3)
   30   CONTINUE
        CALL GEN008 (VIJ, VJK, R, 1)
        CALL GEN008 (VJK, VKL, S, 1)
        CALL GEN008 (R, S, T, 1)
        D = MAX (-1.0, MIN (1.0, GEN009(R, S)))
        D = ACOS(D) * GL(5)
        IF (GEN009 (VJK, T) .LT. 0.0) D = - D
      ELSE
        GOTO 40
      ENDIF
      RETURN
   40 WRITE (LU6, 99999) I, J, K, L
      WRITE (LU7, 99999) I, J, K, L
      RETURN
99999 FORMAT (/, 'F: Invalid arg(s) in call to PLA050 ', 4I10, /)
      END
      SUBROUTINE PLA051 (IAT)
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16,
     1 NP11=128,NP19=31,NP25=99,NP29=63,NP41=200,NP47=9)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /DERIV/ NDIR, VIJ(3), VJK(3)
      NDIR = NDIR + 1
      IDIR(NDIR) = IAT
      DO 20 I = 1, 3
        DO 10 J = 1, 4
          XDIR(NDIR, I, J) = 0.0
   10   CONTINUE
   20 CONTINUE
      RETURN
      END
      SUBROUTINE PLA052 (IFUN, SD)
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16,
     1 NP11=128,NP19=31,NP25=99,NP29=63,NP41=200,NP47=9)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /DERIV/ NDIR, VIJ(3), VJK(3)
      DIMENSION SD(*)
      IF (IFUN .EQ. 4) THEN
        KM = 4
      ELSE
        KM = 1
      ENDIF
      DO 10 K = 1, KM
        SD(K) = 0
   10 CONTINUE
      DO 40 I = 1, NDIR
        DO 30 J = 1, 3
          DO 20 K = 1, KM
            SD(K) = SD(K) + XDIR(I, J, K)**2
   20     CONTINUE
   30   CONTINUE
   40 CONTINUE
      DO 50 K = 1, KM
        SD(K) = SQRT(SD(K))
   50 CONTINUE
      RETURN
      END
      SUBROUTINE PLA053 (I0, J0, K0, L0, D, SD, ISD, NDEC, IER)
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16,
     1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP25=99,NP29=63,
     2 NP38=125,NP39=30,NP41=200,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /DERIV/ NDIR, VIJ(3), VJK(3)
      DIMENSION SDD(2)
      I     = I0
      J     = J0
      K     = K0
      L     = L0
      IHAT  = 0
      JHAT  = 0
      KHAT  = 0
      LHAT  = 0
      IER   = 0
      NOESD = 1
      NESD  = 0
      SD    = 0.0
      CALL PLA050 (I, J, K, L, D)
      CALL GEN048 (-1, JFG(I), 10, IVAL)
      IF (IVAL .EQ. 0) NOESD = 0
      IF (NOESD .EQ. 1) THEN
        CALL GEN048 (-1, JFG(I), 30, IVAL)
        IF (IVAL .EQ. 1) NOESD = 0
      ENDIF
      IF (NOESD .EQ. 1) THEN
        CALL GEN048 (-1, JFG(I), 31, IVAL)
        NESD = NESD + IVAL
      ENDIF
      IF (NOESD .EQ. 1) THEN
        CALL GEN048 (-1, JFG(J), 10, IVAL)
        IF (IVAL .EQ. 0) NOESD = 0
      ENDIF
      IF (NOESD .EQ. 1) THEN
        CALL GEN048 (-1, JFG(J), 30, IVAL)
        IF (IVAL .EQ. 1) NOESD = 0
      ENDIF
      IF (NOESD .EQ. 1) THEN
        CALL GEN048 (-1, JFG(J), 31, IVAL)
        NESD = NESD + IVAL
      ENDIF
      CALL GEN048 (-1, IFG(I), 7, IHAT)
      CALL GEN048 (-1, IFG(J), 7, JHAT)
      IF (K .EQ. 0) THEN
        MODE = 1
        NDCD = 4
        IF (NESD .EQ. 2) NOESD = 0
      ELSE
        IF (NOESD .EQ. 1) THEN
          CALL GEN048 (-1, JFG(K), 10, IVAL)
          IF (IVAL .EQ. 0) NOESD = 0
        ENDIF
        IF (NOESD .EQ. 1) THEN
          CALL GEN048 (-1, JFG(K), 30, IVAL)
          IF (IVAL .EQ. 1) NOESD = 0
        ENDIF
        IF (NOESD .EQ. 1) THEN
          CALL GEN048 (-1, JFG(K), 31, IVAL)
          NESD = NESD + IVAL
        ENDIF
        NDCD = 2
        IF (L .EQ. 0) THEN
          MODE = 2
          IF (NESD .EQ. 3) NOESD = 0
          IF (D .LT. 1.0)  IER = - 1
          CALL GEN048 (-1, IFG(I), 5, IVAL)
          CALL GEN048 (-1, IFG(J), 6, JVAL)
          CALL GEN048 (-1, IFG(K), 5, KVAL)
          IF (ABS (180.0 - D) .LT. 0.05) THEN
            IF (JVAL .EQ. 1 .AND. IVAL + KVAL .EQ. 1) NOESD = 0
          ELSE IF (ABS(120.0 - D) .LT. 0.05 .OR.
     1             ABS(60.0  - D) .LT. 0.05) THEN
            CALL GEN048 (-1, IFG(J), 6, IVAL)
            IF (JVAL .EQ. 1 .AND. IVAL + KVAL .EQ. 1) THEN
              IF (IPR(259) .EQ. 5 .OR. IPR(259) .EQ. 6) NOESD = 0
            ENDIF
          ENDIF
          CALL GEN048 (-1, IFG(K), 7, KHAT)
        ELSE
          IF (NOESD .EQ. 1) THEN
            CALL GEN048 (-1, JFG(L), 10, IVAL)
            IF (IVAL .EQ. 0) NOESD = 0
          ENDIF
          IF (NOESD .EQ. 1) THEN
            CALL GEN048 (-1, JFG(L), 30, IVAL)
            IF (IVAL .EQ. 1) NOESD = 0
          ENDIF
          IF (NOESD .EQ. 1) THEN
            CALL GEN048 (-1, JFG(L), 31, IVAL)
            NESD = NESD + IVAL
          ENDIF
          MODE = 3
          IF (NESD .EQ. 4) NOESD = 0
          CALL PLA050 (I, J, 0, 0, D1)
          IF (D1 .LT. 0.1) IER = - 1
          CALL PLA050 (K, L, 0, 0, D1)
          IF (D1 .LT. 0.1) IER = - 1
          CALL PLA050 (I, K, 0, 0, D1)
          IF (D1 .LT. 0.1) IER = - 1
          CALL PLA050 (J, L, 0, 0, D1)
          IF (D1 .LT. 0.1) IER = - 1
          CALL GEN048 (-1, IFG(L), 7, LHAT)
        ENDIF
      ENDIF
      IF (NOESD .NE. 0) THEN
        NDIR = 0
        CALL PLA051 (I)
        CALL PLA051 (J)
        IF (K .GT. 0) CALL PLA051 (K)
        IF (L .GT. 0) CALL PLA051 (L)
        CALL PLA049 (MODE, D)
        CALL PLA052 (MODE, SDD)
        IF (K .EQ. 0) THEN
          SD = SQRT(SDD(1)**2 + (PAR(13) * D)**2)
        ELSE
          SD = SQRT(SDD(1)**2 + PAR(14)**2)
        ENDIF
      ENDIF
      CALL GEN041 (D, SD, ISD, NDCD, NDEC, IPR(68))
      IF (IPR(68) .EQ. 0) THEN
        IPR68 = 10
      ELSE
        IPR68 = IPR(68)
      ENDIF
      IF (ISD .GT. IPR68 * 10 - 1) THEN
        ISD  = -1
        NDEC = 0
        SD   = -1.0
      ENDIF
      IF (ISD .EQ. 0) THEN
        NHAT = IHAT + JHAT + KHAT + LHAT
        IF (NHAT .NE. 0) THEN
          IF (MODE .EQ. 1) THEN
            NDEC = 2
            D = NINT (D * 100.0) / 100.0
          ELSE
            NDEC = 0
            D = NINT (D)
          ENDIF
        ENDIF
      ENDIF
      RETURN
      END
      SUBROUTINE PLA054 (MODE)
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118,
     1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP25=99,
     2 NP29=63,NP38=125,NP39=30,NP41=200,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9),
     1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10),
     2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10),
     3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770)
      DIMENSION DUMW(3, 3), EV(3, 3), EW(3)
      NMAX = IPR(39)
      WHT = 1.0
      IF (MODE .EQ. 1) THEN
        IWHT = 1
      ELSE
        IWHT = IPR(41)
      ENDIF
      CALL GEN074 (DXI, 0.0, 1, 3)
      KP = 0
      WM = 0
      DO 30 N = 1, NMAX
        I = IATP(N)
        IF (I .LE. NP1) THEN
          IF (IWHT .EQ. 1) THEN
            CALL GEN048 (-4, IFG(I), 15, IVL)
            WHT = SATWT(IVL + 1)
          ELSE IF (IWHT .EQ. 2) THEN
            WHT = 3.0 / (XSD(I, 4) + XSD(I, 5) + XSD(I, 6))
          ENDIF
          KP = KP + 1
          WM = WM + WHT
          DO 20 J = 1, 3
            DXI(J) = DXI(J) + WHT * XXO(I, J + 3)
   20     CONTINUE
        ENDIF
   30 CONTINUE
      DO 50 I = 1, 3
        DXI(I) = DXI(I) / WM
        DO 40 J = 1, 3
          DUMW(I, J) = 0.0
   40   CONTINUE
   50 CONTINUE
      DO 60 N = 1, NMAX
        I = IATP(N)
        IF (I .LE. NP1) THEN
          IF (IWHT .EQ. 1) THEN
            CALL GEN048 (-4, IFG(I), 15, IVL)
            WHT = SATWT(IVL + 1)
          ELSE IF (IWHT .EQ. 2) THEN
            WHT = 3.0 / (XSD(I, 4) + XSD(I, 5) + XSD(I, 6))
          ENDIF
          XX  = XXO(I, 4) - DXI(1)
          YY  = XXO(I, 5) - DXI(2)
          ZZ  = XXO(I, 6) - DXI(3)
          XSQ = XX**2
          YSQ = YY**2
          ZSQ = ZZ**2
          DUMW(1, 1) = DUMW(1, 1) + WHT * (YSQ + ZSQ)
          DUMW(1, 2) = DUMW(1, 2) - WHT * XX * YY
          DUMW(1, 3) = DUMW(1, 3) - WHT * XX * ZZ
          DUMW(2, 2) = DUMW(2, 2) + WHT * (ZSQ + XSQ)
          DUMW(2, 3) = DUMW(2, 3) - WHT * YY * ZZ
          DUMW(3, 3) = DUMW(3, 3) + WHT * (XSQ + YSQ)
        ENDIF
   60 CONTINUE
      CALL GEN024 (DUMW, EV, EW, DUMV)
      DO 70 I = 1, 3
        XPV(I)  = DUMV(I, 1)
        DUMA(I) = EW(I)
   70 CONTINUE
      XPV(4) = GEN009(XPV, DXI)
      XPV(8) = XPV(4)
      RETURN
      END
      SUBROUTINE PLA055
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16,
     1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP25=99,NP29=63,
     2 NP38=125,NP39=30,NP41=200,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /DERIV/ NDIR, VIJ(3), VJK(3)
      NMAX   = IPR(39)
      CALL PLA054 (0)
      CALL GEN002 (-1, OR, XPV(1), XPV(5), XLNG)
      CALL GEN074 (XSPV, 0.0, 1, 8)
      IF (IPR(72) .GT. 0) THEN
        NDIR = 0
        N = 0
        DO 20 I = 1, NMAX
          IATPI = IATP(I)
          IF (IATPI .LE. NP1) THEN
            N = N + 1
            IF (N .GT. NP7) GOTO 60
            CALL PLA051 (IATPI)
          ENDIF
   20   CONTINUE
        D = 0.0
        CALL PLA049 (4, D)
        CALL PLA052 (4, XSPV)
        DO 40 J = 1, 3
          XSPV(4 + J) = 0.0
          DO 30 K = 1, 3
            XSPV(4 + J) = XSPV(4 + J) + (XSPV(K) * OR(K, J))**2
   30     CONTINUE
   40   CONTINUE
        DO 50 K = 5, 7
          XSPV(K) = SQRT(XSPV(K))
   50   CONTINUE
        XSPV(8) = XSPV(4)
      ENDIF
   60 RETURN
      END
      SUBROUTINE PLA056 (PV, IAT, D, SD, ISD, NDECD, NDEC)
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16,
     1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP25=99,NP29=63,
     2 NP38=125,NP39=30,NP41=200,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      DIMENSION PV(*)
      NDEC  = NDECD
      D     = - PV(4)
      DO 10 I = 1, 3
         D = D + PV(I) * XXO(IAT, I + 3)
   10 CONTINUE
      SD  = 0
      ISD = 0
      IF (IPR(72) .NE. 0) THEN
        DO 30 I = 1, 3
          XXO(IAT, I + 3) = XXO(IAT, I + 3) + PAR(12)
          DAC = - PV(4)
          DO 20 J = 1, 3
            DAC = DAC + PV(J) * XXO(IAT, J + 3)
   20     CONTINUE
          XXO(IAT, I + 3) = XXO(IAT, I + 3) - PAR(12)
          DIR = (DAC - D) / PAR(12)
          SD = SD + XSD(IAT, I + 3) * DIR**2
   30   CONTINUE
        SD = SQRT(SD)
        CALL GEN041 (D, SD, ISD, NDECD, NDEC, IPR(68))
      ENDIF
      RETURN
      END
      SUBROUTINE PLA057 (IAT, JAT, KAT)
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118,
     1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP22=256,
     2 NP25=99,NP29=63,NP38=125,NP39=30,NP41=200,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9),
     1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10),
     2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10),
     3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770)
      CHARACTER MARK*2, IMRK1*5, FORMI*98, FORMJ*24, FORMK*6, CXMOL2*9
      COMMON /PAGENM/ PAGET, PAGEIND(25)
      CHARACTER PAGET*8, PAGEIND*8
      PAGET = 'INTER'
      ANGLE = 0.0
      DIJ   = 0.0
      SDIJ  = 0.0
      NDEC1 = 0
      NDEC2 = 0
      ISDIJ = 0
      NATHX = 0
      NATHY = 0
C * SETUP PRINT FORMATS
      FORMI( 1: 32) = '(   A,1X,''.... '',A,''['',A   ,'']'','
      FORMI(33: 65) = 'F8.3,''('',I3,'')'',A,F5.2,F6.2,1X,A,'
      FORMI(66: 98) = '1X,2(3F7.4,2X),A,F7.2,''('',I3,'')'')'
      FORMJ( 1: 24) = '(112X,A,F7.2,''('',I3,'')'')'
      FORMK( 1: 6 ) = '(F9.2)'
      IF (PAR(42) .LT. 100.0) FORMK(5:5) = '1'
      IF (IPR(90) .EQ. 1) THEN
        IF (IPR(15) .LE. 0) THEN
          IF (IPR(15) .EQ. 0 .AND. IGBL(63) .GT. 2) THEN
            CALL PLA269 (-6)
            IF (LMT(IENS(IAN), 1) .EQ. 'Cg') THEN
              IAN0 = IAN - 1
            ELSE
              IAN0 = IAN
            ENDIF
            WRITE (LU7, 99997) PAR(1), PAR(33),
     1        (LMT(IENS(K), 1), K = 1, IAN0)
            WRITE (LU7, 99996) (RADR(IENS(K), 2), K = 1, IAN0)
            IF (IGBL(63) .GT. 3) THEN
              CALL PLA269 (6)
              WRITE (LU7, 99998)
            ENDIF
          ENDIF
          CALL PLA066 (0, 0, 0, 0, 0.0, 0.0, 0.0, 0.0, 0.0)
          IF (IPR(2) .NE. 0) STOP '302'
          PAR(67) = 1555.0 + IPR(61) / PAR(42)
          IF (IPR(75) .NE. 1 .AND. IGBL(63) .GT. 2) THEN
            CALL PLA269 (6)
            WRITE (LU7, 99999) PAR(67)
          ENDIF
          IF (IGBL(63) .GT. 2) THEN
            CALL PLA269 (3)
            WRITE (LU7, 99995) PAR(67)
          ENDIF
          IPR(15) = 1
        ENDIF
        CALL PLA036 (IAT, 1, 1, IPOPI, IDUM1, IDUM2, IPR(119), IGBL(55))
        IDSORD = 0
        IF (IPR(67) .NE. 0) IPOPI = 1000
        IF (IPOPI .LT. 1000) THEN
          IDSORD = IDSORD + 10
          X1     = - XLAB(IAT)
        ELSE
          X1     = XLAB(IAT)
        ENDIF
        X3 = 0.0
        NC = - NINT(CON(IAT, NP4))
        IF (NC .LT. 0) NC = NP4
        IF (NC .GT. 0) THEN
          INCX = NINT(CON(IAT, 1))
          IF (INCX .GT. 0 .AND. INCX .LE. NP1) THEN
            X3   = XLAB(INCX)
            CALL GEN048 (-3, JFG(INCX), 24, NATHX)
          ELSE
            WRITE (LU6, '(''PLA057 INCX = '', I10)') INCX
          ENDIF
        ENDIF
        CALL PLA036 ( KAT, 1, 4, IPOPK, MN, IDUM2, IPR(119), IGBL(55))
        CALL PLA036 (-KAT, 1, 2, IPOPK, MN, IDUM2, IPR(119), IGBL(55))
        IF (IPOPK .LT. 1000) THEN
          IDSORD = IDSORD + 1
          X2 = - XLAB(KAT)
        ELSE
          X2 =   XLAB(KAT)
        ENDIF
        X4 = 0.0
        NC = - NINT(CON(JAT, NP4))
        IF (NC .LT. 0) NC = NP4
        IF (NC .GT. 0) THEN
          JNCX = NINT(CON(JAT, 1))
          IF (JNCX .GT. 0 .AND. JNCX .LE. NP1) THEN
            X4   = XLAB(JNCX)
            CALL GEN048 (-3, JFG(JNCX), 24, NATHY)
          ELSE
            WRITE(LU6, '(''PLA057 JNCX = '', I10)') JNCX
          ENDIF
        ENDIF
        MOL2 = MOL(MN)
        IARU = NINT(PAR(42))
        IF (MOL2 .EQ. 1555 * IARU) MOL2 = MOL2 + IPR(62)
        XMOL2 = MOL2 / PAR(42)
        CALL PLA053 (IAT, KAT, 0, 0, DIJ, SDIJ, ISDIJ, NDEC1, IER)
        ISDIJ = MIN (999, ISDIJ)
        MARK  = '  '
        DMX0  = PAR(23) - PAR(1)
        DELT  = DIJ - DMX0
        DIJ29 = DIJ
        IF (DELT .LT. 0) THEN
          DIJ29 = DIJ29 + 100.0
          MARK  = ' <'
          IF (DELT + PAR(1) .LT. 0.0) THEN
            CALL GEN048 (-1, IFG(IAT), 7, IHA)
            CALL GEN048 (-1, IFG(KAT), 7, KATHA)
            CALL GEN048 (-1, IFG(IAT), 20, IDOH)
            CALL GEN048 (-1, IFG(KAT), 20, KDOH)
            CALL GEN048 (-1, IFG(IAT), 23, IDOA)
            CALL GEN048 (-1, IFG(KAT), 23, KDOA)
            IF (DELT .LT. PAR(199) .AND. IAT .LT. KAT) THEN
              IF ((IDOH .EQ. 1 .OR. KDOA .EQ. 1) .AND.
     1            (IDOA .EQ. 1 .OR. KDOH .EQ. 1)) THEN
                IPR(160) = IPR(160) + 1
              ENDIF
              PAR(200) = MIN (DELT, PAR(200))
            ENDIF
            IF (DELT .LT. PAR(251 + 2 * IPR(20))
     1          .AND. IAT .LE. JAT) THEN
              IF (IHA .EQ. 1 .AND. KATHA .EQ. 1 .AND.
     1            (IPOPI .EQ. 1000 .OR. IPOPK .EQ. 1000)) THEN
                IPR(403 + IPR(20)) = IPR(403 + IPR(20)) + 1
                PAR(252 + 2 * IPR(20)) =
     1                  MIN (DELT, PAR(252 + 2 * IPR(20)))
                IPR20 = IPR(20)
                IKDOH = IDOH + KDOH
                IF (IKDOH .EQ. 0) THEN
                  IF (NATHX .EQ. 3 .OR. NATHY .EQ. 3) IPR20 = IPR20 + 2
                ELSE IF (IKDOH .EQ. 1) THEN
                  IPR20 = IPR(20) + 4
                ELSE IF (IKDOH .EQ. 2) THEN
                  IPR20 = IPR(20) + 6
                ENDIF
                WRITE (LU20, 99993) '_41',
     1           IPR20, - DELT, DIJ, NAMS(1, 1)(2:8), NAMS(1, 2)(2:8)
              ENDIF
            ENDIF
            DIJ29 = DIJ29 + 100.0
            MARK = '<<'
            IF (IPOPI .GE. 500 .AND. IPOPK .GE. 500) THEN
              IF (IHA .NE. 1 .AND. KATHA .NE. 1 .AND. IPR(20) .EQ. 1)
     1          THEN
                  IF (IPR(88) .LT. NP2) THEN
                    IPR(88)         = IPR(88) + 1
                    XLS(1, IPR(88)) = XLAB(IAT)
                    XLS(2, IPR(88)) = PAR(67)
                    XLS(3, IPR(88)) = -XLAB(KAT)
                    XLS(4, IPR(88)) = XMOL2
                    XLS(5, IPR(88)) = IPR(61)
                    XLS(6, IPR(88)) = DIJ
                    XLS(7, IPR(88)) = DELT
                    XLS(8, IPR(88)) = IDSORD
                  ELSE
                    IPR(149) = IPR(149) + 100
                  ENDIF
              ENDIF
            ENDIF
          ENDIF
        ENDIF
        IF (IPR(20) .EQ. 1) THEN
          CALL PLA066 (1, MOL2, NATHX, NATHY, X1, X2, X3, X4, DIJ29)
          IF (IPR(2) .NE. 0) STOP '303'
        ENDIF
        IF (IPR(20) .EQ. 0) THEN
          IMRK1 = 'Intra'
        ELSE
          IMRK1 = '     '
        ENDIF
        ANGL  = -1.0
        SA    = 0.0
        IANGL = 0
        NC    = - NINT(CON(IAT, NP4))
        N     = 0
        NLINE = 0
   10   N     = N + 1
        IF (N .GT. NC) THEN
          IF (NLINE .NE. 0) GOTO 20
        ELSE
          K = NINT(CON(IAT, N))
          IF (K .GT. IPR(37)) GOTO 10
          CALL PLA053 (K, IAT, KAT, 0, ANGLE, SA, IANGL, NDEC2, IER)
          IF (IER .NE. 0) GOTO 10
          IF (ANGLE .LT. PAR(33)) GOTO 10
          CALL PLA036 (K, 1, 3, IDUM1, IDUM2, IDUM3, IPR(119), IGBL(55))
          ANGL  = ANGLE
          IANGL = MIN (999, IANGL)
        ENDIF
        IF (NLINE .EQ. 0) THEN
          WRITE (CXMOL2, FORMK) XMOL2
          IF (INT(XMOL2) .EQ. 1555) CXMOL2 = '         '
          FORMI(36 : 36) = CHAR(ICHAR('0') + NDEC1)
          IF (ANGL .LT. 0) THEN
            WRITE (PRBUF, FORMI) (NAMS(1, L), L = 1, 2),
     1      CXMOL2, DIJ, ISDIJ, MARK, DMX0, DELT, IMRK1,
     2       (XXO(IAT, L), L = 1, 3), (XXO(KAT, L), L = 1, 3)
          ELSE
            FORMI(86 : 86) = CHAR(ICHAR('0') + NDEC2)
            WRITE (PRBUF, FORMI) (NAMS(1, L), L = 1, 2),
     1       CXMOL2, DIJ, ISDIJ, MARK, DMX0, DELT, IMRK1,
     2        (XXO(IAT, L), L = 1, 3), (XXO(KAT, L), L = 1, 3),
     3        NAMS(1, 3), ANGL, IANGL
          ENDIF
          IF (MN .LT. 28) THEN
            IF (IPR(438) * IGBL(97) .EQ. 1) THEN
              IPR(254) = IPR(254) + 1
              WRITE (LU2, 99994) NAMS(1, 1)(2:8), NAMS(1, 4)(2:8),
     1                           DIJ, SDIJ
            ENDIF
          ENDIF
        ELSE
          FORMJ(12 : 12) = CHAR(ICHAR('0') + NDEC2)
          WRITE (PRBUF, FORMJ) NAMS(1, 3), ANGL, IANGL
        ENDIF
        IF (IGBL(63) .GT. 2) CALL PLA067 (LU7, PRBUF, 132, 1, 11)
        NLINE = NLINE + 1
        GOTO 10
      ENDIF
   20 RETURN
99999 FORMAT (/, 57X, 13('='), /, 56('*'), ' ARU =', F8.2, 1X,
     1        61('*'), /, 57X, 13('='), /)
99998 FORMAT (/, 'Default Contact Radii are those given by A.Bondi',
     1 ', J.Phys.Chem. (1964),68,441. (or Coval. Rad. + 0.8 Ang.',
     2 ' when not given)', //, '* WARNING * : no Far-Reaching',
     3 ' Conclusions should be drawn based on the Default Radii',
     4 ' Assigned to Metals', //, 'Short "INTRA" Distances between',
     5 ' two Atoms that are Separated by less than 4 Bonds are NOT',
     6 ' Listed (Except for Potential D/A Contacts)', /)
99997 FORMAT ('Analysis of Short Intra- and Inter-molecular Contacts',
     1 ' ,  d(I-J) <  R(I) + R(J) + Tolr, With Tolr =', F5.1,
     2 ' Ang. (X - I...J) >', F5.0, ' Deg.', /, 132('-'), /,
     3 'Contact Radii :', 16(3X, A))
99996 FORMAT ('(Angstrom)', 5X, 16F5.2)
99995 FORMAT (132('-')/, 'At(I)[', F7.2, '] At(J)  [  ARU(J) ]',
     1 7X, 'D(I-J)  Sumrad  Del  Type    X(I)   Y(I)   Z(I)', 5X,
     2 'X(J)   Y(J)   Z(J)   X', 9X, 'X - I...J', /, 132('-'))
99994 FORMAT ('NONB ', 2(A, 2X), 2F8.4)
99993 FORMAT (A, I1, 2F10.2, 2A)
      END
      SUBROUTINE PLA058 (I, J, K, L, IDET)
      COMMON /PL40/ LHNT(4, 3, 5), NETH(64, 3), MXL
      IDET =  LHNT(I, 1, L)  * (LHNT(J, 2, L)  *  LHNT(K, 3, L)
     1     -  LHNT(K, 2, L)  *  LHNT(J, 3, L)) +  LHNT(I, 2, L)
     2     * (LHNT(J, 3, L)  *  LHNT(K, 1, L)  -  LHNT(J, 1, L)
     3     *  LHNT(K, 3, L)) +  LHNT(I, 3, L)  * (LHNT(J, 1, L)
     4     *  LHNT(K, 2, L)  -  LHNT(J, 2, L)  *  LHNT(K, 1, L))
      IDET = ABS(IDET)
      RETURN
      END
      SUBROUTINE PLA059 (JAT, KAT)
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16,
     1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP25=99,NP29=63,
     2 NP38=125,NP39=30,NP41=200,NP45=2048,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /Q/ ICL, IFL(NP17)
      CHARACTER ICL*(NP45), IFL*7
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      IF (JAT .GT. NP1 .OR. JAT .LE. 0) THEN
        WRITE (LU6, 99999) JAT, KAT
        STOP 'Report problem to Author'
      ENDIF
      IF (JAT .NE. KAT) THEN
        DO 10 I = 1, 3
          XJX(I + 3) = 0.0
          XJX(I)     = XXO(JAT, I)
   10   CONTINUE
        CALL SGSM (ICL, IPR(54), XJX, LU7, 3, IERR)
        DO 20 I = 4, 6
          XJS(I)           = XJX(I + 3) + ITR(I - 3)
          XJS(IPR(30 + I)) = XJS(I)
   20   CONTINUE
        IF (IPR(189) .EQ. 0) THEN
          DO 30 I = 1, 3
            XJX(I) = XSD(JAT, I)
   30     CONTINUE
          NSMM = -IPR(54)
          CALL SGSM (ICL, NSMM, XJX, LU7, 3, IERR)
        ENDIF
      ENDIF
      DO 50 N = 1, 3
        J   = 4 - N
        JP3 = J + 3
        IF (JAT .NE. KAT) THEN
          XXO(KAT, J) = XJS(J + 3)
          XSD(KAT, J) = XJX(J + 6)
        ENDIF
        XXO(KAT, JP3) = 0.0
        XSD(KAT, JP3) = 0.0
        DO 40 L = J, 3
          ORJK = OR(J, L)
          XXO(KAT, JP3) = XXO(KAT, JP3) + XXO(KAT, L) * ORJK
          IF (IPR(189) .EQ. 0) THEN
            IF (IPR(72) .NE. 0) THEN
              XSD(KAT, JP3) = XSD(KAT, JP3) + XSD(KAT, L) * ORJK**2
            ENDIF
          ENDIF
   40   CONTINUE
   50 CONTINUE
      RETURN
99999 FORMAT (/, 'Problem in PLA059; JAT & KAT =', 2I12, /)
      END
      SUBROUTINE PLA065 (MODE, IAT)
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118,
     1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP22=256,
     2 NP25=99,NP29=63,NP38=125,NP39=30,NP41=200,NP45=2048,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9),
     1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10),
     2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10),
     3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770)
      COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0
      COMMON /CGG11/ BCD, SBCD
      CHARACTER BCD*132, SBCD*132
      COMMON /CGGT/ IGGT
      CHARACTER IGGT*80
      COMMON /PL65/ NBOND, NPNT, NPNTM
      COMMON /Q/ ICL, IFL(NP17)
      CHARACTER ICL*(NP45), IFL*7
      IF (MODE .EQ. 0) THEN
        NBOND = 0
        NPNT  = NINT (PAR(262) * 100.0)
        NPNTM = 2 * NPNT
        CALL GEN074 (DATC, 0.0, NPNT + 1, NPNTM)
      ELSE IF (MODE .GT. 0) THEN
        NC = IPR(79)
        IF (NC .GT. 0) THEN
          CALL PLA047 (XLAB(IAT), NQ3, MNX, IENI, 0, IGBL(55), 0,
     1                                             1 - IGBL(55))
          CALL GEN048 (-7, JFG(IAT), 1, IPP)
          MULTI = IPR(48) / IPPR(IPP + 1, 3)
          CALL PLA036 (IAT, 1, 1, IDUM1, MNI, IDUM3, IPR(119),
     1         IGBL(55))
          NCI = 0
          NDB = 0
          DO 30 J = 1, NC
            KAT  = IATC(J)
            MKAT = MOD (KAT, NP1)
            IDUB = 0
            IF (J .GT. 1) THEN
              DO 20 K = 2, J
                IF (MKAT .EQ. MOD(IATC(K - 1), NP1)) THEN
                  IDUB = 2
                  NDB  = NDB + 1
                ENDIF
   20         CONTINUE
            ENDIF
            CALL GEN048 (-1, IFG(MKAT), 7, IHA)
            PADD = (IDUB + IHA + 1) * PAR(23)
            IF (KAT .LE. NP1) THEN
              CALL PLA041 (-1, IAT, JJ, KAT)
              IF (JJ .GT. 0) THEN
                NCI  = NCI + 1
                PADD = 0
              ENDIF
            ENDIF
            DATC(J) = PADD + DATC(J)
   30     CONTINUE
          CALL GEN013 (DATC, IATC, 1, NC)
          NC = NC - NDB
          DO 40 J = 1, NC
            KAT     = IATC(J)
            IPR(20) = 0
            IF (KAT .GT. NP1) THEN
              KAT     = KAT - NP1
              IATC(J) = KAT
              IPR(20) = 1
            ENDIF
            CALL GEN048 (-6, IFG(KAT), 9, IRESJ)
            CALL PLA036 (KAT, 1, 2, IDUM1, MNJ, IDUM3, IPR(119),
     1           IGBL(55))
            XLABX = - XLAB(KAT)
            CALL PLA047 (XLABX, NQ4, MNY, IENK, IPR(119), IGBL(55), 0,
     1               1 - IGBL(55))
            CALL PLA046 (2, NQ4, IDUM, LBB, LBC, LBD, XLMP, YNQNR, KATP)
            CALL PLA047 (XLAB(KAT), NQ3, MNY, IENK, IPR(119), IGBL(55),
     1                 0, 1 - IGBL(55))
            CALL PLA053 (IAT, KAT, 0, 0, DIJ, SDIJ, ISDIJ, NDEC, IER)
            NBOND = NBOND + 1
            NI   = IATNR(IENI)
            NK   = IATNR(IENK)
            NIJ = INT(DIJ * 100.0) + NPNT + 1
            DATC(NIJ) = DATC(NIJ) + FLOAT(NI * NK) / FLOAT(MULTI)
   40     CONTINUE
        ENDIF
      ELSE
   50   CALL GEN074 (DATC, 0.0, 1, NPNT)
        DO 70 I = 1, NPNT
          IF (IPR(581) .EQ. 0) THEN
            A = DATC(I + NPNT)
          ELSE
            A = DATC(I + NPNT) / I
          ENDIF
          IF (A .GT. 0.0) THEN
            DATC(I) = DATC(I) + A
            J = 0
   60       J = J + 1
            FACT = A * EXP (- (J / PAR(451)) ** 2)
            IF (I + J .LE. NPNT) DATC(I + J) = DATC(I + J) + FACT
            IF (I - J .GT. 0)    DATC(I - J) = DATC(I - J) + FACT
            IF (J .LT. 200) GOTO 60
          ENDIF
   70   CONTINUE
        AMX = 0.0
        DO 80 I = 1, NPNT
          AMX = MAX (AMX, DATC(I))
   80   CONTINUE
   90   IGBL(23) = 28
        BCD(1:30) = 'Simulated Radial Distribution'//CHAR(0)
        CALL GGIP (HORS, VERT, 0.0, 1)
        CALL GGIP20 (0.0,  BCD, 29, 1.0, 4, 8, 0.6, VERT - 1.6)
        CALL GGIP20 (0.0,  BCD, 29, 1.0, 2, 8, 0.5, VERT - 1.7)
        CALL PLA117 (HORS, VERT, -1)
        VRT = VERT - 3.0
        CALL PLA283 (0, 1, N, IDM)
        WRITE (LINE, 99989) IDM(N:80)
        CALL GGIP20 (0.0, LINE, 60, 0.35, 1, 1, 1.5, VRT)
        WRITE (LINE, 99999) SPGRNM(1)(1:7)
        VRT = VRT - 0.5
        CALL GGIP20 (0.0, LINE, 17, 0.35, 1, 1, 1.5, VRT)
        WRITE (LINE, 99998) PAR(101)
        VRT = VRT - 0.5
        CALL GGIP20 (0.0, LINE, 13, 0.35, 1, 1, 1.5, VRT)
        WRITE (LINE, 99997) PAR(102)
        VRT = VRT - 0.5
        CALL GGIP20 (0.0, LINE, 13, 0.35, 1, 1, 1.5, VRT)
        WRITE (LINE, 99996) PAR(103)
        VRT = VRT - 0.5
        CALL GGIP20 (0.0, LINE, 13, 0.35, 1, 1, 1.5, VRT)
        WRITE (LINE, 99995) PAR(104)
        VRT = VRT - 0.5
        CALL GGIP20 (0.0, LINE, 13, 0.35, 1, 1, 1.5, VRT)
        WRITE (LINE, 99994) PAR(105)
        VRT = VRT - 0.5
        CALL GGIP20 (0.0, LINE, 13, 0.35, 1, 1, 1.5, VRT)
        WRITE (LINE, 99993) PAR(106)
        VRT = VRT - 0.5
        CALL GGIP20 (0.0, LINE, 13, 0.35, 1, 1, 1.5, VRT)
        WRITE (LINE, 99990) PAR(98)
        VRT = VRT - 0.5
        CALL GGIP20 (0.0, LINE, 13, 0.35, 1, 1, 1.5, VRT)
        XSTEP = (HORS - 2.0) / NPNT
        SCF   = (VERT - 4.0) / AMX
        CALL GGIP (1.0, 2.0, 0.0, 3)
        XP = 1.0
        DO 100 I = 1, NPNT
          XP = XP + XSTEP
          YP = 2.0 + SCF * DATC(I)
          CALL GGIP (XP, YP, 0.0, 2)
  100   CONTINUE
        CALL GGIP (0.0, 0.0, 0.0, 3)
        XP = 1.0
        N  = 0
        NM = NPNT / 50
        XST = XSTEP * 50
  110   CALL GGIP (XP, 1.0, 0.0, 3)
        CALL GGIP (XP, 1.4, 0.0, 2)
        IF (N .LT. 20) THEN
          WRITE (NQ1, 99992) N * 0.5
        ELSE
          WRITE (NQ1, 99991) N * 0.5
        ENDIF
        CALL GGIP20 (0.0, NQ1, 4, 0.2, 2, 2, XP + 0.1, 1.2)
        XP = XP + XST
        N  = N  + 1
        IF (N .LE. NM) GOTO 110
        CALL GGIP20 (0.0, 'Angstrom', 8, 0.3, 2,2, HORS - 2.4, 0.2)
        CALL PLA013 (0, 1)
        CALL GEN072 (IGGT, IFL, FN, KL, KN, 0, LU6, 1, 1, 80, 7, NP17)
        IF (IFL(1)(1:4) .EQ. 'EXIT') THEN
          GOTO 120
        ELSE IF (IFL(1)(1:4) .EQ. 'CALC') THEN
          GOTO 120
        ELSE IF (IFL(1)(1:3) .EQ. 'END') THEN
          IGGT = ' '
          IGBL(23) = 10
          GOTO 120
        ELSE IF (LRET .EQ. 2) THEN
          GOTO 50
        ELSE
          GOTO 90
        ENDIF
      ENDIF
  120 RETURN
99999 FORMAT ('SpGroup ', A)
99998 FORMAT ('a    ', F8.2)
99997 FORMAT ('b    ', F8.2)
99996 FORMAT ('c    ', F8.2)
99995 FORMAT ('alpha', F8.2)
99994 FORMAT ('beta ', F8.2)
99993 FORMAT ('gamma', F8.2)
99992 FORMAT (F3.1)
99991 FORMAT (F4.1)
99990 FORMAT ('Volume', F7.1)
99989 FORMAT ('Formula ', A)
      END
      SUBROUTINE PLA066 (MODE, MOLX, NATHX, NATHY, X1, X2, X3, X4, DIST)
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118,
     1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP22=256,
     2 NP25=99,NP29=63,NP38=125,NP39=30,NP41=200,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9),
     1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10),
     2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10),
     3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770)
      CHARACTER MARK*2, IDS1*1, IDS2*1, FORMI*81
      DIMENSION ZMOLX(6), AMOLX(51)
      FORMI( 1:43) = '(I4,'' ['',F9.2,'']'',I8,F11.4,F7.2,4X,I1,1X,A,'
      FORMI(44:81) = '''-'',2A,''... '',2A,''-'',A,I2,3X,A,6F10.2)'
      IF (PAR(42) .LT. 100.0) THEN
        FORMI(13:13) = '1'
        FORMI(80:80) = '1'
      ENDIF
      N = IPR(49)
      IF (MODE .EQ. 0) THEN
        IPR(49) = 0
      ELSE IF (MODE .LT. 0) THEN
        IF (N .GT. 0 .AND. IPR(149) .LE. 0) THEN
          NSMOL  = IPR(51)
          IF (IGBL(63) .GT. 2) THEN
            CALL PLA269 (8)
            WRITE (LU7, 99999) PAR(3), IPR(104)
          ENDIF
          NI = 0
          DO 150 K = 1, NSMOL
            ML = MOL(K)
            CALL GEN098 (ML, PAR(42), M1, M2, M3, M4, NRES)
            IF (NRES .EQ. 0) THEN
              NRES = IPR(104)
              ML = ML + NRES
            ENDIF
            IF (NRES .EQ. IPR(104)) THEN
              RMOL = ML / PAR(42)
              DO 30 I = 1, N
                MARK  = '  '
                DIJ   = MOD(BOK(I, 1), 100.0)
                ISML  = INT(BOK(I, 1) / 100.0)
                IF (ISML .GT. 0) MARK = ' <'
                IF (ISML .GT. 1) MARK = '<<'
                CALL GEN098 (KBO(I, 1), PAR(42), M1, M2, M3, M4, MRES)
                VMOL = KBO(I, 1) / PAR(42)
                CALL PLA081 (18, RMOL, VMOL, XMOLX)
                IF (IPR(2) .NE. 0) GOTO 100
                ZMOLX(1) = XMOLX
                IF (BOK(I, 2) .LT. 0) THEN
                  IDS1 = '*'
                ELSE
                  IDS1 = ' '
                ENDIF
                XLABN1 = - ABS(BOK(I, 2))
                IF (BOK(I, 3) .LT. 0) THEN
                  IDS2 = '*'
                ELSE
                  IDS2 = ' '
                ENDIF
                NQ3 = '       '
                NQ4 = '       '
                XLABN2 = - ABS(BOK(I, 3))
                XLABN3 = - ABS(BOK(I, 4))
                XLABN4 = - ABS(BOK(I, 5))
                CALL PLA047 (XLABN1, NQ1, IDUM, IENI, IPR(119),
     1                       IGBL(55), 0, 0)
                CALL PLA047 (XLABN2, NQ2, IDUM, IENJ, IPR(119),
     1                       IGBL(55), 0, 0)
                IF (XLABN3 .NE. 0.0)
     1            CALL PLA047 (XLABN3, NQ3, IDUM, IENK, IPR(119),
     1                         IGBL(55), 0, 0)
                IF (XLABN4 .NE. 0.0)
     1            CALL PLA047 (XLABN4, NQ4, IDUM, IENL, IPR(119),
     1                         IGBL(55), 0, 0)
                SUMRAD = ABS(VDWR(IENI)) + ABS(VDWR(IENJ))
                DEL    = DIJ - SUMRAD
                NSML   = 1
                IF (NSMOL .GT. 1) THEN
                  DO 120 L = 2, NSMOL
                    ML = MOL(L)
                    CALL GEN098 (ML, PAR(42), L1, L2, L3, L4, MLRES)
                    IF (IPR(2) .NE. 0) GOTO 100
                    IF (MLRES .EQ. MRES .AND. NSML .LT. 6) THEN
                      YMOLX = ML / PAR(42)
                      CALL PLA081 (19, XMOLX, YMOLX, ZMOLX(NSML + 1))
                      IF (IPR(2) .EQ. 52) GOTO 100
                      IF (IPR(2) .EQ. 28) THEN
                        IPR(2) = 0
                      ELSE
                        NSML = NSML + 1
                      ENDIF
                    ENDIF
  120             CONTINUE
                ENDIF
                IF (NSML .GT. 1) THEN
                  DO 180 I1 = 1, NSML
                    K1 = NSML + 1
                    DO 190 J1 = I1 + 1, NSML
                      K1 =  K1 - 1
                      IF (ZMOLX(K1) .LT. ZMOLX(K1 - 1))
     1                  CALL GEN018 (ZMOLX(K1), ZMOLX(K1 - 1))
  190               CONTINUE
  180             CONTINUE
                ENDIF
                AMOLX(NI + 1) = ZMOLX(1)
                IF (NI .GT. 0) THEN
                  DO 200 I1 = 1, NI
                    IF (AMOLX(I1) .EQ. ZMOLX(1)) GOTO 30
  200             CONTINUE
                ENDIF
                IF (NI .LT. 50) NI = NI + 1
                IF (IGBL(63) .GT. 2) THEN
                  CALL PLA269 (1)
                  WRITE (LU7, FORMI) NI, XMOLX, KBO(I, 2), DIJ, DEL,
     1            KBO(I, 3), NQ3, IDS1, NQ1, IDS2, NQ2, NQ4,
     2            KBO(I, 4), MARK, (ZMOLX(L), L = 1, NSML)
                ENDIF
   30         CONTINUE
            ENDIF
  150     CONTINUE
          IPR(49) = 0
          IF (IGBL(63) .GT. 2) THEN
            CALL PLA269 (4)
            WRITE (LU7, 99997) PAR(3)
          ENDIF
        ENDIF
      ELSE
        IF (N .GT. 0) THEN
          DO 60 I = 1, N
            IF (KBO(I, 1) .EQ. MOLX) THEN
              KBO(I, 2) = KBO(I, 2) + 1
              IF (MOD(DIST, 100.0) .GT. MOD(BOK(I, 1), 100.0)) THEN
                GOTO 100
              ELSE
                GOTO 90
              ENDIF
            ENDIF
   60     CONTINUE
        ENDIF
        I = N + 1
        IF (I .GT. NP8) THEN
          IPR(149) = IPR(149) + 1
          GOTO 100
        ENDIF
        KBO(I, 1) = MOLX
        KBO(I, 2) = 1
        IPR(49)   = IPR(49) + 1
   90   BOK(I, 1) = DIST
        BOK(I, 2) = X1
        BOK(I, 3) = X2
        BOK(I, 4) = X3
        BOK(I, 5) = X4
        KBO(I, 3) = NATHX
        KBO(I, 4) = NATHY
      ENDIF
  100 RETURN
99999 FORMAT (//, 'Summary of Shortest Inter Contacts with d(I-J) < ',
     1 ' R(I) + R(J) + ', F4.1, ' of Residue #', I3,
     2 ' to Neighbouring ARU''S', /, 132('='), //, 2X,
     3 'Nr', 7X, 'ARU', 4X, 'Nr.Cont.', 3X, 'd(min)', 4X, 'Del',
     4 2X, 'XHn X      - At(I)', 7X, 'At(J)  - Y    YHn  Note', 2X,
     5 'Partaking ARU''s in Close Contact Resd.', /, 132('-'))
99997 FORMAT (/, 'Symbols :: < denotes contacts less than the sum of ',
     1 'the van der Waals Radii and << contacts less than this sum ',
     2 'minus', F4.1, ' Angstrom.',/,
     3 11X, 'Nr.Cont. = Number of short contacts from current ARU to',
     4 ' surrounding ARU''s (from list above).')
      END
      SUBROUTINE PLA067 (LU, PRBUF, JBUFL, NLINE, JSUBST)
      CHARACTER PRBUF*(*)
      IF (NLINE .GT. 0) CALL PLA269 (NLINE)
      CALL GEN065 (LU, PRBUF, JBUFL, JSUBST)
      RETURN
      END
      SUBROUTINE PLA068 (MODE, ARU)
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16,
     1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP25=99,NP29=63,
     2 NP38=125,NP39=30,NP41=200,NP45=2048,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /Q/ ICL, IFL(NP17)
      CHARACTER ICL*(NP45), IFL*7
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      IF (MODE .EQ. 0) THEN
        IPR(25) = 0
      ELSE IF (MODE .GT. 0) THEN
        IF (IPR(13) + IPR(25) + 2 .LT. NP11) THEN
          NEWARU = NINT(ARU * PAR(42))
          IF (IPR(25) .GT. 0) THEN
            DO 10 I = 1, IPR(25)
              IF (NEWARU .EQ. MOL(IPR(13) + I)) GOTO 100
   10       CONTINUE
          ENDIF
          IPR(25) = IPR(25) + 1
          MOL(IPR(25) + IPR(13)) = NEWARU
        ENDIF
      ELSE IF (MODE .LT. 0) THEN
        IF (IPR(25) .GT. 0) THEN
          CALL PLA269 (1)
          WRITE (LU7, 99998)
          DO 20 I = 1, IPR(25)
            ML = MOL(IPR(13) + I)
            CALL GEN098 (ML, PAR(42), MOL1, MOL2, MOL3, MOL4, IRS0)
            XJX(4) = MOL2
            XJX(5) = MOL3
            XJX(6) = MOL4
            CALL SGSM (ICL, MOL1, XJX, 0, 20, IERR)
            ML = INT(ML / PAR(42))
            CALL PLA269 (1)
            WRITE (LU7, 99999) ML, ICL(1:30)
   20     CONTINUE
        ENDIF
      ENDIF
  100 RETURN
99999 FORMAT ('[', I6, '] = ', A)
99998 FORMAT (1X)
      END
      SUBROUTINE PLA069
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118,
     1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP22=256,
     2 NP25=99,NP29=63,NP38=125,NP39=30,NP41=200,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9),
     1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10),
     2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10),
     3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770)
      COMMON /PAGENM/ PAGET, PAGEIND(25)
      CHARACTER PAGET*8, PAGEIND*8
      COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0
      IF (IPR(71) .GT. 0) THEN
        IPR(2) = 10
      ELSE
        NNAT = 0
        IWIN = 0
        CALL PLA293 (PAR(17), LU20)
        CALL PLA089
        IF (IPR(2) .EQ. 0) THEN
          NSYM = IPR(48)
          NAT  = IPR(37)
          IF (IPR(17) .EQ. 0) THEN
            PAGET = 'INTRA'
            NNAT = 1
            CALL GEN074 (RCG, 0.0, 1, NP29 * 4)
          ENDIF
C * BRANCH FOR INTRA, INTER/VOID OR COORDINATION CALCULATIONS
   10     IAT   = 0
          IATNF = 0
          IATHF = 0
          IF (IPR(17) .EQ. 0) THEN
            MNAT = NNAT
            INXT = 0
            DO 30 N = MNAT, NAT
              CALL GEN048 (-4, IFG(N), 15, IVAL)
              IATPRP = IATPR(IEN(IVAL + 1))
              CALL GEN048 (-3, IFG(N), 1, IVAL)
              IF (IVAL .GT. 3) THEN
                CALL GEN048 (-1, IFG(N), 7, IHAT)
                IF (IHAT .EQ. 1) THEN
                  CALL GEN048 (3, IFG(N), 1, 3)
                  DO 20 JJ = 1, 3
                    RCG(JJ, IPR(75)) = RCG(JJ, IPR(75)) + XXO(N, JJ)
   20             CONTINUE
                  RCG(4, IPR(75)) = RCG(4, IPR(75)) + 1
                  GOTO 30
                ELSE IF (IATPRP .LT. 0) THEN
                  CALL GEN048 (-1, JFG(N), 9, NCONS)
                  IF (NCONS .EQ. 1) THEN
                    IAT = N
                    GOTO 130
                  ELSE
                    IF (IATNF .EQ. 0) IATNF = N
                  ENDIF
                ELSE
                  CALL GEN048 (-1, JFG(N), 9, NCONS)
                  IF (NCONS .EQ. 1) THEN
                    IF (IATHF .LE. 0) IATHF = N
                  ELSE
                    IF (IATHF .EQ. 0) IATHF = - N
                  ENDIF
                ENDIF
              ELSE IF (IVAL .EQ. 3) THEN
                IF (N .EQ. NNAT) NNAT = NNAT + 1
              ELSE
                IF (INXT .LE. 0) THEN
                  IF (IATPRP .LT. 0) THEN
                    INXT = N
                  ELSE
                    IF (INXT .EQ. 0) INXT = - N
                  ENDIF
                  CALL GEN048 (-7, JFG(N), 1, IPP)
                  IPR(184) = IPPR(IPP + 1, 1)
                ENDIF
              ENDIF
   30       CONTINUE
            IF (IAT .EQ. 0) THEN
              IF (IATHF .GT. 0) THEN
                IAT = IATHF
                GOTO 130
              ELSE IF (IATHF .LT. 0) THEN
                IF (IATNF .NE. 0) THEN
                  IAT = IATNF
                ELSE
                  IAT = - IATHF
                ENDIF
                IPR(124) = 1
                GOTO 130
              ELSE
                IF (IATNF .NE. 0) THEN
                  IAT = IATNF
                  IPR(124) = 1
                  GOTO 130
                ENDIF
              ENDIF
              JJ = IPR(75)
              IF (JJ .GT. 0) THEN
                ICG  = IPR(39) + IPR(24) + 1
                KAT1 = ICG  + 1
                ICG1 = KAT1 + 1
                DO 40 J = 1, 3
                  IF (RCG(4, JJ) .NE. 0.0)
     1              RCG(J, JJ) = RCG(J, JJ) / RCG(4, JJ)
                  XXO(ICG,  J) = RCG(J, JJ)
                  XXO(KAT1, J) = PAR(63 + J)
                  XSD(ICG,  J) = 0.0
                  XSD(KAT1, J) = 0.0
   40           CONTINUE
                IATP(ICG) = 1555
                IF (IGBL(30) .EQ. 0) THEN
                  DUM5 = 99999.0
                  CALL PLA059 (KAT1, KAT1)
                  DO 80 J = 1, NSYM
                    IPR(54) = J
                    DO 50 L = 1, 3
                      ITR(L) = 0
   50               CONTINUE
                    CALL PLA059 (ICG, ICG1)
                    DO 60 L = 1, 3
                      DUM1 = MOD(XXO(ICG1, L), 1.0)
                      IF (DUM1 .LT. 0.0) DUM1 = DUM1 + 1.0
                      ITR(L)       = NINT(DUM1 - XXO(ICG1, L))
                      XXO(ICG1, L) = DUM1
   60               CONTINUE
                    CALL PLA059 (ICG1, ICG1)
                    CALL PLA050 (ICG1, KAT1, 0, 0, DUM4)
                    IF (DUM4 .LT. DUM5) THEN
                      DUM5  = DUM4
                      FN(1) = J
                      DO 70 L = 1, 3
                        FN(L + 1) = ITR(L)
   70                 CONTINUE
                    ENDIF
   80             CONTINUE
                  YM1  = FN(1) * 1000 + FN(2) * 100.0 + FN(3) * 10.0 +
     1                   FN(4) + 555 + JJ / PAR(42)
                  CALL PLA081 (1, YM1, 0.0, YMM1)
                  DO 100 I = 1, ICG
                    CALL GEN048 (-6, IFG(I), 9, JJRES)
                    IF (JJ .EQ. JJRES) THEN
                      ITRNS = NINT(FN(1) * 1000 + 555)
                      DO 90 L = 1, 3
                        XXO(KAT1, L) = XXO(I, L)
                        XSD(KAT1, L) = XSD(I, L)
                        ITR(L)       = NINT(FN(L + 1))
                        IF (IABS(ITR(L)) .GT. 4) THEN
                          CALL PLA047 (XLAB(KAT1), NQ1, IDUM, JDUM, 0,
     1                                 IGBL(55), 0, 0)
                          IPR(2) = 17
                          GOTO 200
                        ENDIF
                        ITRNS = ITRNS + ITR(L) * 10**(3 - L)
   90                 CONTINUE
                      IF (ITRNS .NE. 1555) THEN
                        IF (I .LT. ICG) WRITE (LU4) 5, XLAB(I),
     1                     (FN(L), L = 1, 8)
                        IPR(54) = NINT(FN(1))
                        CALL PLA059 (KAT1, I)
                      ENDIF
                      YM2 = IATP(I)
                      CALL PLA081 (2, YM1, YM2, YM3)
                      IATP(I) = NINT(YM3)
                      CALL GEN048 (1, IFG(I), 2, 1)
                    ENDIF
  100             CONTINUE
                  L2 = IPR(13)
                  DO 110 L = 1, L2
                    ML = MOL(L)
                    CALL GEN098 (ML, PAR(42), MOL1, MOL2, MOL3, MOL4,
     1                           JJRES)
                    IF (JJ .EQ. JJRES) THEN
                      IF (MOL1 .GT. IPR(48)) THEN
                        MOL0 = NINT(IPR(48) * 1000.0 * PAR(42))
                      ELSE
                        MOL0 = 0
                      ENDIF
                      ML  = ML - MOL0
                      YM3 = ML / PAR(42)
                      CALL PLA081 (3, YM1, YM3, YM2)
                      CALL PLA081 (4, YM2, YMM1, YM3)
                      MOL(L) = NINT(YM3 * PAR(42)) + MOL0
                    ENDIF
  110             CONTINUE
                ENDIF
              ENDIF
              IF (INXT .EQ. 0) THEN
                CALL PLA094 (IPR(110))
                DO 120 I = 1, IPR(13)
                  MOLS(I) = MOL(I)
  120           CONTINUE
                IPR(53) = IPR(13)
                GOTO 200
              ELSE
                IAT     = IABS(INXT)
                IPR(75) = IPR(75) + 1
                IF (IPR(75) .GT. IPR(129)) THEN
                  IPR(75)  = IPR(129)
                  IPR(130) = 1
                ENDIF
                CALL GEN048 (6, IFG(IAT), 9, IPR(75))
                CALL PLA078 (IAT)
                IF (IPR(2) .NE. 0) THEN
                  CALL PLA047 (XLAB(IAT), NQ1, IDUM, JDUM, IPR(119),
     1                         IGBL(55), 0, 0)
                  GOTO 200
                ELSE
                  IPR(166) = IABS(IATP(IAT))
                  GOTO 130
                ENDIF
              ENDIF
            ENDIF
  130       CALL GEN048 (1, IFG(IAT), 3, 1)
            CALL GEN048 (1, JFG(IAT), 9, 1)
            GOTO 160
          ELSE IF (IPR(17) .LT. 0) THEN
            IPR(13) = IPR(51)
            IF (IPR(189) .NE. 0) THEN
              CALL PLA125
              GOTO 200
            ENDIF
          ELSE IF (IPR(17) .GT. 0) THEN
            IF (IPR(168) .GT. 0) THEN
              IAT = IPR(168)
              GOTO 160
            ELSE
              IPR(13) = IPR(51)
              GOTO 150
            ENDIF
          ENDIF
  150     IAT = IAT + 1
          IF (IAT .GT. NAT) GOTO 190
  160     CALL GEN048 (-4, IFG(IAT), 15, IPR(58))
          IPR(509) = IEN(IPR(58) + 1)
          CALL GEN048 (-7, JFG(IAT), 1, IPP)
          IPR(128) = IPPR(IPP + 1, 1) * IPPR(IPP + 1, 3) / NSYM
          IPR(127) = IPPR(IPP + 1, 1)
          IF (IPR(127) .LT. 1000) THEN
            IPR(98) = 1 - IPR(502) * IABS(IPR(17))
          ELSE
            IPR(98) = 0
          ENDIF
          CALL GEN048 (-6, IFG(IAT), 9, IPR(61))
          PAR(19) = RADR(IPR(58) + 1, 2) + PAR(1)
          IF (IPR(17) .EQ. 0) THEN
            IATPRI = IATPR(IPR(509))
            IF (IPR(509) .EQ. 10 .OR. IPR(509) .EQ. 11 .OR.
     1          IPR(509) .EQ. 30 .OR. IPR(509) .EQ. 59 .OR.
     2          IPR(509) .EQ. 94 .OR. IPR(509) .EQ. 103) THEN
              IPR(157) = IPR(509)
            ELSE IF (IATPRI .EQ. 5 .OR. IATPRI .EQ. 6) THEN
              IPR(157) = 1
            ELSE IF (IPR(325) .EQ. 0 .AND. IATPRI .LT. 0) THEN
              IF (IPR(509) .GE. 3 .AND. IPR(509) .LE. 5) THEN
                IPR(157) = - IPR(509)
              ELSE
                IPR(157) = -1
              ENDIF
            ELSE IF (IPR(325) .EQ. -1 .AND. IATPRI .EQ. -1) THEN
              IF (IPR(509) .EQ. 3 .OR. IPR(509) .EQ. 4) THEN
                IPR(157) = - IPR(509)
              ELSE
                IPR(157) = -1
              ENDIF
            ELSE
              IPR(157) = 0
            ENDIF
            IPR(191) = ISIGN(1, IATPRI)
          ELSE IF (IPR(17) .LT. 0) THEN
            IF (IPR(104) .NE. IPR(61)) GOTO 150
          ELSE IF (IPR(17) .GT. 0) THEN
            IF (IPR(168) .EQ. 0) THEN
              IF (RADR(IPR(58) + 1, 2) .LT. 0.001) GOTO 150
            ELSE IF (IPR(168) .EQ. IAT) THEN
              PAR(19) = PAR(68)
            ELSE
              GOTO 150
            ENDIF
            IPR(13) = IPR(51)
            IPR(24) = 0
            IPR(79) = 0
          ENDIF
          CALL PLA070 (IAT, KAT)
          IF (IPR(2) .NE. 0) GOTO 200
          IF (IPR(17) .EQ. 0) THEN
            IF (IPR(203) .EQ. 0) THEN
              DO 180 JJ = 1, 3
                RCG(JJ, IPR(75)) = RCG(JJ, IPR(75)) + XXO(IAT, JJ)
  180         CONTINUE
              RCG(4, IPR(75)) = RCG(4, IPR(75)) + 1
            ENDIF
            GOTO 10
          ELSE IF (IPR(17) .GT. 0) THEN
            IF (IPR(138) .EQ. 0) THEN
              IF (IPR(57) .NE. 2) THEN
                CALL PLA072 (IAT)
              ELSE
                CALL PLA065 (1, IAT)
              ENDIF
            ELSE
              WRITE (LU6, 99999) NP11
              IPR(138) = 0
              IF (IPR(168) .EQ. 0) THEN
                RADR(IPR(58) + 1, 2) = RADR(IPR(58) + 1, 2) - 1.0
              ELSE
                PAR(68) = PAR(68) - 1.0
              ENDIF
              IAT = IAT - 1
            ENDIF
            IF (IPR(168) .GT. 0) GOTO 190
          ENDIF
          GOTO 150
  190     IF (IPR(17) .LT. 0) THEN
            IF (IPR(90) .EQ. 1) THEN
              CALL PLA066 (-1, 0, 0, 0, 0.0, 0.0, 0.0, 0.0, 0.0)
              IF (IPR(2) .NE. 0) GOTO 200
            ENDIF
            IPR(104) = IPR(104) + 1
            IF (IPR(104) .LE. IPR(75)) THEN
              IAT     = 0
              IPR(15) = - IABS(IPR(15))
              GOTO 150
            ENDIF
            IF (IPR(90) .GT. 0) CALL PLA043 (0, 1, LU7, 0)
            IF (IPR(149) .EQ. 0) THEN
              CALL PLA091 (1)
              IF (IPR(2) .NE. 0) GOTO 200
            ENDIF
            CALL PLA090
            IF (IPR(149) .EQ. 0 .AND. IPR(300) .GT. 0) THEN
              CALL PLA091 (0)
              IF (IPR(2) .NE. 0) GOTO 200
              CALL PLA092
            ENDIF
          ENDIF
        ENDIF
      ENDIF
  200 IF (IWIN .EQ. 1) THEN
        IF (IPR(168) .EQ. 0 .AND. IPR(326) .LT. 2) CALL PLA297 (0)
        IF (IPR(189) .NE. 0 .AND. IPR(121) .EQ. 0
     1               .AND. IPR(326) .NE. 1) CALL PLA280 ('RESTART')
      ENDIF
      IF (IPR(17) .EQ. 0 .AND. IPR(37) .GT. 100) IGBL(75) = 0
      RETURN
99999 FORMAT (/, ':: ARU-LIST Overflow (', I3, '), Radius Reduced', /)
      END
      SUBROUTINE PLA070 (IAT, KAT)
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118,
     1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP25=99,
     2 NP29=63,NP38=125,NP39=30,NP41=200,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9),
     1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10),
     2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10),
     3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770)
      CHARACTER CSCRAT*1
      P23K  = 0.0
      NSYM = IPR(48)
      NAT  = IPR(37)
      DO 10 K = 1, 3
        INDX           = IPR(33 + K)
        DXI(INDX)      = XXO(IAT, K)
        DUMA(INDX + 3) = PAR(112 + K)
   10 CONTINUE
      IPR(203) = 0
   20 KAX      = -1
      IPR(80)  = 0
   30 IF (KAX .EQ. 0) THEN
        GOTO 50
      ELSE IF (KAX .GT. 0) THEN
        GOTO 110
      ENDIF
      IPR(54)  = 0
   40 IPR(54)  = IPR(54) + 1
      KAX      = -1
      IF (IPR(54) .GT. NSYM) THEN
        IF (IPR(17) .EQ. 0) THEN
          IF (IPR(80) .NE. 0) GOTO 20
          CALL GEN048 (3, IFG(IAT), 1, 3)
        ENDIF
        GOTO 230
      ENDIF
      JAT = 0
   50 JAT = JAT + 1
      IF (JAT .GT. NAT) GOTO 40
      IF (IPR(189) .NE. 0) THEN
        CALL GEN048 (-1, JFG(JAT), 27, IOMT)
        IF (IOMT .NE. 0) GOTO 50
      ENDIF
      CALL GEN048 (-10, IFG(JAT), 9, IHLP)
      IPR(59)  = IHLP / 64
      IPR(62)  = MOD(IHLP, 64)
      PAR(23)  = PAR(19)
      ADDEA    = 0.0
      IPR(510) = IEN(IPR(59) + 1)
      IF (IPR(17) .GT. 0) THEN
        IF (IPR(57) .NE. 0) THEN
          IF (RADR(IPR(59) + 1, 2) .LT. 0.001) GOTO 50
        ENDIF
        GOTO 60
      ELSE IF (IPR(17) .EQ. 0) THEN
        IATPRJ = IATPR(IPR(510))
        IF (IPR(510) .EQ. 10 .OR. IPR(510) .EQ. 11 .OR.
     1      IPR(510) .EQ. 30 .OR. IPR(510) .EQ. 59 .OR.
     2      IPR(510) .EQ. 94 .OR. IPR(510) .EQ. 103) THEN
          IPR(158) = IPR(510)
        ELSE IF (IATPRJ .EQ. 5 .OR. IATPRJ .EQ. 6) THEN
          IPR(158) = 1
        ELSE IF (IPR(325) .EQ.  0 .AND. IATPRJ .LT.  0) THEN
          IF (IPR(510) .GE. 3 .AND. IPR(510) .LE. 5) THEN
            IPR(158) = - IPR(510)
          ELSE
            IPR(158) = -1
          ENDIF
        ELSE IF (IPR(325) .EQ. -1 .AND. IATPRJ .EQ. -1) THEN
          IF (IPR(510) .EQ. 3 .OR. IPR(510) .EQ. 4) THEN
            IPR(158) = - IPR(510)
          ELSE
            IPR(158) = -1
          ENDIF
        ELSE
          IPR(158) = 0
        ENDIF
        IPR(192) = ISIGN(1, IATPRJ)
        IF (IPR(156) .EQ. 0) THEN
          ITST = IPR(157) * IPR(158)
          IF (ITST .EQ. -30  .OR. ITST .EQ.  -40 .OR.
     1        ITST .EQ. -50  .OR. ITST .EQ. -120) THEN
            ADDEA = PAR(5)
          ELSE IF (ITST .EQ. -177 .OR. ITST .EQ. -236) THEN
            ADDEA = PAR(6)
          ELSE IF (ITST .EQ. -1 .OR. ITST .EQ. -3 .OR.
     1             ITST .EQ. -4) THEN
            ADDEA = IGBL(97) * PAR(26)
          ENDIF
          IF (IPR(191) + IPR(192) .EQ. 2) ADDEA = PAR(27)
        ENDIF
        IF (IPR(62) .NE. 0) THEN
          IF (IPR(62) .NE. IPR(61)) GOTO 50
        ENDIF
        IF (IPR(509) .EQ. 3 .AND. IPR(510) .EQ. 1)
     1    PAR(23) = PAR(23) - 0.15
      ENDIF
      PAR(23) = PAR(23) + RADR(IPR(59) + 1, 2) + ADDEA
      IF (IPR(509) .EQ. 10 .AND. IPR(510) .EQ. 10) PAR(23) = 2.0
   60 P23K    = PAR(23)**2
      DO 70 I = 1, 3
        DUMA(I) = DUMA(I + 3) * PAR(23)
        ITR(I)  = 0
   70 CONTINUE
      IF (IPR(27) .EQ. 1) THEN
        IPR(26) = 1555
        KAT     = JAT
        KAX     = 0
        GOTO 180
      ENDIF
      DO 80 I = 1, 3
        XJS(I + 3) = 0.0
        XJS(I)     = XXO(JAT, I)
   80 CONTINUE
      CALL SGSM (CSCRAT, IPR(54), XJS, LU7, 3, IERR)
      DO 90 I = 1, 3
        XJS(IPR(33 + I)) = XJS(I + 6)
   90 CONTINUE
      KAX = 1
  100 IF (DXI(KAX) - XJS(KAX) .GT. DUMA(KAX)) GOTO 120
      XJS(KAX) = XJS(KAX) - 1.0
      GOTO 100
  110 KAX = KAX - 1
  120 XJS(KAX) = XJS(KAX) + 1.0
      IF (DXI(KAX) - XJS(KAX) .GE. DUMA(KAX)) GOTO 120
      IF (XJS(KAX) - DXI(KAX) .LE. DUMA(KAX)) GOTO 130
      KAX = KAX - 1
      IF (KAX .GT. 0) THEN
        GOTO 120
      ELSE
        GOTO 50
      ENDIF
  130 KAX = KAX + 1
      IF (KAX .LT. 4) GOTO 100
      NPOW    = 1000
      IPR(26) = IPR(54) * NPOW + 555
      DO 140 J = 1, 3
        NPOW       = NPOW / 10
        TEMP       = XJS(IPR(33 + J))
        ITR(J)     = ITR(J) + NINT(TEMP - XJS(J + 6))
        XJS(J + 6) = TEMP
        IF (IABS(ITR(J)) .GT. 4) THEN
          IPR(494) = IPR(494) + 1
          GOTO 30
        ENDIF
        IPR(26)    = IPR(26) + ITR(J) * NPOW
  140 CONTINUE
      KAT = IPR(39) + IPR(24) + 1
      IF (KAT .GT. NP1 - IPR(75)) THEN
        IPR(2) = 1
        GOTO 230
      ENDIF
      IF (IPR(189) .EQ. 0) THEN
        DO 150 I = 1, 3
          XJX(I) = XSD(JAT, I)
  150   CONTINUE
        NSMM = - IPR(54)
        CALL SGSM (CSCRAT, NSMM, XJX, LU7, 3, IERR)
      ENDIF
      DO 170 N = 1, 3
        J   = 4 - N
        JP3 = J + 3
        IF (JAT .NE. KAT) THEN
          XXO(KAT, J) = XJS(J + 6)
          XSD(KAT, J) = XJX(J + 6)
        ENDIF
        XXO(KAT, JP3) = 0
        XSD(KAT, JP3) = 0
        DO 160 L = J, 3
          ORJK = OR(J, L)
          XXO(KAT, JP3) = XXO(KAT, JP3) + XXO(KAT, L) * ORJK
          IF (IPR(189) .EQ. 0) THEN
            IF (IPR(72) .NE. 0) THEN
              XSD(KAT, JP3) = XSD(KAT, JP3)
     1                      + XSD(KAT, L) * ORJK**2
            ENDIF
          ENDIF
  160   CONTINUE
  170 CONTINUE
  180 DIJK = (XXO(IAT, 4) - XXO(KAT, 4))**2 +
     1       (XXO(IAT, 5) - XXO(KAT, 5))**2 +
     2       (XXO(IAT, 6) - XXO(KAT, 6))**2
      IF (DIJK .LE. P23K) THEN
        DIJ = SQRT(DIJK)
        IF (IPR(189) .EQ. 0) THEN
          IF (IPR(26) .EQ. 1555 .AND. IAT .EQ. JAT) GOTO 30
          CALL GEN048 (-1, IFG(JAT), 23, IVAL)
          CALL GEN048 (-1, JFG(JAT), 28, IVAL1)
          IPR(63) = IVAL + IVAL1 * IGBL(56)
          CALL GEN048 (-7, JFG(JAT), 1, JPP)
          IPR(120) = IPPR(JPP + 1, 1)
          IF (IPR(120) .LT. 1000) THEN
            IPR(99) = 1 - IPR(502) * IABS(IPR(17))
          ELSE
            IPR(99) = 0
          ENDIF
          IF (IPR(98) + IPR(99) .EQ. 2) THEN
            IF (IPR(17) .EQ. 0) THEN
              IF (IPR(189) .EQ. 0) THEN
                CALL GEN048 (6, IFG(JAT), 9, IPR(75))
                CALL GEN048 (-1, IFG(JAT), 1, IBT1)
                CALL GEN048 (-1, IFG(JAT), 2, IBT2)
                IF (IBT2 .EQ. 0 .AND. IBT1 .EQ. 0) THEN
                  IF (IPR(127) .NE. IPR(120)) THEN
                    CALL GEN048 (3, IFG(JAT), 1, 6)
                  ENDIF
                ELSE IF (IPR(26) .EQ. 1555) THEN
                  CALL GEN048 (1, JFG(JAT), 9, 1)
                  IF (IBT1 .EQ. 0) CALL GEN048 (1, IFG(JAT), 3, 1)
                ENDIF
              ENDIF
            ENDIF
            IF (IPR(127) .NE. IPR(120)) THEN
              IF (IPR(127) .LT. 500 .AND. IPR(120) .LT. 500) THEN
                IF (IABS(2 * IPR(127) - IPR(120)) .GT. 1 .AND.
     1            IABS(2 * IPR(120) - IPR(127)) .GT. 1) GOTO 30
              ELSE IF (IPR(127) + IPR(120) .GE. 999) THEN
                GOTO 30
              ENDIF
            ENDIF
            IF (IPR(154) .EQ. 0) THEN
              IF (IPR(128) .EQ. 500 .AND. IPR(54) .GT. 1) GOTO 30
            ENDIF
          ENDIF
          IF (IPR(17) .NE. 0) THEN
            IPR(20) = 1
            IARU    = NINT(PAR(42))
            IF (IPR(61) .EQ. IPR(62)) THEN
              IF (IPR(26) .NE. 1555) THEN
                CALL GEN048 (-1, IFG(JAT), 6, JSP)
                IF (JSP .EQ. 1) THEN
                  IF (IPR(17) .LT. 0) THEN
                    DO 190 L = 1, IPR(37)
                      CALL PLA050 (L, KAT, 0, 0, DST)
                      IF (DST .LT. 0.001) GOTO 30
  190               CONTINUE
                  ENDIF
                ENDIF
              ENDIF
              NITJ = IPR(26) * IARU
              IF (NITJ .NE. 1555 * IARU) NITJ = NITJ + IPR(62)
              N51 = IPR(51)
              DO 200 L = 1, N51
                MOLL = MOL(L)
                IF (L + IPR(101) .GT. N51)
     1            MOLL = MOLL - NSYM * 1000 * IARU
                IF (MOLL .EQ. NITJ) GOTO 210
  200         CONTINUE
              GOTO 220
  210         IF (L + IPR(101) .GT. N51) GOTO 30
              IPR(20) = 0
            ENDIF
          ENDIF
  220     IF (IPR(17) .LT. 0) THEN
            PAR26 = REL(IPR(509)) + REL(IPR(510))
            IF (IPR(510) .EQ. 3 .AND. IPR(509) .EQ. 1) THEN
              PAR26 = PAR26 + 0.25
            ELSE
              PAR26 = PAR26 + PAR(2)
            ENDIF
          ELSE
            PAR26 = PAR(18)
          ENDIF
          IF (IPR(27) .NE. 0 .OR. DIJ .GT. PAR26) THEN
            CALL PLA071 (IAT, JAT, KAT, DIJ)
          ENDIF
          IF (IPR(2) .NE. 0) GOTO 230
        ELSE
          IF (DIJ .GT. PAR(23) - PAR(20)) THEN
            IPR(199) = -1
            GOTO 30
          ELSE
            IPR(199) = 1
            GOTO 230
          ENDIF
        ENDIF
      ENDIF
      IF (IPR(17) .GT. 0) THEN
        IF (IPR(203) .GT. 0) GOTO 230
      ELSE IF (IPR(17) .EQ. 0) THEN
      ENDIF
      GOTO 30
  230 RETURN
      END
      SUBROUTINE PLA071 (IAT, JAT, KAT, DIJ)
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118,
     1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP25=99,
     2 NP29=63,NP38=125,NP39=30,NP41=200,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9),
     1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10),
     2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10),
     3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770)
      IDS  = 0
      IAUX = 0
      NAT  = IPR(39)
      IARU = NINT(PAR(42))
      IF (IPR(17) .EQ. 0) THEN
        IF (IPR(509) .EQ. 1 .OR. IPR(510) .EQ. 1) THEN
          IF (DIJ .GT. 2.0) GOTO 140
        ENDIF
        CALL GEN048 (-1, IFG(JAT), 7, JHAT)
        IF (JHAT .EQ. 1) THEN
          IF (IPR(509) .EQ. 2) THEN
            CALL GEN048 (-6, IFG(JAT), 9, IYK)
            IF (IYK .EQ. 0) THEN
              CALL GEN048 (-1, JFG(JAT), 10, IESD)
              IPR(474) = IPR(474) + IESD
            ENDIF
          ENDIF
        ENDIF
        CALL GEN048 (6, IFG(JAT), 9, IPR(75))
        CALL GEN048 (-1, IFG(JAT), 1, IBT1)
        CALL GEN048 (-1, IFG(JAT), 2, IBT2)
        IF (IBT2 .EQ. 1 .AND. IPR(26) .EQ. 1555) THEN
          CALL GEN048 (1, JFG(JAT), 9, 1)
        ENDIF
        IF (IBT1 .EQ. 0) CALL GEN048 (1, IFG(JAT), 3, 1)
        CALL GEN048 (-1, IFG(JAT), 3, IBT3)
        IF (IBT2 .EQ. 0) THEN
          IF (IPR(99) .NE. 0) THEN
            IF (IPR(26) .NE. IPR(166)) THEN
              IF (IBT1 .EQ. 0) CALL GEN048 (1, IFG(JAT), 3, 0)
              GOTO 140
            ENDIF
          ENDIF
          CALL GEN048 (1, IFG(JAT), 2, 1)
          CALL GEN048 (1, JFG(JAT), 9, 1)
          IF (IPR(157) .GE. 0 .AND. IPR(158) .LT. 0) IPR(203) = 1
          IF (IATP(JAT) .LE. 0) IATP(JAT) = 1555
          IF (IPR(26) .NE. 1555) THEN
            DO 60 L = 1, 6
              XXO(JAT, L) = XXO(KAT, L)
              XSD(JAT, L) = XSD(KAT, L)
   60       CONTINUE
            FN(1) = IPR(54)
            ITRNS = IPR(54) * 1000 + 555
            DO 70 L = 2, 4
              FN(L) = ITR(L - 1)
              ITRNS = ITRNS + ITR(L - 1) * 10**(4 - L)
   70       CONTINUE
            IATP(JAT) = ITRNS
            WRITE (LU4) 5, XLAB(JAT), (FN(L), L = 1, 8)
          ENDIF
          KAT     = JAT
          IPR(80) = 1
          GOTO 140
        ELSE
        ENDIF
      ELSE IF (IPR(17) .LT. 0) THEN
        N51    = IPR(51)
        N511   = N51 - IPR(101)
        MOL511 = (IPR(48) * 1000 + IPR(26)) * IARU + IPR(62)
        DO 50 K = 1, N51
          IF (K .GT. N511) THEN
            IF (MOL(K) .EQ. MOL511) GOTO 140
          ENDIF
          MOLK = MOL(K) / IARU
          IRES = MOL(K) - MOLK * IARU
          IF (MOLK .EQ. IPR(26)) THEN
            IF (IRES .EQ. 0 .OR. IPR(62) .EQ. IRES) THEN
              DO 40 N = 1, NAT
                CALL PLA050 (N, KAT, 0, 0, D)
                IF (D .LT. PAR(18)) THEN
                  KAT = N
                  IF (IPR(61) .NE. IPR(62)) THEN
                    GOTO 130
                  ELSE
                    CALL GEN048 (-1, IFG(IAT), 23, IDAC)
                    CALL GEN048 (-1, IFG(KAT), 23, KATDAC)
                    NCI = - NINT(CON(IAT, NP4))
                    IF (NCI .LT. 0) NCI = NP4
                    NCJ = - NINT(CON(KAT, NP4))
                    IF (NCJ .LT. 0) NCJ = NP4
                    DO 30 MI = 1, NCI
                      LI = NINT(CON(IAT, MI))
                      IF (LI .LE. NP1) THEN
                        IF (LI .EQ. KAT) GOTO 140
                        CALL GEN048 (-4, IFG(LI), 15, NOLI)
                        IF (MOD(IATPR(IEN(NOLI + 1)), 7) .LT. 5) THEN
                          DO 20 MJ = 1, NCJ
                            LJ = NINT(CON(KAT, MJ))
                            IF (LJ .LE. NP1) THEN
                              IF (LI .EQ. LJ) THEN
                                CALL GEN048 (-1, IFG(LI), 19, LIMET)
                                IF (LIMET .EQ. 0) GOTO 140
                                GOTO 130
                              ELSE
                                NCK = - NINT(CON(LJ, NP4))
                                IF (NCK .LT. 0) NCK = NP4
                                DO 10 MK = 1, NCK
                                  LK = NINT(CON(LJ, MK))
                                  IF (LK .EQ. LI) THEN
                                    CALL GEN048 (-1, IFG(LK), 19, LKMET)
                                    IF (LKMET .EQ. 0 .AND. (IDAC .EQ. 0
     1                                .OR. KATDAC .EQ. 0)) GOTO 140
                                    GOTO 130
                                  ENDIF
   10                           CONTINUE
                              ENDIF
                            ENDIF
   20                     CONTINUE
                        ENDIF
                      ENDIF
   30               CONTINUE
                    GOTO 130
                  ENDIF
                ENDIF
   40         CONTINUE
              GOTO 140
            ENDIF
          ENDIF
   50   CONTINUE
      ENDIF
      IF (IPR(17) .GE. 0) THEN
        NTOT = IPR(39) + IPR(24)
        DO 90 I = 1, NTOT
          CALL PLA050 (I, KAT, 0, 0, D)
          IF (D .LT. PAR(18)) THEN
            KAT = I
            IF (IPR(17) .GT. 0) THEN
              NCX  = IPR(79)
              KATX = KAT + IPR(20) * NP1
              DO 80 L = 1, NCX
                IF (KATX .EQ. IATC(L)) GOTO 140
   80         CONTINUE
            ENDIF
            GOTO 130
          ENDIF
   90   CONTINUE
        IF (IPR(17) .EQ. 0) THEN
          IF (IPR(98) + IPR(99) .GT. 0) THEN
            IF (DIJ + 2 * PAR(2) .LE. PAR(23))
     1         IDS = IPR(154) * IPR(48) * 1000 * IARU
          ENDIF
          GOTO 100
        ENDIF
      ENDIF
      IPR(24)  = IPR(24) + 1
      IAUX     = 1
      IFG(KAT) = IFG(JAT)
      JFG(KAT) = JFG(JAT)
      CALL GEN048 (1, IFG(KAT), 5, 1)
  100 NMOL = IPR(13)
      IF (IPR(26) .NE. 1555) THEN
        IF (IPR(62) .EQ. 0) IPR(62) = IPR(61)
        MOL(NMOL + 1) = IPR(26) * IARU + IPR(62) + IDS
        IF (NMOL .GT. 1) THEN
          DO 110 MM = 2, NMOL
            IF (MOL(MM) .EQ. MOL(NMOL + 1)) GOTO 120
            IF (MOL(MM) - IPR(48) * 1000 * IARU .EQ.
     1          MOL(NMOL + 1)) THEN
                  IPR(24) = IPR(24) - IAUX
                  GOTO 140
            ENDIF
            IF (MOL(MM) + IDS .EQ. MOL(NMOL + 1)) THEN
              MOL(MM) = MOL(NMOL + 1)
              GOTO 120
            ENDIF
  110     CONTINUE
        ENDIF
        IF (IPR(13) + 3 .LT. NP11) THEN
          IPR(13)       = IPR(13) + 1
          MM            = IPR(13)
          MLTI(IPR(62)) = MLTI(IPR(62)) + 1
        ELSE
          IPR(138)      = IPR(138) + 1
          IPR(24)       = IPR(24) - IAUX
          GOTO 140
        ENDIF
  120   IF (IPR(17) .NE. 0) THEN
          IF (MM .GT. IPR(463) - 1) THEN
            IPR(2) = 54
            GOTO  140
          ENDIF
          XLAB(KAT) = XLAB(JAT) + MM - 1
        ENDIF
      ENDIF
  130 IF (IPR(17) .EQ. 0) THEN
        IF (KAT .LE. IPR(37)) THEN
          CALL GEN048 (-1, IFG(IAT), 23, IDOA)
          CALL GEN048 (-1, IFG(KAT), 7,  IHA)
          IF (IDOA .EQ. 1 .AND. IHA .EQ. 1) THEN
            CALL GEN048 (1, IFG(IAT), 21, 1)
            CALL GEN048 (1, IFG(KAT), 20, 1)
          ENDIF
        ENDIF
      ELSE IF (IPR(17) .LT. 0) THEN
        CALL PLA057 (IAT, JAT, KAT)
        CALL GEN048 (-1, IFG(IAT), 7, IHA)
        IF (IHA .EQ. 1 .AND. IPR(63) .EQ. 1) THEN
          IF (KAT .LE. NAT) THEN
            IPR(24) = IPR(24) - IAUX
            IAUX    = 0
          ENDIF
          IF (DIJ .GT. (PAR(23) - PAR(1) + PAR(9))) THEN
            IPR(24) = IPR(24) - IAUX
            GOTO 140
          ENDIF
          KAT = KAT + NP1
          CALL PLA041 (1, IAT, IVAL, KAT)
        ELSE
          IPR(24) = IPR(24) - IAUX
        ENDIF
      ELSE
        IPR(79)       = IPR(79) + 1
        IATC(IPR(79)) = KAT + IPR(20) * NP1
        DATC(IPR(79)) = DIJ
        IF (IPR(79) .GE. NP1) THEN
          CALL GEN013 (DATC, IATC, 1, IPR(79))
          IPR(79)     = NP1 - 5
          PAR(23)     = DATC(IPR(79))
        ENDIF
      ENDIF
  140 RETURN
      END
      SUBROUTINE PLA072 (IAT)
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118,
     1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP22=256,
     2 NP25=99,NP29=63,NP38=125,NP39=30,NP41=200,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9),
     1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10),
     2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10),
     3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770)
      CHARACTER IMRK0*4, IMRK1*5, IMRK2*4, FORMA*71, FORMB*133, POLY*4,
     1 FORMC*96, FORMD*76, FORME*156, FORMK*6, CXMOL*9
      COMMON /PAGENM/ PAGET, PAGEIND(25)
      CHARACTER PAGET*8, PAGEIND*8
      COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0
      COMMON /CGGT/ IGGT
      CHARACTER IGGT*80
      CHARACTER NQ5*7
      DIMENSION YP(3, 12)
      IPR(440) = - IABS(IPR(440))
      DO 1 I = 1, 100
        YMOL(1, I) = -1000.0
    1 CONTINUE
    5 IMRK2  = ' '
      ANGLE  = 0.0
      SANGL  = 0.0
      DIJ    = 0.0
      SDIJ   = 0.0
      SOME   = 0.0
      ISANGL = 0
      NDEC   = 0
      NDEC1  = 0
      NDEC2  = 0
      ISANG  = 0
      INUM   = 0
      IDIS   = 0
      ISDIJ  = 0
      PSCL   = 0.0
      J2     = 0
      FORMA( 1: 31) = '(I2,F8.4,''('',I2,'')'', A,A,''['',A,'
      FORMA(32: 71) = '''='',A   ,''] '',A,2F7.2,1X,3F9.5,2X,3F8.4)'
      FORMB( 1:  4) = '(   '
      FORMB( 5: 33) = ' A , '', '', A ,F7.2,''('',I3,'')'''
      FORMB(34: 66) = ',4X,'//FORMB(5:33)
      FORMB(67:133) =  FORMB(34:66)//FORMB(34:66)//')'
      FORMC( 1: 45) = '(F4.1,'' Angstrom Coordination Sphere Around '''
      FORMC(46: 78) = ',''Atom I = '',A,''[ARU ='',F8.2,'']'','
      FORMC(79: 96) = '7X,3F9.5,2X,3F8.4)'
      FORMD( 1: 39) = '(A,'' , '',A,F8.2,''('',I3,'')'',5X,F8.4,''('','
      FORMD(40: 76) = 'I3,'')'',3X,4(F8.2,''('',I3,'')''),2(2X,A))'
      FORME( 1: 29) = '(''Dist. '',A,'' - Polyh_C.G.:'','
      FORME(30: 57) = 'F6.3,''('',I3,'') Ang,  C.G.:'','
      FORME(58: 73) = 'F9.5,''('',I2,'')'','
      FORME(74:108) = FORME(58:73)//FORME(58:73)//'5X,'
      FORME(109:124)= 'F9.4,''('',I2,'')'','
      FORME(125:156)= FORME(109:124)//FORME(109:123)//')'
      FORMK(1:6)    = '(F9.2)'
      IF (PAR(42) .LT. 100.0) THEN
        FORMK(5:5)   = '1'
        FORMC(73:73) = '1'
      ENDIF
      CALL PLA047 (XLAB(IAT), NQ3, MNX, IENI, 0, IGBL(55), 0,
     1     1 - IGBL(55))
      NC = IPR(79)
      IF (NC .EQ. 0) THEN
        IF (IPR(57) .EQ. 1) WRITE (LU6, 99996) PAR(262), NQ3
        GOTO 280
      ENDIF
      CALL GEN048 (-1, IFG(IAT), 23, IDOA)
      NMAX = IPR(39)
      KPC  = NMAX + IPR(24) + 1
      IF (KPC + NC .GT. NP1 - IPR(75)) THEN
        IPR(2) = 1
        GOTO 280
      ENDIF
      IF (IPR(15) .EQ. 0) THEN
        IF (IGBL(63) .GT. 2 .AND. IENI .NE. 2) THEN
          IF (IPR(57) .EQ. 0) THEN
            PAGET  = 'COORDN'
            CALL PLA269 (0)
            WRITE (LU7, 99990)
          ELSE IF (IPR(57) .LT. 0) THEN
            PAGET  = 'DSCAN'
            CALL PLA269 (0)
            WRITE (LU7, 99986) LMT(- IPR(57), 1)
          ELSE
            PAGET  = 'METAL'
            CALL PLA269 (0)
            WRITE (LU7, 99989)
          ENDIF
          WRITE (LU7, 99988)
        ENDIF
        IPR(15) = 1
      ENDIF
      VDWI = ABS(VDWR(IENI))
      CALL GEN048 (-6, IFG(IAT), 9, IRESI)
      CALL PLA036 (IAT, 1, 1, IDUM1, MNI, IDUM3, IPR(119), IGBL(55))
      NCI = 0
      NDB = 0
      DO 20 J = 1, NC
        KAT  = IATC(J)
        MKAT = MOD (KAT, NP1)
        IDUB = 0
        IF (J .GT. 1) THEN
          DO 10 K = 2, J
            IF (MKAT .EQ. MOD(IATC(K - 1), NP1)) THEN
              IDUB = 2
              NDB  = NDB + 1
            ENDIF
   10     CONTINUE
        ENDIF
        CALL GEN048 (-1, IFG(MKAT), 7, IHA)
        PADD = (IDUB + IHA + 1) * PAR(23)
        IF (KAT .LE. NP1) THEN
          CALL PLA041 (-1, IAT, JJ, KAT)
          IF (JJ .GT. 0) THEN
            NCI  = NCI + 1
            PADD = 0
          ENDIF
        ENDIF
        DATC(J) = PADD + DATC(J)
   20 CONTINUE
      CALL GEN013 (DATC, IATC, 1, NC)
      NC = NC - NDB
      XMOL1 = (1555 * PAR(42) + IRESI) / PAR(42)
      IF (IGBL(63) .GT. 2 .AND. IENI .NE. 2) THEN
        CALL PLA269 (-4)
        IF (IGBL(121) .NE. 0 .AND. IPR(44) .EQ. 0)
     1      CALL PLA096 (0, NAMS(1, 1)(2:8), 0.0, PAR(454))
        WRITE (PRBUF, FORMC) PAR(23), NAMS(1, 1)(2:8), XMOL1,
     1                    (XXO(IAT, L), L = 1, 6)
        CALL PLA067 (LU7, PRBUF, 132, 1, 10)
        WRITE (LU7, 99981)
        WRITE (LU7, 99987)
      ENDIF
      IF (IPR(168) .NE. 0 .OR. IPR(170) .NE. 0) THEN
        WRITE (PRBUF, 99980) PAR(23), NAMS(1, 1)(2:8)
        WRITE (LU6, 99977) PRBUF(1:46)
        IWIN = 0
        IF (IGBL(25) * IGBL(32) .EQ. 1 .AND. IPR(121) .EQ. 0) THEN
          IWIN = 1
          CALL GGIP (HORS, VERT, 0.0, 1)
          VRT = VERT - 0.6
          CALL GGIP20 (0.0, PRBUF, 80, 0.35, 5 + IGBL(68), 2, 1.0, VRT)
          VRT  = VRT - 0.1
          PXOR = 0.80 * HORS
          PYOR = 0.72 * VERT
          PSCL = 0.22 * HORS / PAR(23)
        ENDIF
      ENDIF
      IF (IGBL(31) .EQ. 3) THEN
        WRITE (LU2, 99993)
        WRITE (LU2, 99995) NQ3(1:6)
        WRITE (LU2, 99994) NQ3(1:6),
     1        (XXO(IAT, L), L = 4, 6), (XSD(IAT, L), L = 4, 6)
      ENDIF
      DMAX = 0
      DO 60 J = 1, NC
        ICOL    = 1
        KAT     = IATC(J)
        IPR(20) = 0
        IF (KAT .GT. NP1) THEN
          KAT     = KAT - NP1
          IATC(J) = KAT
          IPR(20) = 1
        ENDIF
        CALL GEN048 (-6, IFG(KAT), 9, IRESJ)
        CALL PLA036 (KAT, 1, 2, IDUM1, MNJ, IDUM3, IPR(119), IGBL(55))
        IF (MNJ .GT. 1) THEN
          MOLMNJ = MOL(MNJ)
        ELSE
          MOLMNJ = NINT(1555 * PAR(42) + IRESJ)
        ENDIF
        XMOL = MOLMNJ / PAR(42)
        IF (ABS(XMOL1 - XMOL) .LT. 0.005) IPR(20) = 0
        CALL GEN048 (-1, IFG(KAT), 23, KDOA)
        XLABX = - XLAB(KAT)
        CALL PLA047 (XLABX, NQ4, MNY, IENK, IPR(119), IGBL(55), 0,
     1               1 - IGBL(55))
        NQ5 = NQ4
        CALL PLA046 (2, NQ4, IDUM, LBB, LBC, LBD, XLMP, YNQNR, KATP)
        CALL PLA047 (XLAB(KAT), NQ3, MNY, IENK, IPR(119), IGBL(55),
     1               0, 1 - IGBL(55))
        VDWIK = ABS(VDWR(IENK)) + VDWI
        CALL PLA053 (IAT, KAT, 0, 0, DIJ, SDIJ, ISDIJ, NDEC, IER)
        IF (IER .NE. 0) GOTO 60
        IF (DIJ .LT. DMAX .AND. IGBL(63) .GT. 2
     1                    .AND. IENI .NE. 2) THEN
          CALL PLA269 (1)
          WRITE (LU7, 99999)
        ENDIF
        IF (J .GT. NCI) THEN
          DELTA = DIJ - VDWIK
          IF (DELTA .GT. 0.0) THEN
            IMRK0 = ' .. '
            ICOL  = 3
          ELSE
            IF (DELTA .LT. - 0.2) THEN
              IMRK0 = ' << '
              ICOL  = 2
            ELSE
              IMRK0 = ' .< '
              ICOL  = 6
            ENDIF
            IF (IPR(20) .NE. 0 .AND. IAT .LE. KATP) THEN
              CALL GEN048 (-1, IFG(IAT), 19, IMET)
              CALL GEN048 (-1, IFG(KAT), 19, KMET)
              CALL GEN048 (-7, JFG(KAT),  1, KPP)
              IF (IRESI .NE. IRESJ .OR. IPR(322) .EQ. 0) THEN
                IF (IDOA + KDOA .EQ. 2) THEN
                  CALL GEN048 (-1, IFG(IAT), 21, IDO)
                  CALL GEN048 (-1, IFG(KAT), 21, KDO)
                  IF (IMET + KMET .EQ. 0) THEN
                    IF (IATPR(IENI) .NE. -7 .AND.
     1                  IATPR(IENK) .NE. -7 .AND. DIJ .LT. 2.9) THEN
                      IF (IDO + KDO .EQ. 0) THEN
                        WRITE (LU20, 99978) '_430',
     1                    - DELTA, DIJ, NAMS(1, 1)(2:8), NQ5(1:7)
                      ENDIF
                    ELSE IF (IATPR(IENI) .EQ. -7) THEN
                      IF (KDO .EQ. 0) THEN
                        DIJT = 10.0
                        IF (IENI .EQ. 38 .AND. IENK .EQ. 38) DIJT = 2.6
                        IF (IENI .EQ. 5  .AND. IENK .EQ. 5)  DIJT = 3.15
                        IF (DIJ .LT. DIJT) THEN
                          WRITE (LU20, 99978) '_431',
     1                    - DELTA, DIJ, NAMS(1, 1)(2:8), NQ5(1:7)
                        ENDIF
                      ENDIF
                    ENDIF
                  ENDIF
                ELSE
                  CALL GEN048 (-1, IFG(IAT), 7, IHAT)
                  CALL GEN048 (-1, IFG(KAT), 7, KHAT)
                  IF (IHAT + KHAT + IMET + KMET .EQ. 0) THEN
                    IF (IPR(127) .GT. 150 .OR. IPR(120) .GT. 150) THEN
                      N = 432
                    ELSE
                      N = 433
                    ENDIF
                    WRITE (LU20, 99984) '_', N,
     1                - DELTA, DIJ, NAMS(1, 1)(2:8), NQ5(1:7)
                  ENDIF
                ENDIF
              ENDIF
            ENDIF
          ENDIF
        ELSE
          IMRK0 = ' -- '
        ENDIF
        DMAX = DIJ
        ISDIJ = MIN (99, ISDIJ)
        FORMA(8 : 8) = CHAR(ICHAR('0') + NDEC)
        CALL PLA050 (IAT, KAT, 0, 0, DIJN)
        DO 30 JJ = 4, 6
          XXO(KPC, JJ) = (XXO(KAT, JJ) - XXO(IAT, JJ)) / DIJN
          XSD(KPC, JJ) = XSD(IAT, JJ)
   30   CONTINUE
        DO 40 JJ = 4, 6
          XXO(KPC + J, JJ) = XXO(IAT, JJ) + XXO(KPC, JJ)
          XSD(KPC + J, JJ) = XSD(IAT, JJ)
   40   CONTINUE
        XLAB(KPC + J) = XLAB(KAT)
        JATC(J) = IATC(J)
        IF (ABS(XXO(KPC, 6)) .LT. 0.999) THEN
          XMU = 90.0 - GL(5) * ACOS(XXO(KPC, 6))
          PHI = GL(5) * ATAN2(XXO(KPC, 5), XXO(KPC, 4))
        ELSE
          XMU = SIGN(90.0, XXO(KPC, 6))
          PHI = 0.0
        ENDIF
        IF (IPR(20) .EQ. 0) THEN
          IMRK1 = 'Intra'
        ELSE
          IMRK1 = '     '
        ENDIF
        CALL GEN098 (MOLMNJ, PAR(42), MOL0, MOL1, MOL2, MOL3, IDUM)
        XJX(4) = MOL1
        XJX(5) = MOL2
        XJX(6) = MOL3
        CALL SGSM (IDM, MOL0, XJX, 0, 20, IERR)
        CALL GEN020 (-1, IDM, 1, 20)
        IF (IDM(1 : 6) .EQ. 'x,y,z ') IDM(1:5) = '     '
        WRITE (CXMOL, FORMK) XMOL
        IF (XMOL .EQ. XMOL1) CXMOL = '         '
        IF (INT(XMOL) .EQ. 1555) CXMOL(1:7) = '       '
        IF (IMRK2 .NE. IMRK0) THEN
          VRT = VRT - 0.2
          IMRK2 = IMRK0
        ENDIF
        JPR = MIN (J, 99)
        IF (IGBL(121) .NE. 0 .AND. IPR(44) .EQ. 0)
     1      CALL PLA096 (1, NAMS(1, 2)(2:8), DIJ, PAR(454))
        WRITE (PRBUF, FORMA) JPR, DIJ, ISDIJ, IMRK0, NAMS(1, 2),
     1    IDM(1:20), CXMOL, IMRK1, PHI, XMU, (XXO(KAT, L), L = 1, 6)
        IF (IGBL(63) .GT. 2 .AND. IENI .NE. 2) THEN
          CALL PLA067 (LU7, PRBUF, 132, 1, 3)
          IF (J .EQ. NCI .AND. NCI .GT. 0 .AND. NC .GT. NCI) THEN
            CALL PLA269 (1)
            WRITE (LU7, 99999)
          ENDIF
        ENDIF
        IF (IPR(168) .NE. 0 .OR. IPR(170) .NE. 0) THEN
          CALL PLA067 (LU6, PRBUF, 58, 1, 3)
          IF (IWIN .EQ. 1) THEN
            VRT = VRT - 0.5
            YMOL(1, JPR) = VRT + 0.175
            YMOL(2, JPR) = XMOL
            IF (ICOL .EQ. 2) THEN
              NRLN = 2 + KDOA
            ELSE
              NRLN = 2
            ENDIF
            LINE = PRBUF(1:26)//' '//PRBUF(49:57)//' = '//PRBUF(28:47)
            CALL GGIP20 (0.0, LINE, 59, 0.35, ICOL, NRLN, 0.1, VRT)
            DO 50 L = 1, 3
              V1(L) = (XXO(KAT, L + 3) - XXO(IAT, L + 3)) * PSCL
   50       CONTINUE
            CALL GEN002 (-1, RMAT, V1, V2, YUNK)
            IF (ICOL .NE. 3) THEN
              CALL GGIP20 (0.0, PRBUF, 2, 0.4, ICOL, NRLN,
     1             PXOR + V2(1) - 0.4, PYOR + V2(2) - 0.20)
              IF (V2(3) .GE. 0) THEN
                ICOL0 = 3
              ELSE
                ICOL0 = 4
              ENDIF
              CALL GGIP (0.0, FLOAT(ICOL0), 0.0, 0)
              CALL GGIP (PXOR, PYOR, 0.0, 3)
              QXOR = PXOR + V2(1) * 0.9
              QYOR = PYOR + V2(2) * 0.9
              CALL GGIP (QXOR, QYOR, 0.0, 2)
            ENDIF
          ENDIF
        ENDIF
        IF (IGBL(31) .EQ. 3) WRITE (LU2, 99994) NQ3(1:6),
     1   (XXO(KAT, L), L = 4, 6), (XSD(KAT, L), L = 4, 6)
   60 CONTINUE
      IF (IGBL(121) .NE. 0 .AND. IPR(44) .EQ. 0)
     1    CALL PLA096 (-1, ' ', 0.0, PAR(454))
      IF (IGBL(31) .EQ. 3) WRITE (LU2, 99993)
      IF (IGBL(63) .GT. 2 .AND. IENI .NE. 2) THEN
        IF (NCI .GE. 4 .AND. NCI .LE. 12) THEN
          DO 80 J = 1, NCI
            DO 70 K = 1, 3
              YP(K, J) = XXO(IATC(J), K + 3) - XXO(IAT, K + 3)
   70       CONTINUE
   80     CONTINUE
          CALL PLA278 (NCI, YP, LU7)
        ENDIF
      ENDIF
      IF (IPR(7) .EQ. 0) GOTO 280
      IF (IPR(122) .LT. 0) IPR(122) = 0
      IF (IPR(122) .EQ. 0 .AND. NCI .EQ. 5 .AND. IPR(7) .GT. 0)
     1    IPR(122) = -5
      IF (IGBL(63) .GT. 2 .AND. IENI .NE. 2) THEN
        CALL PLA269 (3)
        WRITE (LU7, 99998) NAMS(1, 1)(1:7)
      ENDIF
      KB = 0
      NN = NC - 1
      DO 100 J1 = 1, NN
        JB1 = JATC(J1)
        CALL GEN048 (-1, IFG(JB1), 7, IVL)
        IF (IVL .EQ. 0 .OR. IPR(521) .NE. 0) THEN
          MM  = MAX (J1, IABS(IPR(122))) + 1
          DO 90 J2 = MM, NC
            JB2 = JATC(J2)
            CALL GEN048 (-1, IFG(JB2), 7, IVL)
            IF (IVL .EQ. 0 .OR. IPR(521) .NE. 0) THEN
              CALL PLA053 (JB1, IAT, JB2, 0, ANGLE, SANGL, ISANGL,
     1                     NDEC, IER)
              IF (IER .NE. 0) GOTO 90
              KB  = KB + 1
              CALL PLA036 (JB1, KB, 2, IDUM1, IDUM2, IDUM3, IPR(119),
     1                     IGBL(55))
              CALL PLA036 (JB2, KB, 3, IDUM1, IDUM2, IDUM3, IPR(119),
     1                     IGBL(55))
              DBUF(KB)  = ANGLE
              IDBUF(KB) = MIN (999, ISANGL)
              IFT       = -11 + KB * 33
              FORMB(IFT : IFT) = CHAR(ICHAR('0') + NDEC)
              IF (KB .GE. 4) THEN
                IF (IGBL(63) .GT. 2 .AND. IENI .NE. 2) THEN
                  WRITE (PRBUF, FORMB) ((NAMS(L, M),
     1              M = 2, 3), DBUF(L), IDBUF(L), L = 1, KB)
                  CALL PLA067 (LU7, PRBUF, 132, 1, 1)
                ENDIF
                KB = 0
              ENDIF
            ENDIF
   90     CONTINUE
        ENDIF
  100 CONTINUE
      IF (KB .GT. 0 .AND. IGBL(63) .GT. 2 .AND. IENI .NE. 2) THEN
        WRITE (PRBUF, FORMB) ((NAMS(L, M), M = 2, 3),
     1          DBUF(L), IDBUF(L), L = 1, KB)
        CALL PLA067 (LU7, PRBUF, 132, 1, 1)
      ENDIF
      NC = MIN (NC, IABS(IPR(122)))
      IF (NC .EQ. 0 .OR. NC .LT. IABS(IPR(122))) GOTO 280
      DO 110 I = 1, NMAX
        IATP(I) = I + 2 * NP1
  110 CONTINUE
      DO 120 I = 1, 5
        IATP(JATC(I)) = JATC(I)
  120 CONTINUE
      IATP(IAT) = IAT + NP1
      NANG = 0
      ANG1 = 0.0
      ANG2 = 0.0
      DO 130 JJ = 1, 6
        XXO(KPC, JJ) = 0.0
        XSD(KPC, JJ) = 0.0
  130 CONTINUE
      DO 150 II = 1, NC
        IP = IATC(II)
        DO 140 JJ = 1, 3
          XXO(KPC, JJ)     = XXO(KPC, JJ)     + XXO(IP, JJ)
          XXO(KPC, JJ + 3) = XXO(KPC, JJ + 3) + XXO(IP, JJ + 3)
          XSD(KPC, JJ)     = XSD(KPC, JJ)     + XSD(IP, JJ)
          XSD(KPC, JJ + 3) = XSD(KPC, JJ + 3) + XSD(IP, JJ + 3)
  140   CONTINUE
        DATC(II) = 0.0
        IF (IPR(125) .EQ. 1 .AND. IABS(IPR(122)) .GT. 0)
     1      IATC(II) = KPC + II
  150 CONTINUE
      DO 160 JJ = 1, 3
        XXO(KPC, JJ)     = XXO(KPC, JJ) / NC
        XXO(KPC, JJ + 3) = XXO(KPC, JJ + 3) / NC
        XSD(KPC, JJ)     = XSD(KPC, JJ)     / (NC**2)
        XSD(KPC, JJ + 3) = XSD(KPC, JJ + 3) / (NC**2)
  160 CONTINUE
      CALL PLA269 (2)
      IF (IPR(125) .EQ. 0) THEN
        POLY = 'Real'
      ELSE
        POLY = 'Unit'
      ENDIF
      CALL PLA053 (IAT, KPC, 0, 0, DBUF(1), SDIJ, IDIS, INUM, IER)
      IF (IER .EQ. 0) THEN
        IF (IGBL(63) .GT. 2 .AND. IENI .NE. 2) THEN
          CALL PLA269 (3)
          IDBUF(1) = MIN (999, IDIS)
          FORME(33:33) = CHAR(ICHAR('0') + INUM)
          IFT0 = 45
          DO 170 JJ = 1, 6
            IF (JJ .EQ. 4) IFT0 = 48
            XSIG = SQRT(XSD(KPC, JJ))
            CALL GEN041 (XXO(KPC, JJ), XSIG, IDBUF(JJ + 1), IPR(183),
     1                   NDEC, IPR(68))
            XSD(KPC, JJ)  = XSIG ** 2
            DBUF(JJ + 1)  = XXO(KPC, JJ)
            IDBUF(JJ + 1) = MIN (99, IDBUF(JJ + 1))
            IFT           = IFT0 + JJ * 16
            FORME(IFT:IFT) = CHAR(ICHAR('0') + NDEC)
  170     CONTINUE
          WRITE (LU7, '(1X)')
          WRITE (PRBUF, FORME) NAMS(1, 1)(2:7),
     1       (DBUF(JJ), IDBUF(JJ), JJ = 1, 7)
          CALL PLA067 (LU7, PRBUF, 132, 1, 3)
          WRITE (LU7, 99985) NAMS(1, 1)(1:7), POLY
        ENDIF
      ENDIF
      NN = NC - 1
      DO 230 J1 = 1, NN
        JB1 = IATC(J1)
        IF (JB1 .GT. KPC) THEN
          IB1 = JATC(JB1 - KPC)
        ELSE
          IB1 = JB1
        ENDIF
        MM = J1 + 1
        DO 220 J2 = MM, NC
          JB2 = IATC(J2)
          IF (JB2 .GT. KPC) THEN
            IB2 = JATC(JB2 - KPC)
          ELSE
            IB2 = JB2
          ENDIF
          IF (NC .EQ. IABS(IPR(122))) THEN
            ANG = 0.0
            JX  = 0
            JY  = 0
            DO 190 J3 = 1, NC
              IF (J3 .NE. J1 .AND. J3 .NE. J2) THEN
                JB3 = IATC(J3)
                DO 180 J4 = 1, NC
                  IF (J4 .NE. J1 .AND. J4 .NE. J2 .AND. J4 .NE. J3) THEN
                    JB4 = IATC(J4)
                    CALL PLA050 (JB3, JB1, JB2, JB4, OME)
                    IF (ABS(OME) .GT. ANG) THEN
                      JX  = JB3
                      JY  = JB4
                      ANG = ABS(OME)
                    ENDIF
                  ENDIF
  180           CONTINUE
              ENDIF
  190       CONTINUE
            IF (JX .EQ. 0 .OR. JY .EQ. 0) THEN
              WRITE (LU6, 99982)
              GOTO 280
            ENDIF
            DO 200 II = 1, NC
              JZ = IATC(II)
              IF (JZ .NE. JB1 .AND. JZ .NE. JB2 .AND.
     1            JZ .NE. JX .AND. JZ .NE. JY) GOTO 210
  200       CONTINUE
  210       CALL PLA053 (JX, JB1, JB2, JY, DBUF(3), SOME, IDUM1,
     1                  IDUM2, IER)
            IF (IER .NE. 0) GOTO 220
            IDBUF(3) = MIN (999, NINT(SOME * 100.0))
            CALL PLA053 (JX, JB1, JB2, JZ, DBUF(4), SOME, IDUM1,
     1                   IDUM2, IER)
            IF (IER .NE. 0) GOTO 220
            IDBUF(4) = MIN (999, NINT(SOME * 100.0))
            CALL PLA053 (JZ, JB1, JB2, JY, DBUF(5), SOME, IDUM1,
     1                   IDUM2, IER)
            IF (IER .NE. 0) GOTO 220
            IDBUF(5) = MIN (999, NINT(SOME * 100.0))
            DBUF(6)  = 180.0 - ABS(DBUF(4) + DBUF(5))
            IDBUF(6) = (IDBUF(4) + IDBUF(5))/2
            IF (DBUF(6) .GT. 0) THEN
              NANG         = NANG + 1
              KBO(NANG, 1) = JB1
              KBO(NANG, 2) = JB2
              BOK(NANG, 1) = DBUF(6)
              DATC(J1)     = DATC(J1) + 1
              DATC(J2)     = DATC(J2) + 1
            ENDIF
          ENDIF
          CALL PLA053 (IB1, IAT, IB2, 0, DBUF(1), SANGL, ISANG,
     1                 NDEC1, IER)
          IF (IER .NE. 0) GOTO 220
          CALL PLA053 (IB1, IB2,   0, 0, DBUF(2),  SDIJ, IDIS,
     1                 NDEC2, IER)
          IF (IER .NE. 0) GOTO 220
          IDBUF(1) = MIN (999, ISANG)
          IDBUF(2) = MIN (999, IDIS)
          FORMD(15 : 15) = CHAR(ICHAR('0') + NDEC1)
          FORMD(34 : 34) = CHAR(ICHAR('0') + NDEC2)
          CALL PLA036 (IB1, 1, 1, IDIS1, IDUM1, IDUM2, IPR(119),
     1                 IGBL(55))
          CALL PLA036 (IB2, 1, 2, IDIS2, IDUM1, IDUM2, IPR(119),
     1                 IGBL(55))
          CALL PLA047 (XLAB(JX), NQ2, IDUM, JDUM, IPR(119), IGBL(55),
     1                 0, 1 - IGBL(55))
          CALL PLA047 (XLAB(JY), NQ3, IDUM, JDUM, IPR(119), IGBL(55),
     1                 0, 1 - IGBL(55))
          IF (DBUF(1) .GT. ANG1) THEN
            ANG2 = ANG1
            ANG1 = DBUF(1)
          ELSE IF (DBUF(1) .GT. ANG2) THEN
            ANG2 = DBUF(1)
          ENDIF
          IF (IGBL(63) .GT. 2 .AND. IENI .NE. 2) THEN
            WRITE (PRBUF, FORMD) (NAMS(1, M)(1:7), M = 1, 2),
     1       (DBUF(L), IDBUF(L), L = 1, 6), NQ2, NQ3
            CALL PLA067 (LU7, PRBUF, 132, 1, 3)
          ENDIF
  220   CONTINUE
  230 CONTINUE
      IF (IPR(122) .NE. 0) THEN
        IF (NC .EQ. 5) THEN
          IF (PAR(35) .GT. 0.0) THEN
            TBA = PAR(35)
          ELSE IF (IENI .EQ. 103) THEN
            TBA = 158
          ELSE
            TBA  = PAR(31)
          ENDIF
          PHC  = COS(TBA / (2 * GL(5)))
          PHS  = SIN(TBA / (2 * GL(5)))
          SPA1 = 180.0 - GL(5) * ATAN((1.0 + PHC) * SQRT(2.0) / PHS)
          SPA2 = 180.0 - 2.0 * GL(5) * ATAN(SQRT(2.0 / (1.0 + PHC)))
          TPA1 = 180.0 - 2.0 * GL(5) * ATAN(2.0 / SQRT(6.0))
          TPA2 = 180.0 - 2.0 * GL(5) * ATAN(2.0)
          DTP  = 4.0 * ABS(TPA1 - SPA1) + 2.0 * ABS(TPA1 - SPA2) +
     1     2.0 * ABS(TPA2 - SPA2) + TPA2
          IF (IGBL(63) .GT. 2 .AND. IENI .NE. 2) THEN
            CALL PLA269 (4)
            WRITE (LU7, 99979) ANG1, ANG2, (ANG1 - ANG2) / 60.0
            CALL PLA269 (8)
            WRITE (LU7, 99983) TBA, TPA1, TPA2, SPA1, SPA2, DTP
          ENDIF
          CALL GEN013 (DATC, IATC, 1, NC)
          CALL GEN013 (DATC, JATC, 1, NC)
          STP1 = 0.0
          SSP1 = 0.0
          SSP2 = 0.0
          SSP3 = 0.0
          DO 250 II = 1, NANG
            JB1 = KBO(II, 1)
            JB2 = KBO(II, 2)
            ANG = BOK(II, 1)
            DO 240 JJ = 1, NC
              IF (IATC(JJ) .EQ. JB1) J1 = JJ
              IF (IATC(JJ) .EQ. JB2) J2 = JJ
  240       CONTINUE
            IF (J1 .GT. J2) THEN
              J0 = J1
              J1 = J2
              J2 = J0
            ENDIF
            IF (J1 .GT. 2) THEN
              TP1 = TPA2
            ELSE
              TP1 = TPA1
            ENDIF
            STP1 = STP1 + ABS(TP1 - ANG)
            SP1  = SPA1
            SP2  = SPA1
            SP3  = SPA1
            IF (J1 .EQ. 4 .AND. J2 .EQ. 5) SP1 = 0.0
            IF (J1 .EQ. 3 .AND. J2 .EQ. 5) SP2 = 0.0
            IF (J1 .EQ. 3 .AND. J2 .EQ. 4) SP3 = 0.0
            IF (J1 .EQ. 3 .OR.  J2 .EQ. 3) SP1 = SPA2
            IF (J1 .EQ. 4 .OR.  J2 .EQ. 4) SP2 = SPA2
            IF (J1 .EQ. 5 .OR.  J2 .EQ. 5) SP3 = SPA2
            SSP1 = SSP1 + ABS(SP1 - ANG)
            SSP2 = SSP2 + ABS(SP2 - ANG)
            SSP3 = SSP3 + ABS(SP3 - ANG)
  250     CONTINUE
          QSP1 = DTP - SSP1
          QSP2 = DTP - SSP2
          QSP3 = DTP - SSP3
          CALL PLA047 (XLAB(IATC(3)), NQ1, IDUM, JDUM, IPR(119),
     1                 IGBL(55), 0, 1 - IGBL(55))
          CALL PLA047 (XLAB(IATC(4)), NQ2, IDUM, JDUM, IPR(119),
     1                 IGBL(55), 0, 1 - IGBL(55))
          CALL PLA047 (XLAB(IATC(5)), NQ3, IDUM, JDUM, IPR(119),
     1                 IGBL(55), 0, 1 - IGBL(55))
          CALL PLA050 (IATC(4), IAT, IATC(5), 0, TH11)
          CALL PLA050 (IATC(3), IAT, IATC(5), 0, TH21)
          CALL PLA050 (IATC(3), IAT, IATC(4), 0, TH31)
          CALL PLA050 (IATC(1), IAT, IATC(2), 0, TH00)
          CALL PLA050 (IATC(1), IATC(4), IATC(5), IATC(2), OME)
          DLP1 = 180.0 - ABS(OME)
          CALL PLA050 (IATC(1), IATC(3), IATC(5), IATC(2), OME)
          DLP2 = 180.0 - ABS(OME)
          CALL PLA050 (IATC(1), IATC(3), IATC(4), IATC(2), OME)
          DLP3 = 180.0 - ABS(OME)
          CALL PLA269 (6)
          BDIF = STP1 - QSP1
          IF (IGBL(63) .GT. 2 .AND. IENI .NE. 2) THEN
            WRITE (LU7, 99991)  DTP, NQ1, STP1, SSP1, QSP1, DLP1, TH11,
     2       TH00, NQ2, STP1, SSP2, QSP2, DLP2, TH21, TH00, NQ3, STP1,
     3       SSP3, QSP3, DLP3, TH31, TH00
          ENDIF
          IF (STP1 - QSP2 .LT. BDIF) THEN
            NQ1   = NQ2
            QSP1  = QSP2
            BDIF  = STP1 - QSP1
          ENDIF
          IF (STP1 - QSP3 .LT. BDIF) THEN
            NQ1   = NQ3
            QSP1  = QSP3
            BDIF  = STP1 - QSP3
          ENDIF
          BAVER = (STP1 + QSP1) / 2.0
          PSTP1 = BAVER * 100.0 / DTP
          DO 260 JATCI = 1, 5
            CALL PLA047 (XLAB(JATC(JATCI)), NQ2, IDUM, JDUM, IPR(119),
     1                   IGBL(55), 0, 1 - IGBL(55))
            IF (NQ2(1:6) .EQ. NQ1(1:6)) THEN
              IATP(JATC(JATCI)) = JATC(JATCI) + NP1
            ENDIF
  260     CONTINUE
          IF (IGBL(63) .GT. 2 .AND. IENI .NE. 2) THEN
            CALL PLA269 (7)
            WRITE (LU7, 99992) PSTP1, '>', '>', NQ1(1:6),
     1             BAVER, BDIF
          ENDIF
        ENDIF
        IF (PSTP1 .GT. 50) THEN
          IPR(12) = 4
          CALL GEN022 (IATP, 1, NMAX)
          CALL PLA055
          SGN = 1
          DO 270 I = 1, 6
            IATPI = MOD(IATP(I), NP1)
            CALL PLA036 (IATPI, I, 1, IDUM1, IDUM2, IDUM3, IPR(119),
     1                   IGBL(55))
            CALL PLA056 (XPV(1), IATPI, DEV(I), SDV(I), IDUM1,
     1                   5, IDUM2)
            ISDV(I) = MIN (999, NINT(SDV(I) * 10000.0))
  270     CONTINUE
          IF (DEV(4) .LT. 0.0) SGN = -1.0
          IF (IGBL(63) .GT. 2 .AND. IENI .NE. 2) THEN
            CALL PLA269 (3)
            WRITE (LU7, 99997) (NAMS(I, 1)(2:8), I = 1, 4),
     1       (NAMS(I, 1)(2:8), DEV(I) * SGN, ISDV(I), I = 1, 6)
          ENDIF
        ENDIF
      ENDIF
  280 IF (IWIN .EQ. 1) THEN
        IF (IABS(IGBL(23)) .EQ. 1) THEN
          CALL PLA015 (0, 45)
        ENDIF
        CALL PLA297 (2)
        IF (IGGT(1:4) .EQ. 'CALC') GOTO 5
      ENDIF
      IPR(440) = IABS(IPR(440))
      RETURN
99999 FORMAT (1X)
99998 FORMAT (/, 'Angles (Degrees)  At1...V...At2 with Vertex V = ',
     1  A, /, 132('-'))
99997 FORMAT (/, '>> Distance to SP square base plane defined by:',
     1  4(1X, A), /, 1X, 6(1X, A, F8.4, '(', I3, '),'), 'Ang.')
99996 FORMAT (':: No Metal-Metal Distances within ', F5.1,
     1        ' Ang. for ', A)
99995 FORMAT ('TITL ', A, ' - COORDINATION')
99994 FORMAT ('ATOM ', A, 6F8.4)
99993 FORMAT ('ENDS')
99992 FORMAT (/, 'Trigonal Bipyramid (TP) to Square Pyramid (SP)',
     1 ' ::: Perc. Along Berry Pseudorotation Coordinate:', F6.1, 3X,
     2 ':::  D3h  ---', A, ' C2v ---', A, ' C4v', //, 'NOTE: This',
     3 ' Analysis Depends on the Value of the Trans Basal Angle that',
     4 ' is used (Default Value = 150 Deg.).', /, 6X, 'The Pivot Atom',
     5 ' that Best Describes a Berry Pseudo Rotation is: ', A, /, 5X,
     6 ' The Percentage has been Calculated for the Average value,',
     7 F7.1, ' Deg., of the Second and Fourth Table Entry.', /, 5X,
     8 ' The Difference,', F7.1, ' Deg., Between the Second and',
     9 ' Fourth Table Entry (for pivot) should be Zero for a True',
     * ' Berry Rotation.')
99991 FORMAT (/, 'Pivot(3)', 4X, 'Sum(/Del:C - Del:TP/)', 8X, 'Sum(',
     1 '/Del:C - Del:SP/)', 8X, F5.1, ' - Sum(/Del:C - Del:SP/)', 5X,
     2 'Del(24)   Th(24)   Th(15)', /, 132('-'), 3(/, 1X, A, 8X,
     3 3(F8.1, ' Deg.', 16X), 3F9.2))
99990 FORMAT ('Analysis of the Coordination Geometry')
99989 FORMAT ('Analysis of Metal-Metal Geometry')
99988 FORMAT (132('-'), //, 'Distances are calculated from atom I',
     1 ' of Unique Molecule Coordinate List to atom J in Asymmetric',
     2 ' Residue Unit: ARU.', //, 'Phi = Azimuth angle(counter',
     3 ' clockwise from XO in XO,YO-Plane), Mu  = Angle between D and',
     4 ' XO,YO-plane.', //, '''To-Code'' : ''--'' = Bonded atoms, ',
     5 ' ''<<'' = .LT. sum vdW-radii - 0.2, ''.<'' = .LT. sum vdW',
     6 '-radii, ''..'' = .GT. sum vdW-radii.', //,
     7 '>>>> NOTICE >>>> : The Symmetry Code',
     8 ' Character Added to the Atom Label Applies to the Current',
     9 ' Coordination Sphere Only.', /,
     * '>>>>>>>>>>>>>>>> : Symmetry operations refer to the',
     1 ' coordinates listed in the fractional coordinate table',
     2 ' given above', //, 19X, 'The List May be',
     * ' Limited to the Shortest Distances.')
99987 FORMAT (1X, 'Nr     d(I,J) To  Atom J  Symm_Oper. on Atom',
     3  ' J', 4X, 'ARU(J)  Type', 5X, 'Phi', 5X, 'Mu', 9X, 'X', 8X,
     4 'Y', 8X, 'Z', 8X, 'XO', 6X, 'YO', 6X, 'ZO', /, 132('-'))
99986 FORMAT ('Distance Scan for Element ', A)
99985 FORMAT (/, 'Real Angles I - ', A, ' - J', 8X, 'Real Edge I - J',
     1 5X, A4, ' Polyhedron Dihedral Angles', 5X, 'Norm. IJK:IJL', 2X,
     2 'K', 8X, 'L', /, 132('-'))
99984 FORMAT (A, I3, 2F10.2, 2A)
99983 FORMAT (//, 'Analysis of Five-Coordination (See R.R. Holmes in ',
     1 'Progress in Inorg. Chem. Vol. 32 (1984),119-235 and References',
     2 ' Therein)', /, 132('-'), /, 'Idealized Dihedral Angles for',
     3 ' Trans Basal Angle  :', F6.1, /8X, 'Del(13) & Del(23) Trigonal',
     4 ' Bipyramid (TP):', 2F6.1, /, 12X, 'Del(12) & Del(13) Square',
     5 ' Pyramid (SP):', 2F6.1, /, 'Distance Between TP and SP Along',
     6 ' Berry Coordinate:', F6.1)
99982 FORMAT (/, ':: Coordination Analysis Aborted !', //)
99981 FORMAT (132('-'))
99980 FORMAT (F5.1, ' Ang. Coordination Sphere Around ', A,
     1  2X, 'Green = Above, Blue = Below Plane')
99979 FORMAT (/, 'Tau-Descriptor for 5-Coordination (A.W.Addison,T.N.',
     1 'Rao,J.Reedijk,J.van Rijn,G.C.Verschoor, J.Chem.Soc.Dalton ',
     2 'Trans.(1984),1349-1356)', /, 132('-'), /,
     3 'Tau = (Beta - Alpha) / 60 = (', F6.2, '-', F6.2, ') / 60 =',
     4 F5.2, '  :  (Extreme forms: Tau = 0.00 for SP and 1.00 for TP)')
99978 FORMAT (A, 2F10.2, 2A)
99977 FORMAT (/, A, /)
      END
      SUBROUTINE PLA073 (NSMPR)
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118,
     1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NPVD=40000000,
     2 NP22=256,NP23=18000,NP25=99,NP29=63,NP38=125,NP39=30,NP41=200,
     3 NP45=2048,NP47=9,NMA=550)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /Q/ ICL, IFL(NP17)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9),
     1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10),
     2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10),
     3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770)
      COMMON // JNSC(2, NP23), VOID(NPVD)
      COMMON /FORMT/ FORM
      CHARACTER ICH*1, JCH*1, CHYB*3, FORM*109, FORMA*82, NRND*4,
     1 KTYPE*3, ISORD*4, IRS0*1, NOTE*1, NOTE1*1, IYSP1*1,
     2 SPSITE*6, MOVE*8, VLAG*4
      DIMENSION PERC(NP10)
      COMMON /PAGENM/ PAGET, PAGEIND(25)
      CHARACTER PAGET*8, PAGEIND*8
      COMMON /CGGT/ IGGT
      CHARACTER IGGT*80
      COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0
      CHARACTER CN3*1, CN31*1
      IWIN = IGBL(25) * IGBL(32)
      FORMA( 1:40) = '(12X,''Calculated Density ='',F8.4,''('',I2,'
      FORMA(41:82) = ''') g cm-3 [= Mg m-3]'',24X,''** WARNING **'')'
      JBN    = 0
      IATCAR = 0
      NC2    = 0
      KL   = IPR(220)
      KN   = IPR(221)
      NATX = IPR(37)
      NAT  = IPR(39)
      NRES = IPR(75)
      NSYM = IPR(48)
      LTYPE = 0
      IRS0  = ' '
      LRES  = 0
      NHAT  = 0
      NCEFF = 0
      IF (IPR(18) .GT. 0) THEN
        IF (IWIN .EQ. 1) CALL GGIP (HORS, VERT, 0.0, 1)
        IF (IPR(18) .EQ. 1) NAT = NAT + IPR(64)
        IF (KN .GT. 0) LRES = NINT(FN(1))
        IF (KL .GT. 2) CALL PLA037 (3, LTYPE, 2)
        NDLPM = 1
      ELSE
        NDLPM = 2
        PAGET = 'GEOMETRY'
      ENDIF
C * LIST ATOMS
      IF (IABS(IPR(18)) .EQ. 1) THEN
        IF (IPR(18) .GT. 0) THEN
          WRITE (PRBUF, 99979)
          IF (IWIN .EQ. 1) THEN
            VRT = VERT - 0.4
            CALL GGIP20 (0.0, PRBUF, 80, 0.35, 5 + IGBL(68), 2,
     1                   1.0, VRT)
            VRT = VRT - 0.2
          ELSE
            WRITE (LU6, 99969) PRBUF(1:80)
          ENDIF
          GOTO 70
        ENDIF
        IF (IPR(113) .NE. 0) GOTO 690
        IPR(113) = 1
        IF (IGBL(63) .GT. 1) THEN
          IF (IPR(23) .EQ. 0) THEN
            CALL PLA269 (0)
          ELSE
            CALL PLA269 (3)
            WRITE (LU7, 99957) PAR(11)
          ENDIF
        ENDIF
        IF (IPR(72) .EQ. 0 .OR. IPR(68) .EQ. 0) THEN
          NRND = ' Not'
        ELSE
          CALL GEN040 (IPR(68) * 10 - 1, NQ1, IP)
          NRND = '1:'//NQ1(1:2)
        ENDIF
C * GET SHELDRICK TYPE ROUNDED ATOM WEIGHTS
        DO 10 I = 1, IAN
          K = IENS(I)
          L = IEN(K)
          IF (IPR(181) .EQ. 1) THEN
            IF (L .EQ. 1) THEN
              YUNK = 1000.0
            ELSE
              YUNK = 100.0
            ENDIF
            SATWT(K) = NINT(ATWT(L) * YUNK) / YUNK
          ELSE
            SATWT(K) = ATWT(L)
          ENDIF
   10   CONTINUE
        DO 30 I = 1, IAN
          J = IEN(IENS(I))
          IF (IPR(493) .NE. 5) THEN
            J     = (J - 1) * 15
            FN(I) = 0.0
            DO 20 K = 1, 9, 2
              FN(I) = FN(I) + SFAC(J + K)
   20       CONTINUE
          ELSE
            FN(I) = RNSCL(J)
          ENDIF
          IPR(22) = MAX (IPR(22), IATNR(IEN(IENS(I))))
   30   CONTINUE
        IF (IGBL(63) .GT. 3) THEN
          CALL PLA269 (15)
          WRITE (LU7, 99974) NRND
          WRITE (LU7, 99991) (LMT(IENS(I), 1),     I = 1, IAN)
          WRITE (LU7, 99994) (RADR(IENS(I), 2),    I = 1, IAN)
          WRITE (LU7, 99992) (IATNR(IEN(IENS(I))), I = 1, IAN)
          WRITE (LU7, 99993) (SATWT(IENS(I)),      I = 1, IAN)
          IF (IPR(493) .NE. 5) THEN
            WRITE (LU7, 99954) (FN(I), I = 1, IAN)
          ELSE
            WRITE (LU7, 99940) (FN(I), I = 1, IAN)
          ENDIF
        ENDIF
        IF (IPR(493) .GT. 0 .AND. IPR(493) .LT. 4) THEN
          DO 50 K = 1, 2
            DO 40 I = 1, IAN
              J     = IEN(IENS(I)) * 15 + K - 2 * IPR(493)
              FN(I) = SFAC(J)
   40       CONTINUE
            IF (IGBL(63) .GT. 3) THEN
              CALL PLA269 (1)
              IF (K .EQ. 1) WRITE (LU7, 99953) (FN(I), I = 1, IAN)
              IF (K .EQ. 2) WRITE (LU7, 99952) (FN(I), I = 1, IAN)
            ENDIF
   50     CONTINUE
        ENDIF
        IF (IPR(493) .GT. 0 .AND. IPR(493) .LT. 5) THEN
          DO 60 I = 1, IAN
            J = IEN(IENS(I))
            IF (SATWT(IENS(I)) .GT. 0.1) THEN
              IF (IPR(493) .LT. 4) THEN
                YUNK = AMR(J, IPR(493))
              ELSE
                YUNK  = AMR(J, 1) * (PAR(17) / 0.56086)**3
              ENDIF
              FN(I) = YUNK / (SATWT(IENS(I)) * 1.66054)
            ELSE
              FN(I) = 0.0
            ENDIF
   60     CONTINUE
          IF (IGBL(63) .GT. 3) THEN
            CALL PLA269 (6)
            WRITE (LU7, 99998) KRAD, (FN(I), I = 1, IAN)
            WRITE (LU7, 99990) (LMT(IENS(I), 2), I = 1, IAN)
          ENDIF
        ENDIF
        IF (IGBL(63) .GT. 3) THEN
          IF (IGBL(30) .EQ. 1) THEN
            NQ1 = 'NOMOVE'
          ELSE
            NQ1 = ' '
          ENDIF
          WRITE (LU7, 99995) NQ1
        ENDIF
        IF (IPR(23) .EQ. 0) THEN
          FORM(1:8)    = '(A,1X,A,'
          FORM(9:47)   = 'F11.0,A,I2,A,F11.0,A,I2,A,F11.0,A,I2,A,'
          FORM(48:88)  = 'F8.0,A,I2,A,F8.0,A,I2,A,F8.0,A,I2,A,A,I3,'
          FORM(89:109) = '2F6.3,A,I3,A,A,1X,A3)'
        ELSE
          FORM(1:37)   = '(I4,1X,A,42X,F9.0,A,I2,A,F9.0,A,I2,A,'
          FORM(38:56)  = 'F9.0,A,I2,A,35X,A3)'
        ENDIF
   70   IF (NRES .EQ. 0) THEN
          NRES0 = 0
        ELSE
          NRES0 = 1
        ENDIF
C * LOOP OVER RESIDUES
        DO 120 N = NRES0, NRES
          IF (IPR(18) .GT. 0) THEN
            IF (NRES .GT. 1) WRITE (LU6, 99982) N
          ELSE
            IF (IGBL(63) .GT. 2) THEN
              IF (NRES .GT. 1) THEN
                CALL PLA269 (5)
                WRITE (LU7, 99981) N
              ENDIF
              CALL PLA269 (3)
              WRITE (LU7, 99971)
            ENDIF
          ENDIF
          NHAT = 0
          NDIS = 0
          DO 110 NDLP = 1, NDLPM
            NRAT = 0
            DO 100 I = 1, NAT
              CALL GEN048 (-6, IFG(I), 9, IRESI)
              IF (N .EQ. IRESI) THEN
                CALL PLA036 (I, 1, 1, IDIS1, IDUM, ISP1, IPR(119),
     1                       IGBL(55))
                CALL GEN048 (-1, IFG(I), 23, IDA0)
                CALL GEN048 (-1, IFG(I), 20, IDH0)
                CALL GEN048 (-1, IFG(I), 19, IMET)
                CALL GEN048 (-1, IFG(I), 7,  IHAT)
                VLAG = '-   '
                IF (IABS(IGBL(8)) .EQ. 3) THEN
                  VLAG = 'd   '
                  CALL GEN048 (-1, JFG(I), 29, IVLAG)
                  IF (IVLAG .EQ. 1) VLAG(1:1) = 'c'
                  CALL GEN048 (-1, JFG(I), 30, IVLAG)
                  IF (IVLAG .EQ. 1) VLAG(2:2) = 'R'
                  CALL GEN048 (-1, JFG(I), 31, IVLAG)
                  IF (IVLAG .EQ. 1) VLAG(2:2) = 'G'
                ENDIF
                IF (IPR(18) .LT. 0) THEN
                  DO 80 J = 1, 3
                    XSIGMA = SQRT(XSD(I, J))
                    IF (IHAT .EQ. 1) THEN
                      NDEF = 5
                    ELSE IF (INT(XSIGMA * 100000.0)  .EQ. 0 .AND.
     1                       INT(XSIGMA * 1000000.0) .GT. 0) THEN
                      NDEF = 6
                    ELSE
                      NDEF = 5
                    ENDIF
                    CALL GEN041 (XXO(I, J), XSIGMA, IXSD(J),
     1                           NDEF, NDEC, IPR(68))
                    XSD(I, J) = XSIGMA ** 2
                    IF (IPR(23) .EQ. 0) THEN
                      NDC           = J * 13
                      FORM(NDC:NDC) = CHAR(ICHAR('0') + NDEC)
                    ENDIF
                    IXSD(J)       = MIN (99, IXSD(J))
                    XSIGMA = SQRT(ABS(XSD(I, J + 3)))
                    NDEF   = 4
                    YUNK   = XXO(I, J + 3)
                    IYUNK  = IXSD(J + 3)
                    CALL GEN041 (YUNK, XSIGMA, IYUNK, NDEF, NDEC,
     1                           IPR(68))
                    IF (IPR(23) .EQ. 0) THEN
                      NDC = J * 12 + 39
                    ELSE
                      NDC = J * 12 + 5
                    ENDIF
                    FORM(NDC:NDC) = CHAR(ICHAR('0') + NDEC)
                    IXSD(J + 3)   = MIN (99, IYUNK)
   80             CONTINUE
                ENDIF
                CALL GEN048 (-4, IFG(I), 15, NO1)
                NO1 = NO1 + 1
                IF (IEN(NO1) .EQ. 5 .OR. IEN(NO1) .EQ. 6 .OR.
     1              IEN(NO1) .EQ. 8) THEN
                  IF (NINT(CON(I, NP4)) .LT. -3) THEN
                    IDA0 = 0
                    CALL GEN048 (1, IFG(I), 23, IDA0)
                  ENDIF
                ENDIF
                IAH0 = 0
                IF (IHAT .EQ. 1) THEN
                  IF (NINT(CON(I, NP4)) .EQ. -1) THEN
                    J = NINT(CON(I, 1))
                    CALL GEN048 (-4, IFG(J), 15, NO2)
                    IF (IEN(NO2 + 1) .EQ. 20) THEN
                      IAH0 = 1
                      CALL GEN048 (1, JFG(I), 28, 1)
                    ENDIF
                  ENDIF
                ENDIF
                IF (NDLP .EQ. 1) THEN
                  IF (IPR(18) .LT. 0) THEN
                    IF (IEN(NO1) .EQ. 1) THEN
                      IF (NHAT .EQ. 0) THEN
                        IF (IGBL(63) .GT. 2) THEN
                          CALL PLA269 (1)
                          WRITE (LU7, 99966)
                        ENDIF
                        NHAT = 1
                      ENDIF
                    ELSE
                      IF (NHAT .EQ. 1) THEN
                        IF (IGBL(63) .GT. 2) THEN
                          CALL PLA269 (1)
                          WRITE (LU7, 99966)
                        ENDIF
                        NHAT = 0
                      ENDIF
                    ENDIF
                  ENDIF
                ENDIF
                IF (ISP1 .EQ. 1) THEN
                  IYSP1   = 'S'
                  XJX(1)  = XXO(I, 1)
                  XJX(2)  = XXO(I, 2)
                  XJX(3)  = XXO(I, 3)
                  XJX(10) = 0.0
                  CALL SGSM (LINE, 0, XJX, LU6, 19, IERR)
                  SPSITE = ' '//LINE(1:5)
                ELSE
                  IYSP1  = ' '
                  SPSITE = '      '
                ENDIF
                KTYPE = ' - '
                IF (IAH0 .EQ. 1) KTYPE = 'A-H'
                IF (IDA0 .EQ. 1) KTYPE = 'D/A'
                IF (IDH0 .EQ. 1) KTYPE = 'D-H'
                IF (IMET .EQ. 1) KTYPE = 'Met'
                CALL GEN048 (-7, JFG(I), 1, IPP)
                IPP  = IPP + 1
                PPAR = IPPR(IPP, 1) / 1000.0
                SPAR = IPPR(IPP, 2) / 1000.0
                CALL GEN041 (PPAR, SPAR, IPPAR, 3, NDEC, IPR(68))
                IF (IPR(23) .EQ. 0) FORM(93:93) =
     1            CHAR(ICHAR('0') + NDEC)
                MULT = NSYM / IPPR(IPP, 3)
                SOF  = PPAR / MULT
                ATTRS = NTRNS(I) / 1000.0
                IF (IPR(18) .GT. 0) THEN
                  IF (LTYPE .EQ. 0   .AND. LRES .EQ. 0 .OR.
     1                LTYPE .EQ. 0   .AND. LRES .EQ. N .OR.
     2                LTYPE .EQ. NO1 .AND. LRES .EQ. 0 .OR.
     3                LTYPE .EQ. NO1 .AND. LRES .EQ. N) THEN
                    IF (IPR(23) .EQ. 0) THEN
                      WRITE (PRBUF, 99978) I, NAMS(1, 1),
     1                                     (XXO(I, K), K = 1, 3),
     2                RADR(NO1, 2), IYSP1, MULT, PPAR, ATTRS, KTYPE
                    ELSE
                      WRITE (PRBUF, 99934) I, NAMS(1, 1),
     1                                     (XXO(I, K), K = 1, 3),
     2                RADR(NO1, 2), IYSP1, MULT, PPAR, ATTRS, KTYPE
                    ENDIF
                    K = INDEX (PRBUF, ' 1.000 ')
                    IF (K .GT. 0) PRBUF(K:K+5) = '   -  '
                    K = INDEX (PRBUF, ' 1.555 ')
                    IF (K .GT. 0) PRBUF(K:K+5) = '   -  '
                    IF (IWIN .EQ. 1) THEN
                      IF (VRT - 0.4 .LT. 0) THEN
                        CALL PLA013 (1, 1)
                        ICH = IGGT(1:1)
                        CALL GGIP (HORS, VERT, 0.0, 1)
                        IF (ICH .NE. 'Y' .AND. ICH .NE. '!') GOTO 700
                        VRT = VERT
                      ENDIF
                      VRT = VRT - 0.4
                      CALL GGIP20 (0.0, PRBUF, 80, 0.35, 1, 2, 1.0, VRT)
                    ELSE
                      WRITE (LU6, 99948) PRBUF(1:80)
                    ENDIF
                  ENDIF
                ELSE
                  IF (PPAR .LT. 0.5) THEN
                    IF (NDLP .EQ. 1) GOTO 100
                    NDIS = NDIS + 1
                    IF (NDIS .LT. 2) THEN
                      IF (IGBL(63) .GT. 2) THEN
                        CALL PLA269 (4)
                        WRITE (LU7, 99999) '<'
                      ENDIF
                    ENDIF
                    GOTO 90
                  ENDIF
                  IF (NDLP .EQ. 2) GOTO 100
   90             NRAT = NRAT + 1
                  MOVE = '    -   '
                  IF (NINT(ATTRS * 1000.0) .NE.  1555)
     1                WRITE (MOVE, '(F8.3)') ATTRS
                  IF (IPR(23) .EQ. 0) THEN
                    IF (IATP(I) .NE. 1555 .AND. I .LE. NATX) THEN
                        IPR(204) = IPR(204) + 1
                    ENDIF
                    WRITE (PRBUF, FORM) VLAG, NAMS(1, 1), (XXO(I, K),
     1                '(', IXSD(K), ')', K = 1, 6), SPSITE, MULT, SOF,
     2                PPAR, '(', IPPAR, ')', MOVE, KTYPE
                  ELSE
                    WRITE (PRBUF, FORM) NRAT, NAMS(1, 1), (XXO(I, K),
     1                '(', IXSD(K), ')', K = 4, 6), KTYPE
                  ENDIF
                  IF (IGBL(63) .GT. 2)
     1              CALL PLA067 (LU7, PRBUF, 132, 1, 7)
                ENDIF
              ENDIF
  100       CONTINUE
  110     CONTINUE
  120   CONTINUE
        IF (IPR(18) .LE. 0) THEN
          IF (IPR(23) .EQ. 0 .AND. IPR(13) .GT. 1) THEN
            CALL PLA269 (0)
            CALL PLA043 (NSMPR, 1, LU7, 0)
          ENDIF
          IPR(488) = 3
          IF (IGBL(63) .GT. 2) THEN
            IF (IPR(44) .EQ. 1) THEN
              CALL PLA269 (3)
              WRITE (LU7, 99973)
              ISORD = 'Diso'
            ELSE
              ISORD = '   O'
            ENDIF
            IF (IGBL(71) .NE. 0) THEN
              CALL PLA269 (3)
              WRITE (LU7, 99972)
            ENDIF
            NWL = 25 + NRES - IPR(23) * 10
            CALL PLA269 (NWL)
            WRITE (LU7, 99986) ISORD, (LMT(IENS(K), 1), K = 1, IAN)
            WRITE (LU7, 99985)
          ENDIF
          PAR(163) = 0
          PAR(157) = 0
          DO 130 J = 1, NP10
            CONT(J, 2) = 0.0
  130     CONTINUE
          DO 410 IRES = 1, NRES
            MULT = MLTI(IRES)
            IF (MULT .LE. 0) MULT = 1
            NN = NP1 + 1 - IRES
            DO 140 J = 1, 5
              XXO(NN, J) = 0.0
              XSD(NN, J) = 0.0
  140       CONTINUE
            XXO(NN, 6) = 1.0
            DO 150 J = 1, NP10
              CONT(J, 1) = 0.0
  150       CONTINUE
            SUMWT = 0.0
            DO 190 J = 1, NAT
              CALL GEN048 (-6, IFG(J), 9, IRESJ)
              IF (IRESJ .EQ. IRES) THEN
                IF (J .GT. NATX) THEN
                  KMX = J - 1
                  DO 170 K = 1, KMX
                    DO 160 L = 1, 3
                      DIF = ABS(XXO(J, L) - XXO(K, L))
                      IF (ABS(MOD(DIF, 1.0)) .GT. 0.0001) GOTO 170
  160               CONTINUE
                    GOTO 190
  170             CONTINUE
                ENDIF
                CALL GEN048 (-7, JFG(J), 1, NPP)
                NPP = NPP + 1
                PPM = MULT * IPPR(NPP, 3) * IPPR(NPP, 1) /
     1                (NSYM * 1000.0)
                CALL GEN048 (-4, IFG(J), 15, NO1)
                NO1 = NO1 + 1
                WT  = SATWT(NO1)
                IF (NINT(WT) .EQ. 0) WT = 1.0
                SUMWT = SUMWT + WT
                DO 180 L = 1, 3
                  XXO(NN, L) = XXO(NN, L) + XXO(J, L) * WT
  180           CONTINUE
                IF (J .LE. NATX) THEN
                  CONT(NO1, 1) = CONT(NO1, 1) + PPM
                  XXO(NN, 4)   = XXO(NN, 4)   + WT * PPM
                  XXO(NN, 5)   = MAX(XXO(NN, 5), IPPR(NPP, 1) / 1000.0)
                  XXO(NN, 6)   = MIN(XXO(NN, 6), IPPR(NPP, 1) / 1000.0)
                ENDIF
              ENDIF
  190       CONTINUE
            IF (XXO(NN, 5) .NE. XXO(NN, 6)) XXO(NN, 5) = 1.000
            IF (SUMWT .EQ. 0.0) THEN
              IPR(2)   = 32
              IPR(323) = 8
              GOTO 690
            ENDIF
            DOM = 1
            DO 200 J = 1, 3
              XJX(J)     = XXO(NN, J) / SUMWT
              XXO(NN, J) = XJX(J)
  200       CONTINUE
            SPSITE = '      '
            IF (IPR(101) .GT. 0) THEN
              NMOL = IPR(13)
              DO 220 K = 2, NMOL
                ML  = MOL(K)
                XML = ML / PAR(42)
                CALL GEN098 (ML, PAR(42), MOL1, MOL2, MOL3, MOL4, IRES0)
                IF (IRES0 .EQ. IRES) THEN
                  IF (MOL1 .GT. IPR(48)) THEN
                    MOL1   = MOL1 - IPR(48)
                    XML    = XML  - IPR(48) * 1000
                    XJX(4) = MOL2
                    XJX(5) = MOL3
                    XJX(6) = MOL4
                    CALL SGSM (ICL, MOL1, XJX, LU6, 3, IERR)
                    DO 210 J = 1, 3
                      XXO(NN, J) = XXO(NN, J) + XJX(J + 6)
  210               CONTINUE
                    DOM = DOM + 1
                  ENDIF
                ENDIF
  220         CONTINUE
              DO 230 K = 1, 3
                XXO(NN, K) = XXO(NN, K) / DOM
  230         CONTINUE
            ENDIF
            DO 240 K = 1, 3
              XJX(K) = XXO(NN, K)
  240       CONTINUE
            XJX(10)  = 0.0
            CALL SGSM (LINE, 0, XJX, LU6, 19, IERR)
            SPSITE   = ' '//LINE(1:5)
            PAR(163) = PAR(163) + XXO(NN, 4) * NSYM / MULT
            RCONT(IRES) = 0.0
            IF (IPR(322) .GT. 0) THEN
              MM0 = IPR(255) * IPR(257)
              DO 250 I = 1, IAN
                C1  = CONT(I, 1) * MM0
                IC1 = NINT(C1)
                IF (ABS(C1 - IC1) .GT. 0.01) GOTO 270
                IATC(I) = IC1
  250         CONTINUE
              MULT          = MULT * MM0
              IATC(IAN + 1) = MULT
              CALL GEN107 (IATC, IAN + 1, IGGD)
              MULT = MULT / IGGD
              XXO(NN, 4) = XXO(NN, 4) * MM0 / IGGD
              DO 260 I = 1, IAN
                CONT(I, 1) = CONT(I, 1) * MM0 / IGGD
  260         CONTINUE
            ENDIF
  270       DO 280 I = 2, 6
              IF (I .NE. 5) THEN
                DO 271 L = 1, IAN
                  IF (ABS(MOD(CONT(L, 1) / XXO(NN, 5), 1.0) - 1.0 /
     1              FLOAT(I)) .LT. 0.001) THEN
                    IF (MOD(NSYM, I) .EQ. 0) THEN
                      DO 275 L9 = 1, IAN
                        CONT(L9, 1) = CONT(L9, 1) * FLOAT(I)
  275                 CONTINUE
                      MULT = MULT * I
                      XXO(NN, 4) = XXO(NN, 4) * FLOAT(I)
                    ENDIF
                    GOTO 290
                  ENDIF
  271           CONTINUE
              ENDIF
  280       CONTINUE
  290       NSP = IPR(488)
            NONINT = 0
            IF (NSP .GT. 3) THEN
              DO 310 K = 4, NSP
                DO 300 L = 1, IAN
                  IF (ABS(CONT(L, K) - CONT(L, 1)) .GT. 0.03) GOTO 310
  300           CONTINUE
                NSP = K
                GOTO 320
  310         CONTINUE
            ENDIF
            NSP      = NSP + 1
            IPR(488) = NSP
            IF (NSP .GT. 99) THEN
              IPR(2) = 62
              GOTO 710
            ENDIF
            CONT(NP10 + 1, NSP) = 0.0
  320       IZET = NSYM / MULT
            IF (IZET * MULT .NE. NSYM) THEN
              DO 330 L = 1, IAN
                CONT(L, 1) = CONT(L, 1) * NSYM / MULT
  330         CONTINUE
              XXO(NN, 4) = XXO(NN, 4) * NSYM / MULT
              IZET = 1
              DO 340 L = 1, IAN
                IF (ABS(NINT (CONT(L, 1) / 2.0) - CONT(L, 1) / 2.0)
     1            .GT. 0.01) GOTO 360
  340         CONTINUE
              DO 350 L = 1, IAN
                CONT(L, 1) = CONT(L, 1) / 2.0
  350         CONTINUE
              XXO(NN, 4) = XXO(NN, 4) / 2.0
              IZET = 2
            ENDIF
  360       DO 370 L = 1, IAN
              CONT(L, 2) = CONT(L, 2) + CONT(L, 1) * IZET
              CONT(L, 1) = CONT(L, 1) / XXO(NN, 5)
              NCNT       = NINT (CONT(L, 1))
              IF (ABS(CONT(L, 1) - NCNT) .GE. 0.1) NONINT = 1
              CONT(L, NSP) = CONT(L, 1)
              IF (IEN(L) .NE. 1) RCONT(IRES) = RCONT(IRES) + CONT(L, 1)
  370       CONTINUE
            CONT(NP10 + 1, NSP) = CONT(NP10 + 1, NSP)
     1                          + IZET * XXO(NN, 5)
            CALL PLA283 (1, 1, N, IDM)
            IF (N .GT. 0 .AND. N .LT. 81)
     1        WRITE (LU6, 99963) IRES, XXO(NN, 5), IZET, IDM(N:80)
            INSIDE = 1
            DO 390 K = 1, 3
              IF (XXO(NN, K) .GT. 1.1  .OR. XXO(NN, K) .LT. -0.1) THEN
                INSIDE = 0
              ENDIF
  390       CONTINUE
            IF (INSIDE .EQ. 0) THEN
              IF (N .GT. 0 .AND. N .LT. 81 .AND. IGBL(94) .EQ. 0)
     1          WRITE (LU20, 99946) 1, IRES, IDM(N:80)
            ENDIF
            IF (NONINT .GT. 0) THEN
              WRITE (PRBUF, 99984) IRES, SPSITE, (XXO(NN, K), K = 1, 5),
     1        IZET, (CONT(IENS(L), 1), L = 1, IAN)
            ELSE
              IF (IRES .EQ. 1 .AND. NRES .EQ. 1) IPR(260) = IZET
              WRITE (PRBUF, 99970) IRES, SPSITE, (XXO(NN, K), K = 1, 5),
     1          IZET, (NINT(CONT(IENS(L), 1)), L = 1, IAN)
              DO 400 K = 51, 128
                IF (PRBUF(K : K + 4) .EQ. '    0') PRBUF(K+4:K+4) = '-'
  400         CONTINUE
            ENDIF
            IF (IGBL(63) .GT. 2) CALL GEN065 (LU7, PRBUF, 130, 7)
  410     CONTINUE
          NCMX = 1
          IF (NRES .GT. 1) THEN
            DO 415 K = 1, NRES
              IF (RCONT(K) .GT. RCONT(NCMX)) NCMX = K
  415       CONTINUE
          ENDIF
          IF (RCONT(NCMX) .LT. 15) IPR(487) = 0
          DO 430 K = 1, 32
            KZ = 33 - K
            DO 420 L = 4, IPR(488)
              LZ = NINT(CONT(NP10 + 1, L))
              IF (ABS(CONT(NP10 + 1, L) - LZ) .LT. 0.00001) THEN
                IF (MOD(LZ, KZ) .NE. 0) GOTO 430
              ENDIF
  420       CONTINUE
            GOTO 440
  430     CONTINUE
          KZ = NSYM
  440     IF (KZ * 2 .EQ. NSYM) THEN
            DO 450 L = 1, IAN
              LZ = NINT(CONT(L, 2))
              IF (MOD (LZ, 2) .NE. 0) GOTO 460
  450       CONTINUE
            IF (MOD (NINT(CONT(NP10 + 1, 4)), NSYM) .EQ. 0) KZ = KZ * 2
          ENDIF
  460     MZ = 1
          IF ((KZ / 2) * 2 .EQ. KZ) THEN
            DO 465 L = 1, IAN
  461         LZ = NINT(CONT(L, 2) * MZ)
              IF (ABS(CONT(L, 2) * MZ - LZ) .LT. 0.001) THEN
                IF ((LZ / KZ) * KZ .NE. LZ) THEN
                  IF (MZ .EQ. 1) THEN
                    MZ = 2
                    GOTO 461
                  ELSE
                    GOTO 466
                  ENDIF
                ENDIF
              ENDIF
  465       CONTINUE
            KZ = KZ / MZ
          ENDIF
  466     IPR(260) = KZ
          PAR(162) = 0.0
          IPR(215) = 0
          F000A    = 0.0
          F000B    = 0.0
          NHEAVY   = 0
          DO 480 L = 1, IAN
            IENL = IEN(L)
            NHEAVY = MAX (NHEAVY, IATNR(IENL))
            J      = (IENL - 1) * 15
            YMR   = 0.0
            FDELA = 0.0
            FDELB = 0.0
            IF (IPR(493) .GT. 0 .AND. IPR(493) .LT. 5) THEN
              IF (IPR(493) .LT. 4) THEN
                YMR   = AMR(IENL, IPR(493))
                FDELA = SFAC(J + 16 - 2 * IPR(493))
                FDELB = SFAC(J + 17 - 2 * IPR(493))
              ELSE
                YMR = AMR(IENL, 1) * (PAR(17) / 0.56086)**3
              ENDIF
            ENDIF
            DO 470 K = 1, 9, 2
              F000A = F000A + CONT(L, 2) * SFAC(J + K)
  470       CONTINUE
            F000A = F000A + CONT(L, 2) * FDELA
            F000B = F000B + CONT(L, 2) * FDELB
            IF (IPR(493) .NE. 5) THEN
              PAR(157) = PAR(157) + CONT(L, 2) * IATNR(IENL)
            ELSE
              PAR(157) = PAR(157) + CONT(L, 2) * RNSCL(IENL)
            ENDIF
            PERC(L)    = CONT(L, 2) * SATWT(L) * 100.0 / PAR(163)
            PAR(162)   = PAR(162) + CONT(L, 2) * YMR * 0.1
            NCNT       = NINT(CONT(L, 2))
            CONT(L, 3) = CONT(L, 2) - NCNT
            IF (ABS(CONT(L, 3)) .GT. NCNT * PAR(331))
     1              IPR(215) = IPR(215) + 1
  480     CONTINUE
          PAR(426) = SQRT(F000A**2 + F000B**2)
          PAR(160) = PAR(163) / (PAR(98) * 0.60221)
          DXREP    = IPR(276) * PAR(308) / (PAR(98) * 0.60221)
          IF (PAR(267) .GT. 0.0 .AND. IGBL(94) .EQ. 0) THEN
            XDIF = 100 * ABS (PAR(267) - DXREP) / PAR(267)
            IF (XDIF .GT. 0.5)
     1        WRITE (LU20, 99936) '_046', XDIF, DXREP
          ENDIF
          PAR(162) = PAR(162) / PAR(98)
          SIGD     = (PAR(160) / PAR(98)) * PAR(21)
          CALL GEN041 (PAR(160), SIGD, IPR(295), 4, IPR(296), IPR(68))
          FORMA(32:32) = CHAR(ICHAR('0') + IPR(296))
          PAR(142) = FLOAT(IPR(260)) / NSYM
          CALL PLA283 (0, 1, N, IDM)
          IF (IGBL(94) .EQ. 0) THEN
            IF (INDEX (RLWS(4), '?') .EQ. 0) THEN
              N3 = 0
              DO 500 N2 = N, 80
                ICH  = IDM(N2:N2)
  490           N3   = N3 + 1
                CN3  = RLWS(4)(N3:N3)
                IF (CN3 .EQ. '+' .OR. CN3 .EQ. '-') GOTO 490
                CN31 = RLWS(4)(N3+1:N3+1)
                IF (ICH .NE. CN3) THEN
                  CALL GEN105 (3, CN3, J)
                  IF (CN3 .EQ. CHAR(32)) THEN
                    GOTO 490
                  ELSE IF (ICH .EQ. CHAR(32) .AND.
     1                     CN3//CN31 .EQ. '1 ') THEN
                    GOTO 490
                  ELSE IF (J .GE. 0 .AND. (CN31 .EQ. '+' .OR.
     1                                     CN31 .EQ. '-')) THEN
                    N3 = N3 + 1
                    GOTO 490
                  ELSE
                    CALL GEN020 (1, ICH, 1, 1)
                    IF (ICH .NE. CN3) THEN
                      WRITE (LU20, 99943) '_042', 1.0, 1.0
                      GOTO 510
                    ELSE
                      CALL GEN020 (-1, RLWS(4), N3, N3)
                    ENDIF
                  ENDIF
                ENDIF
  500         CONTINUE
            ELSE
              WRITE (LU20, 99943) '_048', 1.0, 1.0
            ENDIF
          ENDIF
  510     XDIF = 100 * ABS (PAR(163) - PAR(308) * IPR(276)) / PAR(163)
          IF (XDIF .GT. 0.1 .AND. IGBL(94) .EQ. 0)
     1        WRITE (LU20, 99937) '_043', XDIF, PAR(308)
          XDIF = 100.0 * ABS (PAR(160) - PAR(267)) / PAR(160)
          IF (XDIF .GT. 0.5 .AND. IGBL(94) .EQ. 0)
     1      WRITE (LU20, 99939) '_044', XDIF, PAR(267)
          IF (PAR(160) .LT. 1.0)
     1      WRITE (LU20, 99939) '_049', 0.5, PAR(160)
          IF (IPR(260) .NE. IPR(276)) THEN
            IF (IPR(276) .NE. 0) THEN
              RATIO = FLOAT(IPR(260)) / FLOAT(IPR(276))
            ELSE
              RATIO = 0.0
            ENDIF
            IF (IGBL(94) .EQ. 0)
     1        WRITE (LU20, 99937) '_045', 1.0, RATIO
          ENDIF
          CALL PLA283 (2, IPR(260), N1, ICL)
          IF (IGBL(94) .EQ. 0) THEN
            IF (INDEX (RLWS(5), '?') .EQ. 0) THEN
              N3 = 0
              DO 530 N2 = N1, 80
                ICH = ICL(N2:N2)
  520           N3  = N3 + 1
                JCH = RLWS(5)(N3:N3)
                IF (ICH .NE. JCH) THEN
                  IF (ICH .EQ. ' ' .AND.
     1              RLWS(5)(N3:N3+1) .EQ. '1 ') GOTO 520
                  CALL GEN020 (1, ICH, 1, 1)
                  IF (ICH .NE. JCH) THEN
                    WRITE (LU20, 99943) '_041', 1.0, 1.0
                    GOTO  540
                  ELSE
                    CALL GEN020 (-1, RLWS(5), N3, N3)
                  ENDIF
                ENDIF
  530         CONTINUE
            ELSE
              WRITE (LU20, 99943) '_047', 1.0, 1.0
            ENDIF
          ENDIF
  540     WRITE (LU6, 99951) IDM(N:80), ICL(N1:80),
     1           PAR(163) / IPR(260), IPR(260), IPR(48), PAR(142)
          IF (ABS(IGBL(8)) .EQ. 4) WRITE (LU6, 99947)
     1        JID(1:27), PAR(98), PAR(142), PAR(160), IDM(N:80)
          IF (IPR(23) .EQ. 0) THEN
            IF (IGBL(63) .GT. 2) THEN
              WRITE (LU7, 99989)
     1          PAR(163), (NINT(CONT(IENS(L), 2)), L = 1, IAN)
              IF (IPR(215) .GT. 0) THEN
                WRITE (LU7,  99965) (CONT(IENS(L), 3), L = 1, IAN)
              ENDIF
              WRITE (LU7, 99988) (PERC(IENS(L)), L = 1, IAN)
              WRITE (LU7, 99956) IDM(N:80), ICL(N1:80),
     1          PAR(163) / IPR(260), IPR(260), IPR(48), IPR(260),
     2          IPR(48), PAR(142)
              WRITE (LU7, 99966)
              WRITE (PRBUF, FORMA) PAR(160), IPR(295)
              CALL GEN065 (LU7, PRBUF, 130, 1)
              WRITE (LU7, 99987) PAR(157), PAR(426)
            ENDIF
            IF (IGBL(71) .GT. 0)
     1        WRITE (LU20, 99944) '_720', 1, IGBL(71)
            IF (IPR(474) .GT. 0 .AND. NHEAVY .GT. 18 .AND.
     1        IGBL(94) .EQ. 0) WRITE (LU20, 99944) '_164', 1, IPR(474)
            IF (IPR(164) .GT. 0) THEN
              WRITE (LU20, 99944) '_165', 1, IPR(164)
            ENDIF
            IF (KRAD(1:2) .NE. '??') THEN
              IF (IGBL(63) .GT. 2) THEN
                WRITE (LU7, 99955) KRAD, PAR(162) * 10.0, PAR(162)
                WRITE (LU6, 99997) KRAD, PAR(162) * 10.0, PAR(162)
              ENDIF
              IF (IABS(IGBL(8)) .EQ. 3) THEN
                IF (IPR(124) .NE. 0 .AND. IGBL(97) .EQ. 1)
     1            WRITE (LU20, 99933) 1, 1
                CALL PLA231 (50)
                CALL PLA231 (80)
              ENDIF
            ENDIF
            IF (IGBL(63) .GT. 2) THEN
              CALL PLA269 (2)
              WRITE (LU7, 99949)
            ENDIF
          ENDIF
          IPR(483) = 0
          IPR(484) = 0
          DO 550 L = 1, IAN
            IF (IEN(L) .EQ. 1) THEN
              IF (CONT(L, 2) .GT. 0) IPR(484) = 1
            ELSE IF (IEN(L) .EQ. 2) THEN
              IF (CONT(L, 2) .GT. 0) IPR(483) = 1
            ENDIF
  550     CONTINUE
          CALL PLA231 (70)
          IF (PAR(433) .EQ. 999999.0 .AND. IPR(22) .GT. 14 .AND.
     1        IPR(257) .EQ. 1 .AND. IGBL(94) .EQ. 0 .AND.
     2        IABS(IGBL(8)) .NE. 4)
     3      WRITE (LU20, 99944) '_034', 1, 1
          IF (IPR(257) .NE. 2 .AND. IGBL(94) .EQ. 0
     1                        .AND. IPR(583) .GT. 0) THEN
            N = INDEX (CCIF(17), '?')
            IF (N .NE. 0 .AND. IABS(IGBL(8)) .EQ. 3 .AND.
     1        CHSG(1:1) .EQ. 'C') WRITE (LU20, 99944) '_035', 1, 1
          ENDIF
          IF (IPR(484) .EQ. 0 .AND. IPR(483) .GT. 0) THEN
            WRITE (LU20, 99944) '_040', 1, 1
          ENDIF
          IF (IPR(495) .NE. 0 .AND. IPR(200) .EQ. 0) THEN
            IF (IPR(322) .EQ. 0 .AND. IGBL(3) .NE. 28) THEN
              IF (IGBL(3) .NE. 1 .AND. IPR(39) .LT. NMA) THEN
                IF (IPR(23) .EQ. 0) CALL PLA211 (LU6, LU7, JID)
              ELSE
                WRITE (LU6, '(''Too Many Atoms for MOLSYM'')')
              ENDIF
              IF (IPR(495) .EQ. 1 .OR. IPR(495) .EQ. 3) CALL PLA082
            ENDIF
          ENDIF
        ENDIF
      ELSE
        IF (IPR(147) .NE. 0) THEN
          IF (IGBL(31) .EQ. 4) THEN
            CALL GEN108 (LU2, 0)
            WRITE (LU2, 99959)
          ENDIF
          VRT = 0.0
          DO 680 N = 1, NRES
            NRS = N
            NADD = 0
            IF (RCONT(NRS) .LT. IPR(487)) NADD = 1
            IF (IGBL(31) .EQ. 4) THEN
              CALL GEN040 (NRS, NQ1, IP)
              WRITE (LU2, 99962) NQ1(1:IP)
              JBN = NP1
            ENDIF
            IF (IPR(18) .LT. 0) THEN
              IF (IGBL(63) .GT. 2) THEN
                IF (NRS .EQ. 1) THEN
                  CALL PLA269 (-11)
                  WRITE (LU7, 99983)
                ENDIF
                IF (NRES .GT. 1) THEN
                  CALL PLA269 (-5)
                  WRITE (LU7, 99981) NRS
                ENDIF
                CALL PLA269 (3)
                WRITE (LU7, 99977)
              ENDIF
            ELSE
              IF (NRES .GT. 1 .AND. IWIN .EQ. 0)
     1          WRITE (LU6, 99982) N
              IF (IWIN .EQ. 0)
     1              WRITE (LU6, '(//, A, /, 80(''-''))') PRBUF(1:80)
            ENDIF
            NDIS = 0
            DO 660 NDLP = 1, NDLPM
              NRAT  = 0
              NHRAT = 0
              DO 650 I = 1, NAT
                IAT    = I
                UEQAVR = 0.0
                NUEQ   = 0
                NROX   = 0
                CALL GEN048 (-6, IFG(IAT), 9, IRESI)
                IF (NRS .NE. IRESI) GOTO 650
                CALL GEN048 (-1, IFG(I), 7,  IHAT)
                CALL PLA036 (IAT, 1, 2, IDS1, IDUM1, IDUM2, IPR(119),
     1                       IGBL(55))
                IF (IDS1 .GE. 500) THEN
                  IF (NDLP .EQ. 2) GOTO 650
                ELSE
                  IF (NDLP .EQ. 1) GOTO 650
                  NDIS = NDIS + 1
                  IF (NDIS .EQ. 1 .AND. IGBL(63) .GT. 2) THEN
                    CALL PLA269 (3)
                    WRITE (LU7, 99999) '<'
                  ENDIF
                ENDIF
                CALL GEN048 (-4, IFG(IAT), 15, NO1)
                NO1 = NO1 + 1
                IATAK = IATPR(IEN(NO1))
                IF (IATAK .EQ. 5 .OR. IATAK .EQ. 6) THEN
                  IATALK = 1
                ELSE
                  IATALK = 0
                ENDIF
                IF (IGBL(31) .EQ. 4) THEN
                  IF (IEN(NO1) .EQ. 2) THEN
                    IATCAR = 1
                  ELSE
                    IATCAR = 0
                  ENDIF
                  IF (NDLP .EQ. 1 .AND. IEN(NO1) .NE. 1) THEN
                    NHRAT = NHRAT + 1
                    JNSC(1, IAT) = NHRAT
                  ENDIF
                ENDIF
                CALL GEN048 (-1, IFG(IAT), 19, IMET)
                IATMET = IMET
                IF (IPR(18) .LT. 0) THEN
                  IF (IEN(NO1) .EQ. 1) THEN
                    IF (NHAT .EQ. 0) THEN
                      IF (IGBL(63) .GT. 2) THEN
                        CALL PLA269 (1)
                        WRITE (LU7, 99966)
                      ENDIF
                      NHAT = 1
                    ENDIF
                  ELSE
                    IF (NHAT .EQ. 1) THEN
                      IF (IGBL(63) .GT. 2) THEN
                        CALL PLA269 (1)
                        WRITE (LU7, 99966)
                      ENDIF
                      NHAT = 0
                    ENDIF
                  ENDIF
                ENDIF
                NOTE  = ' '
                NOTE1 = ' '
                KMT   = 0
                DMX   = 0.0
                DMN   = 999.0
                DMNNH = 0.0
                NRAT  = NRAT + 1
                NBNDS = 0
                NC    = - NINT(CON(IAT, NP4))
                IF (NC .LT. 0) THEN
                  NC = NP4
                  CALL GEN048 (-1, IFG(IAT), 8, IVAL)
                  IF (IVAL .GT. 0) NC = NC + IPR(76)
                ENDIF
                PNC   = 0
                NRMET = 0
                DO 570 J = 1, NP4
                  IF (J .GT. NC) THEN
                    NAMS(J, 1) = ' -------'
                  ELSE
                    IF (J .LE. NP4) THEN
                      KAT = NINT(CON(IAT, J))
                    ELSE
                      IF (IBON(J - NP4, 1) .NE. IAT) GOTO 570
                      KAT = IBON(J - NP4, 2)
                    ENDIF
                    KAT = MOD(KAT, NP1)
                    CALL GEN048 (-1, IFG(KAT), 7, JHAT)
                    CALL GEN048 (-4, IFG(KAT), 15, NO3)
                    NO3 = NO3 + 1
                    IF (IEN(NO3) .EQ. 3) NROX = NROX + 1
                    IF (JHAT .EQ. 0 .AND. IPR(18) .EQ. -2
     1                              .AND. KAT .LE. NATX) THEN
                      NUEQ   = NUEQ   + 1
                      UEQAVR = UEQAVR + DATC(KAT)
                    ENDIF
                    CALL GEN048 (-1, IFG(KAT), 19, KATMET)
                    NRMET = NRMET + KATMET
                    CALL GEN048 (-4, IFG(KAT), 15, NOK)
                    NOK = NOK + 1
                    IF (IGBL(31) .EQ. 4) THEN
                      IF (JHAT .EQ. 0 .AND. NDLP .EQ. 1) THEN
                        IF (IEN(NOK) .EQ. 2) THEN
                          KATCAR = 1
                        ELSE
                          KATCAR = 0
                        ENDIF
                        IF ((IATMET .NE. 1 .OR. KATCAR .NE. 1) .AND.
     1                    (KATMET .NE. 1 .OR. IATCAR .NE. 1)) THEN
                          CALL PLA036 (KAT, 1, 2, IDS2, IDUM1, IDUM2,
     1                                 IPR(119), IGBL(55))
                          IF (IDS2 .GT. 500) THEN
                            NBNDS = NBNDS + 1
                            IF (KAT .GT. IAT) THEN
                              JBN = JBN + 1
                              JNSC(1, JBN) = IAT
                              JNSC(2, JBN) = KAT
                            ENDIF
                          ENDIF
                        ENDIF
                      ENDIF
                    ENDIF
                    CALL PLA036 (KAT, J, 1, IDS2, MNUM, ISPOS,
     1                           IPR(119), IGBL(55))
                    CALL GEN048 (-1, IFG(KAT), 19, KMET)
                    KMT = KMT + 1
                    PNC = PNC + MIN (1.0, FLOAT(IDS2) / FLOAT(IDS1))
                    IF (IPR(18) .LT. 0) THEN
                      CALL PLA050 (IAT, KAT, 0, 0, DIST)
                      DMX = MAX (DMX, DIST)
                      DMN = MIN (DMN, DIST)
                      IF (JHAT .EQ. 0) THEN
                        DMNNH = DMNNH + DIST
                      ENDIF
                      IF (KMET .EQ. 1) IMET = IMET + 1
                    ENDIF
                  ENDIF
  570           CONTINUE
                IF (IPR(18) .GT. 0) THEN
                  WRITE (PRBUF, 99976)
                  IF (IWIN .EQ. 1 .AND. VRT .EQ. 0.0) THEN
                    VRT = VERT - 0.4
                    CALL GGIP20 (0.0, PRBUF, 80, 0.3, 5 + IGBL(68), 2,
     1                           1.0, VRT)
                    VRT = VRT - 0.2
                  ENDIF
                  IF (LTYPE .EQ. 0   .AND. LRES .EQ. 0   .OR.
     1                LTYPE .EQ. 0   .AND. LRES .EQ. NRS .OR.
     2                LTYPE .EQ. NO1 .AND. LRES .EQ. 0   .OR.
     3                LTYPE .EQ. NO1 .AND. LRES .EQ. NRS) THEN
                        WRITE (PRBUF, 99975) NRAT, NAMS(1, 2),
     1                  (NAMS(L, 1)(1:8), L = 1, 8)
                    IF (IWIN .EQ. 1) THEN
                      IF (VRT - 0.4 .LT. 0.0) THEN
                        CALL PLA013 (1, 1)
                        ICH = IGGT(1:1)
                        CALL GGIP (HORS, VERT, 0.0, 1)
                        IF (ICH .NE. 'Y' .AND. ICH .NE. '!') GOTO 700
                        VRT = VERT
                      ENDIF
                      VRT = VRT - 0.4
                      CALL GGIP20 (0.0, PRBUF, 80, 0.35, 1, 2, 1.0, VRT)
                    ELSE
                      WRITE (LU6, 99948) PRBUF(1:80)
                    ENDIF
                  ENDIF
                  GOTO 610
                ENDIF
                INC = NINT(PNC)
                IF (IATMET .EQ. 1) THEN
                  IF (IGBL(97) .NE. 0 .AND. IATALK .EQ. 0) THEN
                    IF (NAMS(1, 2)(2:3) .NE. 'Cg') THEN
                      IF (INC .EQ. 0) THEN
                        WRITE (LU20, 99938) '_307', 1.0, 1.0, NAMS(1, 2)
                      ELSE IF (INC .EQ. 1 .AND. IAT .LE. NATX) THEN
                        WRITE (LU20, 99938) '_308', 1.0, 1.0, NAMS(1, 2)
                      ENDIF
                    ENDIF
                  ENDIF
                ENDIF
                IF (IEN(NO1) .EQ. 1) THEN
                  IF (INC .NE. 1 .AND. IMET .EQ. 0) NOTE = 'V'
                  IF (INC .EQ. 0 .AND. IAT .LE. NATX) THEN
                    IPR(153) = IPR(153) + 1
                    WRITE (LU20, 99938) '_305', 1.0, 1.0, NAMS(1, 2)
                  ENDIF
                ENDIF
                IF (IEN(NO1) .EQ. 2 .AND. KMT .LE. 1 .AND.
     1             (INC .EQ. 0 .OR. INC .GT. 4)) NOTE = 'V'
                IF (NC .EQ. 0) DMN = 0.0
                IF (IEN(NO1) .EQ. 3 .AND. IAT .LE. NATX) THEN
                  IF (INC .EQ. 0) THEN
                    NOTE = 'V'
                    IPR(161) = IPR(161) + 1
                    IF (IDS1 .EQ. 1000) THEN
                      WRITE (LU20, 99938) '_306', 1.0, 1.0, NAMS(1, 2)
                    ELSE
                      WRITE (LU20, 99938) '_311', 1.0, 1.0, NAMS(1, 2)
                    ENDIF
                  ELSE IF (INC .EQ. 1 .AND. PNC .LT. 1.3) THEN
                    KAT = NINT(CON(IAT, 1))
                    CALL GEN048 (-4, IFG(KAT), 15, NO2)
                    IF (IEN(NO2 + 1) .EQ. 2) THEN
                      CALL PLA050 (IAT, KAT, 0, 0, DIST)
                      IF (DIST .GT. 1.3) THEN
                        CALL PLA047 (XLAB(IAT), NQ1, IDUM, JDUM,
     1                               IPR(119), IGBL(55), 0, 0)
                        WRITE (LU20, 99938) '_309', 1.0, 1.0, ' '//NQ1
                      ENDIF
                    ENDIF
                  ELSE IF (INC .EQ. 2) THEN
                    KAT = NINT(CON(IAT, 1))
                    LAT = NINT(CON(IAT, 2))
                    CALL GEN048 (-1, IFG(KAT), 19, METK)
                    CALL GEN048 (-1, IFG(LAT), 19, METL)
                    CALL GEN048 (-4, IFG(KAT), 15, NO2)
                    IF (IEN(NO2 + 1) .EQ. 2) THEN
                      CALL PLA050 (IAT, KAT, 0, 0, DIST)
                      IF (DIST .LT. 1.25) THEN
                        CALL GEN048 (-4, IFG(LAT), 15, NO2)
                        IF (IEN(NO2 + 1) .EQ. 1) THEN
                          CALL PLA047 (XLAB(IAT), NQ1, IDUM, JDUM,
     1                                 IPR(119), IGBL(55), 0, 0)
                          WRITE (LU20, 99938)
     1                             '_312', 1.25 - DIST, 1.0, ' '//NQ1
                        ENDIF
                      ENDIF
                    ENDIF
                    CALL PLA050 (KAT, IAT, LAT, 0, ANG3)
                    IF (ANG3 .GT. 120) THEN
                      IF (METK .EQ. 0 .AND. METL .EQ. 0) THEN
                        CALL GEN048 (-4, IFG(KAT), 15, NOK)
                        CALL GEN048 (-4, IFG(LAT), 15, NOL)
                        IF (IEN(NOK + 1) .EQ. 85 .AND.
     1                      IEN(NOL + 1) .EQ. 85) THEN
                          WRITE (LU20, 99938)
     1                      '_396', ANG3 - 150.0, ANG3, NAMS(1, 2)
                        ELSE
                          WRITE (LU20, 99938)
     1                      '_395', ANG3 - 120.0, ANG3, NAMS(1, 2)
                        ENDIF
                      ENDIF
                    ENDIF
                  ELSE IF (INC .EQ. 3) THEN
                    DISTM = 0.0
                    DO 575 LL = 1, 3
                      KAT = NINT(CON(IAT, LL))
                      CALL PLA050 (IAT, KAT, 0, 0, DIST)
                      DISTM = MAX (DISTM, DIST)
  575               CONTINUE
                    IF (DISTM .LT. 1.6) THEN
                      CALL PLA047 (XLAB(IAT), NQ1, IDUM, JDUM,
     1                             IPR(119), IGBL(55), 0, 0)
                      WRITE (LU20, 99932) 1, 1, NQ1
                    ENDIF
                  ENDIF
                ENDIF
                CALL PLA099 (1, IAT, NANG, ANG1, ANG2, ANG3, NCEFF,
     1                       IMET, IHYB, CHYB, NATH, NOTE1)
                CALL GEN048 (  4, IFG(IAT), 24, IHYB)
                CALL GEN048 (  3, JFG(IAT), 24, NATH)
                CALL GEN048 (-10, JFG(IAT), 14, LNR)
                IF (IPR(324) .EQ. 1) THEN
                  IRS0 = ' '
                  IF (IHYB .EQ. 3) THEN
                    CALL GEN048 (-2, IFG(IAT), 28, JCAI)
                    IF (JCAI .EQ. 1) THEN
                      IRS0 = 'S'
                    ELSE IF (JCAI .EQ. 2) THEN
                      IRS0 = '?'
                    ELSE IF (JCAI .EQ. 3) THEN
                      IRS0 = 'R'
                    ENDIF
                  ENDIF
                ENDIF
                VLAG = '-   '
                IF (IABS(IGBL(8)) .EQ. 3) THEN
                  VLAG = 'd   '
                  CALL GEN048 (-1, JFG(IAT), 29, IVLAG)
                  IF (IVLAG .EQ. 1) VLAG(1:1) = 'c'
                  CALL GEN048 (-1, JFG(IAT), 30, IVLAG)
                  IF (IVLAG .EQ. 1) VLAG(2:2) = 'R'
                  CALL GEN048 (-1, JFG(IAT), 31, IVLAG)
                  IF (IVLAG .EQ. 1) VLAG(2:2) = 'G'
                ENDIF
                IF (IGBL(31) .EQ. 4 .AND. IEN(NO1) .NE. 1) THEN
                  IF (NDLP .EQ. 1) THEN
                    CALL GEN040 (NHRAT, NQ1, IP)
                    JX1 = IEL(IEN(NO1))
                    J1  = JX1 / 100
                    J2  = MOD(JX1, 100)
                    NQ1(5 : 5) = CHAR(ICHAR('A') + J1 - 1)
                    IF ( J2 .NE. 0) THEN
                      NQ1(6 : 6) = CHAR(ICHAR('A') + J2 - 1)
                    ELSE
                      NQ1(6 : 6) = ' '
                    ENDIF
                    WRITE (LU2, 99961) NQ1(1:IP), NQ1(5:6), NBNDS
                  ENDIF
                ENDIF
                IF (IAT .LE. NATX) THEN
                  IF (IEN(NO1) .EQ. 4) THEN
                    IF (NRMET .GT. 0 .AND. NCEFF .EQ. 3 .AND.
     1                DMN .GT. 1.45 .AND. ANG3 .LT. 114.0) THEN
                      WRITE (LU20, 99942)
     1                  '_32', 4 + NADD, 1.0, 1.0, NAMS(1, 2)
                      NOTE = '?'
                    ENDIF
                    IF (IHYB  .EQ. 0 .AND. NRMET. EQ. 0 .AND.
     1                  NCEFF .EQ. 3 .AND. DMN .LT. 1.1 .AND.
     2                  DMNNH .GT. 2.8 .AND. ANG3 .EQ. 120.0) THEN
                      WRITE (LU20, 99942)
     1                       '_31', 8 + NADD, 1.0, 1.0, NAMS(1, 2)
                    ENDIF
                  ELSE IF (IEN(NO1) .EQ. 2) THEN
                    IF (NCEFF .EQ. 3 .AND. NRMET .EQ. 0) THEN
                      IF (DMN .GT. 1.45 .AND. ANG3 .LT. 112.0) THEN
                        WRITE (LU20, 99942)
     1                    '_32', 6 + NADD, 1.0, 1.0, NAMS(1, 2)
                        NOTE = '?'
                      ENDIF
                    ENDIF
                  ELSE IF (IEN(NO1) .EQ. 8) THEN
                    IF (NCEFF .EQ. 3 .AND. NRMET .GT. 0) THEN
                      IF (ANG3 .LT. 115.0) THEN
                        WRITE (LU20, 99942)
     1                         '_32', 8, 1.0, 1.0, NAMS(1, 2)
                      ENDIF
                    ENDIF
                  ENDIF
                ENDIF
                IF (NAMS(1, 2)(1:1) .EQ. CHAR(32)) THEN
                  DO 580 LL = 1, NP4
                    IF (NAMS(LL, 1)(1:1) .NE. CHAR(32)) GOTO 590
  580             CONTINUE
                  GOTO 600
                ENDIF
  590           NOTE  = ' '
                NOTE1 = ' '
  600           IF (NOTE  .EQ. 'V') IPR(102) = IPR(102) + 1
                IF (NOTE1 .EQ. 'A') IPR(103) = IPR(103) + 1
                IF (IPR(483) .GT. 0 .AND. IPR(484) .GT. 0) THEN
                  NADD1 = NADD
                  IF (IEN(NO1) .NE. 2) THEN
                    IF (NADD1 .EQ. 0) THEN
                      NADD1 = 2
                    ELSE IF (NADD1 .EQ. 1) THEN
                      NADD1 = 3
                    ENDIF
                  ENDIF
                  IF ((NOTE1 .EQ. '?' .OR. NOTE1 .EQ. 'A') .AND.
     1                IAT .LT. NATX) WRITE (LU20, 99935)
     2                '_32', NADD1, 1.0, 1.0, NAMS(1, 2)
                ENDIF
                IF (NOTE .NE. ' ' .OR. NOTE1 .NE. ' ') THEN
                  WRITE (LU6, 99996) NAMS(1, 2),
     1              (NAMS(LL, 1), LL = 1, 7), NOTE, NOTE1
                ENDIF
                IF (IGBL(63) .GT. 2) THEN
                  CALL PLA269 (1)
                  WRITE (LU7, 99980) VLAG, NAMS(1, 2),
     1             (NAMS(LL, 1), LL = 1, NP4), NANG, NINT(ANG1),
     2             NINT(ANG2), ANG3, DMN, DMX, NCEFF, LNR, CHYB, IRS0,
     3             NOTE, NOTE1
                ENDIF
                IF (IRS0 .NE. ' ')
     1            WRITE (LU6, 99950) NAMS(1, 2), NRS, LNR, IRS0
                IF (IPR(18) .EQ. -2 .AND. IAT .LE. NATX
     1                              .AND. IHAT .EQ. 0) THEN
                  IF (NUEQ .GT. 1) THEN
                    UEQAVR = UEQAVR / NUEQ
                    DUEQ   = DATC(IAT) - UEQAVR
                    NADD2  = 0
                    NQ4    = NAMS(1, 2)(2 : 8)
                    IF (RCONT(NRS) .LT. IPR(487) .AND. NRES .GT. 1)
     1                  NADD2 = 2
                    IF (DUEQ .GT. 0.005) THEN
                      WRITE (LU20, 99945)  241 + NADD2, DUEQ, DUEQ, NQ4
                    ELSE IF (DUEQ .LT. -0.005) THEN
                      IF (NO1 .NE. 5 .OR. NROX .NE. 4 .OR.
     1                    DATC(IAT) .LT. 0.025) THEN
                        WRITE (LU20, 99945) 242 + NADD2, - DUEQ,
     1                                      - DUEQ, NQ4
                      ENDIF
                    ENDIF
                  ENDIF
                ENDIF
  610           NC1 = NP4
  620           NC1 = NC1 + 1
                IF (NC1 .GT. NC) GOTO 650
                NCL = 0
                DO 630 NC0 = NC1, NC
                  NC2 = NC0
                  IF (IBON(NC0 - NP4, 1) .EQ. IAT) THEN
                    NCK = MOD(IBON(NC0 - NP4, 2), NP1)
                    NCL = NCL + 1
                    CALL PLA036 (NCK, NCL, 1, IDIS, MNUM, ISPOS,
     1                           IPR(119), IGBL(55))
                    IF (NCL .EQ. NP4) GOTO 640
                  ENDIF
  630           CONTINUE
  640           IF (NCL .GT. 0) THEN
                  IF (IPR(18) .GT. 0) THEN
                    WRITE (LU6, 99968) (NAMS(LL, 1)(2:7), LL = 1, NCL)
                  ELSE
                    IF (IGBL(63) .GT. 2) THEN
                      CALL PLA269 (1)
                      WRITE (LU7, 99967) (NAMS(LL, 1), LL = 1, NCL)
                    ENDIF
                  ENDIF
                ENDIF
                NC1 = NC2
                GOTO 620
  650         CONTINUE
  660       CONTINUE
            IF (IGBL(31) .EQ. 4) THEN
              DO 670 K = NP1 + 1, JBN
                WRITE (LU2, 99960) JNSC(1, JNSC(1, K)),
     1                             JNSC(1, JNSC(2, K))
  670         CONTINUE
              WRITE (LU2, 99958)
            ENDIF
  680     CONTINUE
          IF (IGBL(31) .EQ. 4) THEN
            IF (IPR(322) .EQ. 0) THEN
              CALL PLA294 (0)
            ELSE
              CALL PLA015 (0, 27)
            ENDIF
          ENDIF
C * PRINT SYMMETRY CODES
          CALL PLA043 (NSMPR, 1, LU7, 0)
        ENDIF
      ENDIF
  690 IF (IWIN .EQ. 1 .AND. IPR(18) .GT. 0) CALL PLA297 (0)
  700 IPR(18) = 0
  710 RETURN
99999 FORMAT (/, 'Disordered Atoms with S.O.F ', A, ' 0.5', /)
99998 FORMAT ('Mu/Rho(', A, '):', 16F7.2)
99997 FORMAT (':: mu(', A, ')       =', F12.2, ' cm-1 = ', F7.3,
     1        ' mm-1')
99996 FORMAT ('N: ', A, ' : ', 7(A), 1X, 2A)
99995 FORMAT (132('-'), /, 'Sources - Cov. Radii : Manual Cambridge',
     1  ' Cryst. Data Base', /, 8X, '- Atomic Wt. : IUPAC 1993',
     2  93X, A, /, 8X,
     3  '- mu/rho     : International Tables C, table 4.2.4.2,',
     4 ' p193-199')
99994 FORMAT ('Cov.Rad(Ang):', 16F7.2)
99993 FORMAT ('Atom Weight :', 2F7.3, 14F7.2)
99992 FORMAT ('Atom Number :', 16I7)
99991 FORMAT ('Atom Types  : ', 16(4X, A, 1X))
99990 FORMAT ('Elem. Type  : ', 16(4X, A, 1X))
99989 FORMAT (30X, 102('-'), /, 9X, 'Unit Cell Weight =', F12.2,
     1 11X, 2I6, 14I5)
99988 FORMAT (/, 1X, 'Calculated Analysis (Percent) =',
     1 11X, F13.1, F6.1, 14F5.1)
99987 FORMAT (75X, 'Please Check the Derived Crystal Data.', /,
     1 24X, 'F(000) = ', F11.1, ' [', F11.2, ']', 17X,
     2 'They may be Incorrect for Disordered,', /, 75X,
     3 'Incomplete or Polymeric Structures.')
99986 FORMAT (/, A4, 'rdered Structure', 34X, 'Unit Cell Contents',
     1 ' (Based on Contents of Atom List, that may be Incomplete)', /,
     2 132('='), /, 'Resd Site  X(cen) Y(cen) Z(cen)  Mol.Wt S.O.F',
     3 '   Z', 5X, A, 4X, A, 14(3X, A))
99985 FORMAT (132('='))
99984 FORMAT (I3, A, 3F7.3, F9.2, F6.3, I4, 1X, 2F6.1, 14F5.1)
99983 FORMAT ('Analysis of Bond Distance and Angle Values',
     1 ' - Identification of Chiral Center(s) and Their (R/S)-',
     2 'Configuration (Cahn-Ingold-Prelog)', /, 132('='), /,
     3 4X, 'The Following Tests are done. Faults are Marked ',
     4 'Under Note', /, 4X, '-- V : Valency Check Fault for H, C ', /,
     5 4X, '-- S : Bond Too Short ', /, 4X, '-- A : Unusual Bond Angle',
     6 ' Values (PLEASE CHECK)', /, 132('='), /,
     7 ' *** PLEASE NOTE: R/S ASSIGNMENTS ARE TENTATIVE  ***',
     8 ' (CIP Special rules NOT Implemented)', /,
     9 ' *** See Angew.Chem.Intern. Ed. Eng.,(1966),5,385 & ',
     * '(1982),21,567 for Authoritative Details for Special Cases', /)
99982 FORMAT (/, 34X, 'Residue =', I4, /)
99981 FORMAT (/, 57X, 13('='), /, 56('*'), ' Residue =', I4, 1X,
     1 61('*'), /, 57X, 13('='), /)
99980 FORMAT (A, A, '-', 9(A), I2, 2I4, F6.1, 2F6.3, I3, I4, 1X,
     1 A3, 2X, A, 2X, 2A)
99979 FORMAT ('Atom  Label', 5X, 'Fractional Coordinates', 3X,
     1 'Radius Sp SSN  Ppar    Move Type')
99978 FORMAT (I4, 1X, A, F8.5, 2F9.5, F7.2, 2X, A, I4, F7.3, F8.3,
     1 2X, A3)
99977 FORMAT (87X, '=A.N.G.L.E.S=   =B.O.N.D.S=', /, 'Flag Label  -',
     1 ' Connected to  (May be Incomplete for Polymeric Structures)',
     2 12X, 'nra min max  Aver  min', 3X,
     3 'max nrb tnr Hyb RS Note', /, 132('-'))
99976 FORMAT ('Atom  Label  - Bonded to ')
99975 FORMAT (I4, 1X, A, ' : ', 9(A))
99974 FORMAT ('(', A, '-Rule Rounded) Coordinates of Unique',
     1 ' Residue(s) Identified.  Standard Deviations in the Last ',
     2 'Digit are in Parentheses.', /, 132('-'), /,
     3 10X, 'Site    = Site Symmetry; SSN = Site Symmetry Number; ',
     4 'SSOF = SHELX Site Occupation Factor (= S.O.F / SSN).',
     5 /, '*******   Move    = Transformation on Input Data',
     6 ': N.IJK (N = SymOp, IJK = Translation) i.e. 1.555 = nomove', /,
     7 'SYMBOLS:  Type    = D/A = Potential Donor or Acceptor atom,',
     8 ' D-H = H on Donor atom, MET = Metal.', /,
     9 '*******   El Type = AK = Alkali Metal, AE = Alkaline Earth,',
     * ' HL = Halogen, AN = Actinide, LN = Lanthanide,',
     1 ' TR = Transition Element.', /,
     2 10X, 'ARU     = Asymmetric Residue Unit encoded as sklm.nn,',
     3 ' with s = symmetry op, klm = translation, nn = residue #.', /,
     4 10X, 'RESIDUE = collection of ARU''s constituting an isolated',
     5 ' unit (= molecule, ion).', /,
     6 10X, 'FLAGS   : d = determined, c = calculated, R = riding ',
     7 'G = group', /, 132('-'))
99973 FORMAT (/, 'NOTE: Atoms preceded by > * or < indicate ',
     1 'disordered positions (SOF : < 50%, 50%, > 50%)', /)
99972 FORMAT (/, 'NOTE: A # in the Atom Label Indicates a Label that',
     1 ' was Modified to Conform with the Label Convention (A4)', /)
99971 FORMAT (132('-'), /, 'Flags Label', 9X,
     1 'Fractional Coordinates (x,y,z)', 10X,
     2 'Orthogonal Coordinates (XO,YO,ZO)', 3X, 'Site SSN*SSOF =', 4X,
     3 'S.O.F', 3X, 'Move Type', /, 132('-'))
99970 FORMAT (I3, A, 3F7.3, F9.2, F6.3, I4, 1X, 2I6, 14I5)
99969 FORMAT (/, A, /)
99968 FORMAT (15X, 9(A, 1X))
99967 FORMAT (13X, 9(A))
99966 FORMAT (1X)
99965 FORMAT (37X, 'Add Non-Int. ', 2F6.2, 14F5.2)
99963 FORMAT (':: Resd', I3, ', SOF', F6.3, ', Z', I3,  ', ', A)
99962 FORMAT ('T', A, ' *CONNSER')
99961 FORMAT ('AT', A, 2X, A, I5)
99960 FORMAT ('BO', 2I6, ' 99')
99959 FORMAT ('SAVE 3')
99958 FORMAT ('END')
99957 FORMAT ('Angstrom coordinates. - Input data multiplied by:',
     1         F15.5, //)
99956 FORMAT (/, 16X, 'Moiety_Formula = ', A, //,
     1        19X, 'Sum_Formula = ', A, //,
     2        16X, 'Formula_Weight =', F12.2, //,
     3        21X, 'Formula_Z =', I12, //,
     4        18X, 'SpaceGroup_Z =', I12,
     5        '  ===>  Z'' =', I3, ' /', I3, ' =',  F8.3)
99955 FORMAT (22X, 'mu(', A, ') =', F12.2, ' cm-1 =', F8.3, ' mm-1')
99954 FORMAT ('Scat.Fact.f0:',  16F7.3)
99953 FORMAT ('Scat.Fact.f'':', 16F7.3)
99952 FORMAT ('Scat.Fact.f":',  16F7.3)
99951 FORMAT (':: Moiety_Formula = ', A, /,
     1        ':: Sum_Formula    = ', A, /,
     2        ':: Formula_Weight = ', F11.2, /,
     3        ':: Formula_Z      = ', I11, /,
     4        ':: SpaceGroup_Z   = ', I11, /,
     5        ':: Formula_Z''     = ', F11.3)
99950 FORMAT ('::', A, ' RES =', I5, ' LNR =', I5, ' Chiral: ', A)
99949 FORMAT (/,
     1 'Note on F000: The first number is a pure electron count, the ',
     2 'second number between [] is calculated from f,f'' & f"')
99948 FORMAT (A)
99947 FORMAT (A, ' ;V', F8.1, ' Z''', F7.3, ' Dx', F6.3, ' ', A)
99946 FORMAT ('_790', 2I10, 15X, '=', /, 14X, A)
99945 FORMAT ('_', I3, 2F10.3, A)
99944 FORMAT (A, 2I10)
99943 FORMAT (A, 2F10.0)
99942 FORMAT (A, I1, 2F10.1, A)
99940 FORMAT ('NScat.Length:',  16F7.3)
99939 FORMAT (A, 2F10.4)
99938 FORMAT (A, 2F10.1, A)
99937 FORMAT (A, 2F10.2)
99936 FORMAT (A, 2F10.3)
99935 FORMAT (A, I1, 2F10.1, A)
99934 FORMAT (I4, 1X, A, F8.4, 2F9.4, F7.2, 2X, A, I4, F7.3, F8.3,
     1 2X, A3)
99933 FORMAT ('_780', 2I10)
99932 FORMAT ('_313', 2I10, A)
      END
      SUBROUTINE PLA074
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16,
     1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP22=256,NP25=99,
     2 NP29=63,NP38=125,NP39=30,NP41=200,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      CHARACTER IE3*4, ISRT*4, IPROB*4, FORMA*73, FORMB*73,
     1 FORMC*73, FORMD*157, FORME*218, FORMF*188, CPLM*1, CDUM*1
      DIMENSION ISPV(8), IPLA(7, 2)
      IDUM1 = 0
      IDUM2 = 0
      IRES1 = 0
      FORMA(1:9)     = '(     A ,'
      FORMA(10:41)   = 'F8.4,''('',I4,'')'',F8.4,''('',I4,'')'','
      FORMA(42:73)   =  FORMA(10:41)
      FORMB(1:9)     = '( ''A'',I3,'
      FORMB(10:73)   =  FORMA(10:73)
      FORMC(1:29)    = '(60X,                        '
      FORMC(30:73)   =  FORMC(8:29)//FORMC(8:29)
      FORMD(74:94)   = '1X,A,F6.3,''('',I2,'')'','
      FORMD(95:136)  =  FORMD(74:94)//FORMD(74:94)
      FORMD(137:157) = '1X,A,F6.3,''('',I2,'')'')'
      FORME(1:32)    = '(I2,'','',I2,''= '',F5.2,''('',I3,'')'','
      FORME(33:63)   = 'I4,'','',I2,''= '',F5.2,''('',I3,'')'','
      FORME(64:156)  =  FORME(33:63)//FORME(33:63)//FORME(33:63)
      FORME(157:187) =  FORME(33:63)
      FORME(188:218) = 'I4,'','',I2,''= '',F5.2,''('',I3,'')'')'
      FORMF(1:18)    = '(   3A,I2,''M =  '','
      FORMF(19:52)   = 'F6.2,''('',I2,''),'',F6.2,''('',I2,''),'','
      FORMF(53:154)  =  FORMF(19:52)//FORMF(19:52)//FORMF(19:52)
      FORMF(155:188) = 'F6.2,''('',I2,''),'',F6.2,''('',I2,''),'')'
      IF (IPR(147) .GT. 0) THEN
        CALL GEN108 (LU8, 0)
        SD   = 0.0
        NMAX = IPR(39)
        NLSPL = 0
   10   READ (LU8) MARK, IPR(12), JR, RMAT
        IF (MARK .NE. -100) THEN
          IF (MARK .LT. 0) THEN
            READ (LU8)
            GOTO 10
          ENDIF
          READ (LU8) (IATP(L4), L4 = 1, NMAX)
          NLSPL = NLSPL + 1
          IF (NLSPL .EQ. 1) THEN
            IF (IPR(41) .EQ. 0) THEN
              IE3 = 'UNIT'
            ELSE IF (IPR(41) .EQ. 1) THEN
              IE3 = 'ATWT'
            ELSE
              IE3 = 'ESD '
            ENDIF
            IF (IGBL(63) .GT. 2) THEN
              CALL PLA269 (- 15 - IPR(155) * 2)
              WRITE (LU7, 99998) IPR(579), PAR(49), PAR(76), IE3
              IF (IPR(155) .GT. 0)
     1          WRITE (LU7, 99995) IPR(217), IPR(159)
              WRITE (LU7, 99997)
            ENDIF
          ENDIF
          IF (NLSPL .GT. NP2) GOTO 170
          CALL PLA055
          DO 20 I = 1, 4
            K = I + 4
            XLS(I, NLSPL) = XPV(I)
            XLS(K, NLSPL) = XSPV(I)
            IFT = -3 + 16 * I
            CALL GEN041 (XPV(I), XSPV(I), ISPV(I), 4, NDEC, IPR(68))
            FORMA(IFT : IFT) = CHAR(ICHAR('0') + NDEC)
            CALL GEN041 (XPV(K), XSPV(K), ISPV(K), 4, NDEC, IPR(68))
            FORMB(IFT : IFT) = CHAR(ICHAR('0') + NDEC)
   20     CONTINUE
          CPLM = '#'
          IF (MARK .EQ. 1) THEN
            ISRT = 'Plan'
          ELSE IF (MARK .EQ. 2) THEN
            ISRT = 'Ring'
          ELSE IF (MARK .EQ. 3) THEN
            ISRT = 'Resd'
          ELSE IF (MARK .EQ. 4) THEN
            ISRT = 'Lspl'
            IPR(19) = IPR(19) + 1
          ELSE IF (MARK .EQ. 5) THEN
            ISRT = 'Crdn'
          ENDIF
          DO 30 I = 1, 8
            ISPV(I) = MIN (99, ISPV(I))
   30     CONTINUE
          SGREF = 0
          SDK   = 0
          NATP  = IPR(12)
          DO 50 J = 1, NATP
            IP = IATP(J)
            SGREF = SGREF + XSD(IP, 4) + XSD(IP, 5) + XSD(IP, 6)
            D = - XPV(4)
            DO 40 I = 1, 3
              D = D + XPV(I) * XXO(IP, I + 3)
   40       CONTINUE
            SDK = SDK + D**2
   50     CONTINUE
          SIGPL = 0
          IF (NATP .GT. 3) SIGPL = SQRT(SDK / (NATP - 3))
          SGREF = SQRT(SGREF / (NATP * 3))
          CHIK  = 0.0
          IF (SGREF .GT. PAR(12)) CHIK = MIN (999999.9, SDK / SGREF**2)
          IDOF  = NATP - 3
          IF (IPR(72) .NE. 0) THEN
            CALL GEN093 (IDOF, CHIK, IPROB)
          ELSE
            IPROB = '    '
          ENDIF
          IF (IGBL(63) .GT. 2) THEN
            CALL PLA269 (3)
            WRITE (LU7, 99999) NLSPL, SGREF, SIGPL, CHIK, IPROB
          ENDIF
          MLL = 0
          ISX = 0
          DO 80 II = 1, NMAX
            IATPI = MOD(IATP(II), NP1)
            CALL GEN048 (-1, IFG(IATPI), 7, IVAL)
            IF (IVAL .EQ. 1 .AND. II .GT. NATP) GOTO 70
            CALL GEN048 (-6, IFG(IATPI), 9, IRESII)
            IF (II .EQ. 1) THEN
              IRES1 = IRESII
            ELSE IF (II .GT. NATP) THEN
              IF (IRES1 .NE. IRESII .AND. II .GT. 8) GOTO 70
            ENDIF
            CALL PLA056 (XLS(1, NLSPL), IATPI, DEVMLL, SDVMLL,
     1                   ISDVML, 3, NDEC)
            IF (ABS(DEVMLL) .GT. PAR(76) .AND. II .GT. NATP) GOTO 70
            CALL PLA047 (XLAB(IATPI), NQ1, IDUM, JDUM, IPR(119),
     1                 IGBL(55), 0, 1 - IGBL(55))
            MLL              = MLL + 1
            IF (II .GT. NATP) CPLM = ' '
            NAMS(MLL, 1)     = CPLM//NQ1
            DEV(MLL)         = DEVMLL
            SDV(MLL)         = SDVMLL
            ISDV(MLL)        = MIN (99, ISDVML)
            IFT              = 61 + MLL * 21
            FORMD(IFT : IFT) = CHAR(ICHAR('0') + NDEC)
            IF (II .NE. NMAX) THEN
              IF (MLL .LT. 4) GOTO 80
            ENDIF
   60       IF (ISX .EQ. 4) THEN
              FORMD(1 : 73) = FORMB
              IF (IGBL(63) .GT. 2) THEN
                WRITE (PRBUF, FORMD) IPR(12),
     1          (XPV(I + ISX), ISPV(I + ISX), I = 1, 4),
     2           (NAMS(LL, 1)(1:7), DEV(LL), ISDV(LL), LL = 1, MLL)
                CALL PLA067 (LU7, PRBUF, 132, 1, 1)
              ENDIF
              ISX = ISX + 4
            ELSE IF (ISX .GT. 4) THEN
              IF (MLL .EQ. 0) GOTO 80
              FORMD(1 : 73) = FORMC
              IF (IGBL(63) .GT. 2) THEN
                WRITE (PRBUF, FORMD) (NAMS(LL, 1)(1:7),
     1            DEV(LL), ISDV(LL), LL = 1, MLL)
                CALL PLA067 (LU7, PRBUF, 132, 1, 1)
              ENDIF
            ELSE
              FORMD(1 : 73) = FORMA
              IF (IGBL(63) .GT. 2) THEN
                WRITE (PRBUF, FORMD) ISRT,
     1           (XPV(I + ISX), ISPV(I + ISX), I = 1, 4),
     2           (NAMS(LL, 1)(1:7), DEV(LL), ISDV(LL), LL = 1, MLL)
                CALL PLA067 (LU7, PRBUF, 132, 1, 1)
              ENDIF
              NAMS(1, 1) = '        '
              ISX = ISX + 4
            ENDIF
            MLL = 0
            GOTO 80
   70       IF (II .EQ. NMAX) GOTO 60
   80     CONTINUE
          GOTO 10
        ENDIF
        IF (NLSPL .GT. 1 .AND. IGBL(63) .GT. 0) THEN
          KB = 0
          IF (IGBL(63) .GT. 2) THEN
            CALL PLA269 (3)
            WRITE (LU7, 99996)
          ENDIF
          DO 110 I = 1, NLSPL - 1
            DO 100 J = I + 1, NLSPL
              KB = KB + 1
              DBUF(KB) = GL(5) * ACOS(MIN(ABS(XLS(1, I) * XLS(1, J) +
     1           XLS(2, I) * XLS(2, J) + XLS(3, I) * XLS(3, J)), 1.0))
              A = 0
              DO 90 K = 5, 7
                A = A + XLS(K, I)**2 + XLS(K, J)**2
   90         CONTINUE
              A = GL(5) * SQRT(A)
              CALL GEN041 (DBUF(KB), A, ISIGA, 2, NDEC, IPR(68))
              IDBUF(KB)     = MIN (99, ISIGA)
              IPLA(KB, 1) = I
              IPLA(KB, 2) = J
              IFT         = - 11 + KB * 31
              FORME(IFT : IFT) = CHAR(ICHAR('0') + NDEC)
              IF (KB .GE. 7) THEN
                IF (IGBL(63) .GT. 2) THEN
                 WRITE (PRBUF, FORME) ((IPLA(L, M), M = 1, 2),
     1             DBUF(L), IDBUF(L), L = 1, 7)
                  CALL PLA067 (LU7, PRBUF, 132, 1, 1)
                ENDIF
                KB = 0
              ENDIF
  100       CONTINUE
  110     CONTINUE
          IF (KB .GT. 0 .AND. IGBL(63) .GT. 2) THEN
            WRITE (PRBUF, FORME) ((IPLA(L, M), M = 1, 2), DBUF(L),
     1             IDBUF(L), L = 1, KB)
              CALL PLA067 (LU7, PRBUF, 132, 1, 1)
          ENDIF
        ENDIF
        IF (NLSPL .GT. 0 .AND. IGBL(63) .GT. 0) THEN
          IF (IPR(40) .GT. 0) THEN
            IF (IGBL(63) .GT. 2) THEN
              CALL PLA269 (7)
              WRITE (LU7, 99994) '>', (I, I = 1, 10)
            ENDIF
            KB       = 0
            IPR(133) = - IPR(368)
            IFIN     = -3
            N        = 0
            NEXB     = IPR(407) + 6
            NQ1(1:6) = 'Axes O'
            NQ2(1:6) = '--->a '
  120       IF (N .GE. 6) THEN
              N = N + 1
              IF (N .GT. NEXB) THEN
                CALL PLA038 (I, J, IFIN)
                IF (IFIN .EQ. 1) GOTO 170
                CDUM = '-'
              ELSE
                I = NINT(SLN(N - 6, 1))
                J = NINT(SLN(N - 6, 2))
                CALL PLA047 (XLAB(I), NQ1, IDUM1, IDUM2, IPR(119),
     1                       IGBL(55), 0, 1 - IGBL(55))
                CALL PLA047 (XLAB(J), NQ2, IDUM1, IDUM2, IPR(119),
     1                       IGBL(55), 0, 1 - IGBL(55))
                CDUM = '.'
              ENDIF
              CALL PLA227 (I, J, VECN)
              CALL PLA053 (I, J, 0, 0, D, SD, IDUM1, IDUM2, IER)
              IF (IER .NE. 0) GOTO 120
            ELSE
              N = N + 1
              IF (N .LT. 4) THEN
                NQ2(5:5) = CHAR(ICHAR('a') - 1 + N)
                D        = PAR(100 + N)
                SD       = 0.0
                DO 130 K = 1, 3
                  VECN(K) = OR(K, N) / D
  130           CONTINUE
              ELSE
                NQ2(5:6) = CHAR(ICHAR('a') - 4 + N)//'*'
                D        = PAR(109 + N)
                SD       = 0.0
                DO 140 K = 1, 3
                  VECN(K) = ROR(N - 3, K) / D
  140           CONTINUE
              ENDIF
              CDUM = ' '
            ENDIF
            IF (D .NE. 0.0) THEN
              DO 160 K = 1, NLSPL
                KB = KB + 1
                DBUF(KB) = 90.0 - ACOS(MIN(ABS(XLS(1, K) * VECN(1) +
     1          XLS(2, K) * VECN(2) + XLS(3, K) * VECN(3)), 1.0)) *
     2          GL(5)
                A = 0
                DO 150 L = 1, 3
                  A = A + XLS(L + 4, K)**2 + (VECN(L) * SD / D)**2
  150           CONTINUE
                A = GL(5) * SQRT(A)
                CALL GEN041 (DBUF(KB), A, ISIGA, 2, NDEC, IPR(68))
                IDBUF(KB) = MIN (99, ISIGA)
                IFT = 5 + KB * 17
                FORMF(IFT : IFT) = CHAR(ICHAR('0') + NDEC)
                IF (KB .GE. 10) THEN
                  K0 = K / 10 - 1
                  IF (IGBL(63) .GT. 2) THEN
                    IF (K0 .EQ. 0) THEN
                      NQ1(7:7) = CDUM
                      NQ2(7:7) = ' '
                      CPLM     = '/'
                    ENDIF
                    WRITE (PRBUF, FORMF) NQ1, NQ2, CPLM, K0,
     1                                   (DBUF(L), IDBUF(L), L = 1, 10)
                    CALL PLA067 (LU7, PRBUF, 132, 1, 1)
                    NQ1  = ' '
                    NQ2  = ' '
                    CPLM = ' '
                  ENDIF
                  KB = 0
                ENDIF
  160         CONTINUE
            ENDIF
            IF (KB .GT. 0) THEN
              K0 = NLSPL / 10
              IF (IGBL(63) .GT. 2) THEN
                IF (K0 .EQ. 0) THEN
                  NQ1(7:7) = CDUM
                  NQ2(7:7) = ' '
                  CPLM     = '/'
                ENDIF
                WRITE (PRBUF, FORMF) NQ1, NQ2, CPLM, K0,
     1                               (DBUF(L), IDBUF(L), L = 1, KB)
                CALL PLA067 (LU7, PRBUF, 132, 1, 1)
                NQ1  = '       '
                NQ2  = '       '
                CPLM = ' '
              ENDIF
              KB = 0
            ENDIF
            GOTO 120
          ENDIF
        ENDIF
      ENDIF
  170 RETURN
99999 FORMAT (132('-'), /, 'Nr', I3, 8X, 'P', 13X, 'Q', 13X, 'R', 13X,
     1 'S', 5X, 'Sigref', F7.3, 5X, 'Sigpln', F7.3, 5X, 'Chisq ', F9.1,
     2 4X, 'Pl.Hyp.', 4X, A4, /, 132('-'))
99998 FORMAT ('Automatic Search for Rings (3 to', I3, '-Membered) and',
     1 ' Planes Determined by 4 or More Connected Atoms (with',
     2 ' Deviation <', F5.2, ' Ang.)', /, 132('-'), //,
     3 'Least-Squares Planes - P*X+Q*Y+R*Z=S   ::', 2X, 'First Line',
     4 ' Orthogonal(XO,YO,ZO), Second Line Fractional(X,Y,Z)', /,
     5 36('='), 7X, 'Ring/Plan/Resd/Lspl N Indicates that the Ring/',
     6 'Plane/Residue Involves N Atoms', /, 43X, 'Sigref - R.M.S-Error',
     7 ' of the Contributing Atoms', /, '  The Deviation D of an Atom',
     8 ' with', 10X, 'Sigpln - Sqrt(Sum(j=1:N)(D(j)**2/(N-3))',/, 43X,
     9 'Chisq  - Chi-Squared = Sum(j=1:N)(D(j)**2)/Sigref**2', /,
     * '  Fractional Coordinates X,Y,Z may be', 6X, 'Pl.Hyp. - Result',
     1 ' of the Chi.Sq. Test for Planarity (See Stout & Jensen, p424)',
     2 //, 2X, 'Calculated via Substitution in',
     3 /43X,
     4 '**** - Atoms Deviating by More Than ', F3.1, ' Angstrom and',
     5 ' Hydrogen Atoms are NOT Listed', /, 2X, 'D = P*X + Q*Y + R*Z',
     6 ' - S (2nd Line)', 7X, 'Note - Weights : ', A4)
99997 FORMAT (48X, '- Deviations from planes are in Angstrom Units', /,
     1        48X, '- The Plane determining Atoms have been Marked #')
99996 FORMAT (/, '(Acute) Angles (Degrees) Between Planes ',
     1 '(Numbers I,J from List Above)', /, 132('-'))
99995 FORMAT (43X, '**** - Maximum Metal Containing Ring Size:',
     1 I6, /, 48X, '- Maximum Number of Bonds to Ring Metal:', I3)
99994 FORMAT (//, '(Acute) Angles (Degrees) Between Axes, Lines,',
     1 ' Bonds and L.S.-Plane', /, 132('-'), /, 1X,
     2 'Bond  /  Plane NM --', A, ' M', I7, 9(I11), /, 132('-'))
      END
      SUBROUTINE PLA075
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16,
     1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP25=99,
     2 NP29=63,NP38=125,NP39=30,NP41=200,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      IF (IPR(69) .NE. 0 .AND. IPR(55) .EQ. 0) THEN
        CALL GEN108 (LU8, 0)
        NRING = 0
        NHEAD = 0
   10   READ (LU8) MARK, IPR(12), JR, RMAT
        IF (MARK .NE. -100) THEN
          IF (MARK .NE. 2) THEN
            READ (LU8)
            GOTO 10
          ENDIF
          READ (LU8) (IATP(L4), L4 = 1, IPR(39))
          NRING = NRING + 1
          IF (IPR(12) .GT. 3) CALL PLA095 (NRING, NHEAD, 0)
          GOTO 10
        ENDIF
      ENDIF
      CALL GEN108 (LU8, 0)
      IF (IPR(23) .EQ. 0 .AND. IPR(64) .GT. 0 .AND. IGBL(97) .EQ. 1
     1    .AND. IGBL(63) .GT. 1) CALL PLA048
      RETURN
      END
      SUBROUTINE PLA076
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16,
     1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NPVD=40000000,
     2 NP22=256,NP23=18000,NP25=99,NP29=63,NP38=125,NP39=30,NP41=200,
     3 NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON // JNSC(2, NP23), VOID(NPVD)
      CHARACTER FORMA*126, FORMB*129
      A    = 0.0
      D    = 0.0
      SA   = 0.0
      SD   = 0.0
      ISA  = 0
      ISD  = 0
      NDEC = 0
      CALL GEN108 (LU8, 0)
      IPR(52) = 0
      IF (IPR(147) .EQ. 0) THEN
        IF (IGBL(63) .GT. 2) THEN
          CALL PLA269 (2)
          WRITE (LU7, 99985) '<', PAR(1)
        ENDIF
        WRITE (LU6, 99985) '<', PAR(1)
        GOTO 190
      ENDIF
      NMAX = IPR(39)
      NRES = IPR(75)
      NCB  = IPR(131)
      MBL  = 4
      MAL  = 3
      IF (IGBL(31) .EQ. 2) THEN
        DO 10 I = 1, NMAX
          CALL PLA047 (XLAB(I), NQ1, IDUM, JDUM, 0, IGBL(55), 0, 0)
          WRITE (LU2, 99999) NQ1(1:4), (XXO(I, J), J = 4, 6)
   10   CONTINUE
        WRITE (LU2, 99998)
        DO 20 N = 1, NCB
          FLI = VOID(IPR(298) + N * 3 - 2)
          FLJ = VOID(IPR(298) + N * 3 - 1)
          WRITE (LU2, 99997) NINT(FLI), NINT(FLJ)
   20   CONTINUE
        WRITE (LU2, 99996)
      ENDIF
      CALL PLA098 (0, 0, 0, 0.0, 0.0, 0.0, 0, 0)
      IF (IPR(6) + IPR(7) + IPR(8) .EQ. 0) GOTO 190
      IF (IGBL(63) .GT. 2) THEN
        CALL PLA269 (0)
        WRITE (LU7, 99993)
        WRITE (LU7, 99989) PAR(1), IGBL(97) * PAR(26), PAR(27)
        IF (IPR(44) .EQ. 1) WRITE (LU7, 99984) '>', '<'
        NLINE = 3 + IPR(44)
      ENDIF
      IF (PAR(107) .GT. 0.0 .AND. IGBL(63) .GT. 2) THEN
        NLINE = NLINE + 4
        WRITE (LU7, 99983) PAR(13), PAR(14)
        WRITE (LU7, 99981)
      ENDIF
      IF (IGBL(63) .GT. 2) CALL PLA269 (NLINE)
      FORMB( 1:  4)  = '(   '
      FORMB( 5: 32)  = ' A ,''- '', A ,F8.4,''('',I2,'')'''
      FORMB(33: 64)  = ',4X,'//FORMB(5:32)
      FORMB(65:129)  =  FORMB(33:64)//FORMB(33:64)//')'
      FORMA( 1:  4)  = '(   '
      FORMA( 5: 26)  = ' A ,''- '', A ,''- '', A ,'
      FORMA(27: 41)  = 'F7.2,''('',I3,'')'''
      FORMA(42: 83)  = ', 6X,'//FORMA(5:26)//FORMA(27:41)
      FORMA(84:126)  =  FORMA(42:83)//')'
      DO 180 NRSD = 1, NRES
        NDIS = 0
        KB   = 0
        IHB  = 0
        IF (NRES .GT. 1) THEN
           IPR(134) = 1
        ELSE
           IPR(134) = 0
        ENDIF
        IF (IPR(438) .EQ. 1) WRITE (LU2, 99995) NRSD
        IF (IPR(6) .NE. 0) THEN
          IPR(133) = -1
   70     IPR(133) = IPR(133) + 1
          IF (IPR(133) .GT. 1) GOTO 100
          IFIN     = -1
   80     CALL PLA038 (I, J, IFIN)
          IF (IFIN .EQ. 1) GOTO 70
          CALL GEN048 (-6, IFG(I), 9, IRESI)
          IF (IRESI .NE. NRSD) GOTO 80
          CALL GEN048 (-1, IFG(J), 7, IHJ)
          IF (IHJ .NE. IHB) THEN
            IHB = 1
            IF (KB .GT. 0) THEN
              IF (IGBL(63) .GT. 2) THEN
                WRITE (PRBUF, FORMB) ((NAMS(L, M), M = 1, 2),
     1                 DBUF(L), IDBUF(L), L = 1, KB)
                CALL PLA067 (LU7, PRBUF, 132, 1, 1)
              ENDIF
              KB = 0
            ENDIF
            IF (IGBL(63) .GT. 2) THEN
              CALL PLA269 (1)
              WRITE (LU7, 99992)
            ENDIF
          ENDIF
          CALL PLA053 (I, J, 0, 0, D, SD, ISD, NDEC, IER)
          IF (IER .NE. 0) GOTO 80
          KB        = KB + 1
          NDIS      = NDIS + 1
          CALL PLA036 (I, KB, 1, IDS1, IDUM1, IDUM2, IPR(119), IGBL(55))
          CALL PLA036 (J, KB, 2, IDS2, IDUM1, IDUM2, IPR(119), IGBL(55))
          DIFF  = 0.0
          IDS12 = IDS1 + IDS2
          CALL PLA098 (I, J, KB, D, SD, DIFF, IDS12, 1)
          DBUF(KB)  = D
          IDBUF(KB) = MIN (99, ISD)
          IFT       = -11 + 32 * KB
          FORMB(IFT : IFT) = CHAR(ICHAR('0') + NDEC)
          IFT       = -22 + 32 * KB
          FORMB(IFT : IFT) = '-'
          IF (DIFF .GT.   PAR(280)) FORMB(IFT : IFT) = '>'
          IF (DIFF .LT. - PAR(280)) FORMB(IFT : IFT) = '<'
          IF (IPR(438) .EQ. 1) THEN
            IPR(251) = IPR(251) + 1
            WRITE (LU2, 99991)
     1        (NAMS(KB, M)(2:8), M = 1, 2), D, SD
          ENDIF
          IF (NDIS .EQ. 1) THEN
             IF (IPR(134) .EQ. 1) THEN
               IF (IGBL(63) .GT. 2) THEN
                 CALL PLA269 (4)
                 WRITE (LU7, 99994) NRSD
               ENDIF
               IPR(134) = 0
             ENDIF
             IF (IGBL(63) .GT. 2) THEN
               CALL PLA269 (3)
               WRITE (LU7, 99990)
             ENDIF
          ENDIF
          IF (KB .GE. MBL) THEN
            IF (IGBL(63) .GT. 2) THEN
              WRITE (PRBUF, FORMB) ((NAMS(L, M), M = 1, 2),
     1             DBUF(L), IDBUF(L), L = 1, MBL)
              CALL PLA067 (LU7, PRBUF, 132, 1, 1)
            ENDIF
            KB = 0
          ENDIF
          GOTO 80
  100     IF (KB .GT. 0 .AND. IGBL(63) .GT. 2) THEN
            WRITE (PRBUF, FORMB) ((NAMS(L, M), M = 1, 2),
     1               DBUF(L), IDBUF(L), L = 1, KB)
            CALL PLA067 (LU7, PRBUF, 132, 1, 1)
          ENDIF
        ENDIF
        IF (IPR(7) .NE. 0) THEN
          NANG = 0
          KB   = 0
          IPR(133) = -1
  170     IPR(133) = IPR(133) + 1
          IF (IPR(133) .GT. 1) GOTO 175
          IF (IPR(133) .EQ. 1 .AND. IGBL(63) .GT. 2) THEN
            IF (KB .GT. 0) THEN
              IF (IGBL(63) .GT. 2) THEN
                WRITE (PRBUF, FORMA) ((NAMS(L, M), M = 1, 3),
     1                       DBUF(L), IDBUF(L), L = 1, KB)
                CALL PLA067 (LU7, PRBUF, 132, 1, 3)
              ENDIF
              KB = 0
            ENDIF
            CALL PLA269 (1)
            WRITE (LU7, 99992)
          ENDIF
          IFIN = -1
  160     CALL PLA039 (IAT, JAT, KAT, NRSD, A, SA, ISA, NDEC, KB, IFIN)
          IF (IFIN .EQ. 1) GOTO 170
          NANG      = NANG + 1
          KB        = KB + 1
          DBUF(KB)  = A
          IDBUF(KB) = MIN (999, ISA)
          IFT       = -12 + 42 * KB
          FORMA(IFT : IFT) = CHAR(ICHAR('0') + NDEC)
          IF (IPR(438) .EQ. 1) THEN
            IPR(252) = IPR(252) + 1
            WRITE (LU2, 99988)
     1            (NAMS(KB, M)(2:8), M = 1, 3), A, SA
          ENDIF
          IF (NAMS(KB, 2)(2:2) .EQ. 'C') THEN
            CALL GEN048 (-3, JFG(JAT), 24, JMET)
            IF (JMET .EQ. 3) THEN
              DANG = ABS (109.5 - A)
              IF (DANG .GT. 0.1) THEN
                CALL GEN048 (-1, IFG(IAT), 7, IHAT)
                NDISO = 0
                IF (NAMS(KB, 1)(1:1) .NE. ' ') NDISO = NDISO + 1
                IF (NAMS(KB, 2)(1:1) .NE. ' ') NDISO = NDISO + 1
                IF (NAMS(KB, 3)(1:1) .NE. ' ') NDISO = NDISO + 1
                IF (NDISO .LT. 2) WRITE (LU20, 99982)
     1                         IHAT, DANG, A, NAMS(KB, 2)(2:8)
              ENDIF
            ENDIF
          ENDIF
          IF (NANG .EQ. 1) THEN
            IF (IPR(134) .EQ. 1) THEN
              IF (IGBL(63) .GT. 2) THEN
                CALL PLA269 (4)
                WRITE (LU7, 99994) NRSD
              ENDIF
              IPR(134) = 0
            ENDIF
            IF (IGBL(63) .GT. 2) THEN
              CALL PLA269 (3)
              WRITE (LU7, 99987)
            ENDIF
          ENDIF
          IF (KB .GE. MAL) THEN
            IF (IGBL(63) .GT. 2) THEN
              WRITE (PRBUF, FORMA) ((NAMS(L, M), M = 1, 3),
     1               DBUF(L), IDBUF(L), L = 1, MAL)
              CALL PLA067 (LU7, PRBUF, 132, 1, 3)
            ENDIF
            KB = 0
          ENDIF
          GOTO 160
  175     IF (KB .GT. 0) THEN
            IF (IGBL(63) .GT. 2) THEN
              WRITE (PRBUF, FORMA) ((NAMS(L, M), M = 1, 3),
     1                     DBUF(L), IDBUF(L), L = 1, KB)
              CALL PLA067 (LU7, PRBUF, 132, 1, 3)
            ENDIF
            KB = 0
          ENDIF
        ENDIF
        CALL PLA032 (NRSD)
  180 CONTINUE
  190 CALL PLA098 (0, 0, 0, 0.0, 0.0, 0.0, 0, -1)
      RETURN
99999 FORMAT (A, 3X, 3F10.4)
99998 FORMAT ('END')
99997 FORMAT (I4, 1X, I4)
99996 FORMAT ('END', /, 'END')
99995 FORMAT ('RESD ', I5)
99994 FORMAT (/, 57X, 13('='), /, 56('*'), ' Residue =', I4, 1X,
     1 61('*'), /, 57X, 13('='))
99993 FORMAT ('Analysis of the IntraMolecular Geometry in Terms of',
     1 ' Unique Molecule(s)/Ions, with Bond Criterium:',
     2 ' d(i-j) < R(i) + R(j) + Tol', /, 132('-'))
99992 FORMAT (' ')
99991 FORMAT ('BOND ', 2(A, 2X), 2F8.4)
99990 FORMAT (/'Bond Lengths (Angstrom). - (Bonds are ordered on the',
     1 ' first label, left to right and  top to bottom) - ',
     2 'su in last digit in ().', /, 132('='))
99989 FORMAT ('-- Tol = ', F4.2, ' Ang. for Normal Bonds + ', F4.2,
     1        ' for (Earth)alkali-NonMetal Contacts and adjusted by ',
     2          F4.2, ' Ang. for Metal-Metal Distances')
99988 FORMAT ('ANGL ', 3(A, 2X), 2F7.2)
99987 FORMAT (/'Bond/Valence Angles (Degrees) - (Angles are ordered',
     1 ' on the middle label, left to right and top to bottom) -',
     2 ' su in last digit in ().', /, 132('='))
99985 FORMAT (/, ':: Note: No Intra-Bonds with d(I-J) ',
     1 A,' R(I) + R(J) + (Tol=', F5.2, ')')
99984 FORMAT ('-- Disordered Atoms are Indicated with ', A, ' or ', A,
     1 ' Attached to the Atom Label, indicating Major and Minor Form',
     2 ' Respectively')
99983 FORMAT ('-- The Bond Distance and Angle su''s have been',
     1 ' Incremented to Include the Effect of the Unit-cell su.',/,
     2 3X, '(Rel.Error in Dist.', F7.4, ' Ang. , Abs. Angle Error',
     3 F6.3, ' Deg.)')
99982 FORMAT ('_39', I1, 2F10.2, A)
99981 FORMAT ('-- Bonds below with ''>'' or ''<'' Substituted for',
     1 ' ''-'' have Distances that Deviate from Expected Values',
     2 '(Based on the hybridisations).', /, 132('-'))
      END
      SUBROUTINE PLA077
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118,
     1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP25=99,
     2 NP29=63,NP38=125,NP39=30,NP41=200,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9),
     1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10),
     2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10),
     3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770)
      NAT     = IPR(37)
      NMAX    = IPR(39)
      NRES    = IPR(75)
      IPR(18) = -2
      NEXB = 0
      IF (IPR(407) .GT. 0) THEN
        DO 30 I = 1, IPR(407)
          NEXB = NEXB + 1
          DO 20 J = 1, 2
            DO 10 K = 1, NMAX
              IF (SLN(I, J) .EQ. XLAB(K)) THEN
                SLN(NEXB, J) = K
                GOTO 20
              ENDIF
   10       CONTINUE
            NEXB = NEXB - 1
            GOTO 30
   20     CONTINUE
   30   CONTINUE
        IPR(407) = NEXB
      ENDIF
      IF (IPR(147) .NE. 0) THEN
        IPR(146) = 0
   40   IPR(12)  = 0
        IPR(146) = IPR(146) + 1
        IF (IPR(146) .GT. IPR(145)) GOTO 100
        NTYP = NINT(XLS(1, IPR(146)))
        IF (NTYP .GE. 0) THEN
          DO 90 I = 1, NMAX
            IATPI = NP1 + I
            XLBL  = XLAB(I)
            I1    = IPR(146)
            GOTO 60
   50       I1 = I1 + 1
            IF (XLS(1, I1) .GT. 0) GOTO 80
   60       I2 = 1
   70       I2 = I2 + 1
            IF (I2 .GT. 9) GOTO 50
            XLS12 = XLS(I2, I1)
            IF (XLS12 .GE. 0.0) THEN
              IF (ABS(XLBL - XLS12) .GT. 0.001) GOTO 70
              IPR(12) = IPR(12) + 1
              JR((I1 - IPR(146)) * 8 + I2 - 1) = I
              IATPI   = I
            ENDIF
   80       IATP(I) = IATPI
   90     CONTINUE
          IF (IPR(12) .LT. NP7) THEN
            IF (NTYP .EQ. 0) THEN
              IF (IPR(12) .GE. 2) THEN
                VARDIST = 999.0
                CALL PLA085 (0, VARDIST)
              ELSE
                WRITE (LU6, 99998)
              ENDIF
            ELSE
              IF (IPR(12) .GE. 3) THEN
                CALL PLA045 (NTYP)
              ELSE
                WRITE (LU6, 99998)
              ENDIF
            ENDIF
          ELSE
            WRITE (LU6, 99998)
          ENDIF
        ENDIF
        GOTO 40
  100   IF (IPR(10) .NE. 0 .AND. IGBL(97) .NE. 0) THEN
          IF (NMAX .GT. 250 .OR. IPR(44) .EQ. 1) THEN
            IPR(579) = MIN (IPR(219), IPR(216))
            WRITE (LU6, 99999) IPR(579)
          ENDIF
          DO 190 NR = 1, NRES
            NRING = 0
            DO 180 K = 3, IPR(579)
            NRTM = K + 1
            DO 170 J = 1, NAT
              CALL GEN048 (-6, IFG(J), 9, IRESJ)
              IF (IRESJ .NE. NR) GOTO 170
              IF (IPR(44) .GT. 0) THEN
                CALL GEN048 (-7, JFG(J), 1, IPP)
                IF (IPPR(IPP + 1, 1) .LE. IPR(222)) GOTO 170
              ENDIF
              NHAT = NINT(RCONT(IRESJ))
              IF (NHAT .LT. 5 .OR. NHAT .LT. K) GOTO 170
              LRT   = 2
              NRT   = 1
              JR(1) = J
  110         CALL GEN048 (-1, JFG(JR(NRT)), 13, IVAL)
              IF (IVAL .EQ. 1) THEN
                IF (LRT .EQ. 1) THEN
                  GOTO 120
                ELSE IF (LRT .EQ. 2) THEN
                  GOTO 170
                ENDIF
              ENDIF
              CALL GEN048 (-1, IFG(JR(NRT)), 8, IVAL)
              IF (IVAL .EQ. 1) THEN
                IF (LRT .EQ. 1) THEN
                  GOTO 120
                ELSE IF (LRT .EQ. 2) THEN
                  GOTO 170
                ENDIF
              ENDIF
              NCN(NRT) = - NINT(CON(JR(NRT), NP4))
              IF (NCN(NRT) .LT. 0) NCN(NRT) = NP4
              IF (NCN(NRT) .LT. 2) THEN
                IF (LRT .EQ. 1) THEN
                  GOTO 120
                ELSE IF (LRT .EQ. 2) THEN
                  GOTO 170
                ENDIF
              ENDIF
              CALL GEN048 (-1, IFG(JR(NRT)), 19, IVAL)
              IF (IVAL .EQ. 1) THEN
                IF (NCN(NRT) .GT. IPR(159)) THEN
                  IF (LRT .EQ. 1) THEN
                    GOTO 120
                  ELSE IF (LRT .EQ. 2) THEN
                    GOTO 170
                  ENDIF
                ENDIF
                CALL GEN048 (-4, IFG(JR(NRT)), 15, NO1)
                IF (IATPR(IEN(NO1 + 1)) .GT. 4) THEN
                  IF (LRT .EQ. 1) THEN
                    GOTO 120
                  ELSE IF (LRT .EQ. 2) THEN
                    GOTO 170
                  ENDIF
                ENDIF
              ENDIF
              LRT      = 1
              NRT      = NRT + 1
              JLN(NRT) = 0
  120         JLN(NRT) = JLN(NRT) + 1
              IF (JLN(NRT) .GT. NCN(NRT - 1)) THEN
                NRT = NRT - 1
                IF (NRT .GT. 1) GOTO 120
                GOTO 170
              ENDIF
              JR(NRT) = NINT(CON(JR(NRT - 1), JLN(NRT)))
              IF (JR(NRT) .GE. JR(1)) THEN
                IF (NRT .GT. 3) THEN
                  IF (NRT .EQ. NRTM) THEN
                    NRTM2 = 1
                    ELSE
                      NRTM2 = NRT - 2
                    ENDIF
                    DO 130 I = 2, NRTM2
                      IF (JR(NRT) .EQ. JR(I)) GOTO 120
  130               CONTINUE
                  ENDIF
                  IF (JR(NRT) .EQ. JR(1)) THEN
                    IF (NRT .LT. NRTM) GOTO 120
                    DO 140 I = 2, NRT
                      CALL GEN048 (-1, IFG(JR(I)), 19, IVAL)
                      IF (IVAL * (NRT - 1) .GT. IPR(217)) GOTO 120
  140               CONTINUE
                    IF (JR(2) .LE. JR(NRT - 1)) THEN
                      DO 150 I = 1, NMAX
                        IATP(I) = NP1 + I
  150                 CONTINUE
                      IPR(12) = NRT - 1
                      IPOP = 1000
                      DO 160 I = 1, IPR(12)
                        IF (IPR(44) .GT. 0) THEN
                          CALL GEN048 (-7, JFG(JR(I)), 1, IPP)
                          IPAR = IPPR(IPP + 1, 1)
                          IF (IPAR .NE. IPOP) THEN
                            IF (IPOP .LT. 1000 .AND. IPAR .LT. 1000 .OR.
     1                          IPOP .LE. IPR(222) .OR.
     2                          IPAR .LE. IPR(222)) THEN
                              GOTO 120
                            ELSE
                              IF (IPOP .EQ. 1000) IPOP = IPAR
                            ENDIF
                          ENDIF
                        ENDIF
                        IATP(JR(I)) = JR(I)
  160                 CONTINUE
                      IF (K .GT. 3 .OR.
     1                   (K .EQ. 3 .AND. IPR(69) .LE. 10)) THEN
                        CALL PLA045 (2)
                        NRING = NRING + 1
                        IF (NRING .GE. IPR(302) + IPR(592) * 1000) THEN
                          IPR(579) = K
                          WRITE (LU6, 99999) K
                          GOTO 190
                        ENDIF
                      ELSE
                        GOTO 180
                      ENDIF
                    ENDIF
                    IF (NRT .EQ. NRTM) NRT = NRT - 1
                    GOTO 120
                  ENDIF
                  IF (NRT .LT. NRTM) GOTO 110
                ENDIF
                GOTO 120
  170         CONTINUE
  180       CONTINUE
  190     CONTINUE
        ELSE
          IF (IGBL(99) .EQ. 1) WRITE (LU6, 99997)
        ENDIF
        IF (IPR(11) .NE. 0 .AND. IGBL(97) .NE. 0) THEN
          DO 220 JAT = 1, NAT
            CALL GEN048 (-1, IFG(JAT), 19, IVAL)
            IF (IVAL .EQ. 1) THEN
              IF (NINT(CON(JAT, NP4)) .EQ. -4) THEN
                DO 200 I = 1, NMAX
                  IATP(I) = NP1 + I
  200           CONTINUE
                DO 210 I = 1, 4
                  IATP(I) = NINT(CON(JAT, I))
  210           CONTINUE
                IPR(12) = 4
                CALL PLA045 (5)
              ENDIF
            ENDIF
  220     CONTINUE
          DO 240 NRS = 1, NRES
            IPR(12) = 0
            DO 230 I = 1, NMAX
              IATPI = NP1 + I
              CALL GEN048 (-6, IFG(I), 9, IVAL)
              IF (IVAL .EQ. NRS) THEN
                CALL GEN048 (-1, IFG(I), 7, IVAL)
                IF (IVAL .EQ. 0) THEN
                  IPR(12) = IPR(12) + 1
                  IATPI   = I
                ENDIF
              ENDIF
              IATP(I) = IATPI
  230       CONTINUE
            IF (IPR(12) .GT. 5) CALL PLA045 (3)
  240     CONTINUE
        ENDIF
        IF (IPR(9) .NE. 0) THEN
          DO 350 JAT = 1, NMAX
            IF (IPR(44) .GT. 0) THEN
              CALL GEN048 (-7, JFG(JAT), 1, IPP)
              IF (IPPR(IPP + 1, 1) .LT. 1000) GOTO 350
            ENDIF
            CALL GEN048 (-1, IFG(JAT), 7, IVAL)
            IF (IVAL .GT. 0) GOTO 350
            CALL GEN048 (-1, IFG(JAT), 5, IVAL)
            IF (IVAL .GT. 0) GOTO 350
            CALL GEN048(-6, IFG(JAT), 9, IRESJ)
            NC = - NINT(CON(JAT, NP4))
            IF (NC .LT. 0) NC = NP4
            IF (NC .GT. 1) THEN
              N = NC - 1
              DO 340 KI = 1, N
                IAT = NINT(CON(JAT, KI))
                IF (IPR(44) .GT. 0) THEN
                  CALL GEN048 (-7, JFG(IAT), 1, IPP)
                  IF (IPPR(IPP + 1, 1) .LT. 1000) GOTO 340
                ENDIF
                CALL GEN048 (-1, IFG(IAT), 7, IVAL)
                IF (IVAL .EQ. 0) THEN
                  J1 = KI + 1
                  DO 330 KJ = J1, NC
                    KAT = NINT(CON(JAT, KJ))
                    CALL GEN048 (-1, IFG(KAT), 7, IVAL)
                    IF (IVAL .EQ. 0) THEN
                      DO 250 I = 1, NMAX
                        IATP(I) = NP1 + I
  250                 CONTINUE
                      IATP(IAT) = IAT
                      IATP(JAT) = JAT
                      IATP(KAT) = KAT
                      IPR(12)   = 3
  260                 CALL PLA054 (0)
                      I = 0
  270                 I = I + 1
                      IF (I .GT. NMAX) GOTO 320
                      IF (IPR(44) .GT. 0) THEN
                        CALL GEN048 (-7, JFG(I), 1, IPP)
                        IF (IPPR(IPP + 1, 1) .LT. 1000) GOTO 270
                      ENDIF
                      IF (IATP(I) .LT. NP1) GOTO 270
                      CALL GEN048 (-6, IFG(I), 9, IRESI)
                      IF (IRESI .NE. IRESJ) GOTO 270
                      CALL GEN048 (-1, IFG(I), 7, IVAL)
                      IF (IVAL .GT. 0) GOTO 270
                      NCI = - NINT(CON(I, NP4))
                      IF (NCI .LT. 0) NCI = NP4
                      IF (NCI .EQ. 0) GOTO 270
                      UITW = - XPV(4)
                      DO 280 J = 1, 3
                        UITW = UITW + XPV(J) * XXO(I, J + 3)
  280                 CONTINUE
                      IF (ABS(UITW) .GT. PAR(49)) GOTO 270
                      DO 300 J = 1, NMAX
                        IF (IATP(J) .GT. NP1) GOTO 300
                        DO 290 IJ = 1, NCI
                          IF (NINT(CON(I, IJ)) .EQ. J) GOTO 310
  290                   CONTINUE
  300                 CONTINUE
                      GOTO 270
  310                 IPR(12) = IPR(12) + 1
                      IATP(I) = I
                      GOTO 260
  320                 IF (IPR(12) .GT. 3) CALL PLA045 (1)
                    ENDIF
  330             CONTINUE
                ENDIF
  340         CONTINUE
            ENDIF
  350     CONTINUE
        ENDIF
      ENDIF
      WRITE (LU8) -100, 0, JR, RMAT
      IPR(86) = 1
      RETURN
99999 FORMAT (/, ':: Maximum Ring-size has been Reset to:', I3, /)
99998 FORMAT ('W: User-specified Ring/Plane/Fit/Line not accepted', /)
99997 FORMAT (/, ':: Note: Ring-search Suppressed in Inorganic Mode.',
     1        /)
      END
      SUBROUTINE PLA078 (I)
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16,
     1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP25=99,NP29=63,
     2 NP38=125,NP39=30,NP41=200,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      CALL GEN048 (-1, IFG(I), 2, IVAL)
      IF (IGBL(30) .EQ. 1) THEN
        ITRNS = 1555
      ELSE IF (IVAL .EQ. 1) THEN
        ITRNS = IATP(I)
      ELSE
        KAT  = IPR(39) + IPR(24) + 1
        KAT1 = KAT + 1
        IF (KAT1 .GT. NP1) THEN
          IPR(2) = 1
          ITRNS   = 1555
          GOTO 40
        ENDIF
        ITRNS = IABS(IATP(I))
        IF (ITRNS .NE. 0) THEN
          IGBL(30) = -1
          IPR(50) = IPR(50) + 1
          J       = ITRNS / 1000
          FN(1)   = J
          J       = ITRNS - J * 1000
          ITR(1)  = J / 100
          J       = J - ITR(1) * 100
          ITR(2)  = J / 10
          ITR(3)  = J - ITR(2) * 10
          DO 20 J = 1, 3
            FN(J + 1) = ITR(J) - 5
   20     CONTINUE
        ELSE
          FN(1) = 1.0
          CALL GEN074 (FN, 0.0, 2, 4)
        ENDIF
        ITRNS = NINT(FN(1) * 1000 + 555)
        DO 30 L = 1, 3
          XXO(KAT, L) = XXO(I, L)
          XSD(KAT, L) = XSD(I, L)
          ITR(L)      = NINT(FN(L + 1))
          IF (IABS(ITR(L)) .GT. 4) IPR(2) = 17
          ITRNS       = ITRNS + ITR(L) * 10**(3 - L)
   30   CONTINUE
        IF (ITRNS .NE. 1555) THEN
          WRITE (LU4) 5, XLAB(I), (FN(L), L = 1, 8)
          IPR(54) = NINT(FN(1))
          CALL PLA059 (KAT, I)
        ENDIF
      ENDIF
   40 IATP(I) = ITRNS
      CALL GEN048 (1, IFG(I), 2, 1)
      RETURN
      END
      SUBROUTINE PLA079 (XNQNR)
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118,
     1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP22=256,
     2 NP25=99,NP29=63,NP36=1000,NP38=125,NP39=30,NP41=200,NP45=2048,
     3 NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /Q/ ICL, IFL(NP17)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9),
     1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10),
     2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10),
     3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770)
      COMMON /ALIASES/ ALAB(NP36), BLAB(NP36)
      CHARACTER ALAB*7, BLAB*7
      COMMON /LMEM/ ATYC, ATYO, ATYN
      IENR = 0
      ISU  = 0
      NAT  = IPR(39)
      IF (NAT .GE. NP1) THEN
        IPR(2) = 1
      ELSE
        IF (NAT .EQ. 0) THEN
          IGBL(59) = 0
          ATYC     = 0.0
          ATYO     = 0.0
          ATYN     = 0.0
        ENDIF
        NATP1 = NAT + 1
        KL   = IPR(220)
        KN   = IPR(221)
        MODE = 100
        GL25 = MAX (0.05, GL(25))
        IF (IGBL(8) .EQ. 3) THEN
          IF (KN .NE. 10) THEN
            IF (IGBL(3) .EQ. 1) THEN
              WRITE (LU20, 99990) '_170', 1, 1, IFL(2)
            ELSE
              IPR(2) = 51
            ENDIF
            GOTO 250
          ENDIF
          IF (NAT .EQ. 0) THEN
            IF (IPR(319) .EQ. 0) THEN
              WRITE (LU20, 99994) '_124', 1.0, 1.0, CCIF(7)(1:7)
              IF (SPGRNM(1)(1:1) .EQ. ' ') THEN
                WRITE (LU20, 99994) '_121', 1.0, 1.0, CCIF(6)
                CALL SGSM (IDM, 0, XJX, 0, 1, IERR)
                IPR(48) = 1
              ENDIF
            ENDIF
          ENDIF
        ENDIF
        NSYM = IPR(48)
        IPR(107) = 0
        IF (NAT .EQ. 0) THEN
          IF (IGBL(8) .EQ. 3 .AND. PAR(101) .LT. 1.1) THEN
            IPR(2) = 58
            GOTO 250
          ENDIF
          IPR(463) = 128
          IPR(464) = 512000
          IPR(465) = 4000
          IPR(466) = IPR(465) * 2
        ENDIF
        NQ1 = IFL(IPR(473))
        IF (IGBL(8) .EQ. 2) THEN
          IF (IPR(538) .NE. 0) THEN
            N = INDEX (NQ1, ' ')
            IF (N .NE. 0) THEN
              IF (IPR(538) .LT. 10) THEN
                WRITE (NQ1(N:N + 1), 99992) IPR(538)
              ELSE
                WRITE (NQ1(N:N + 2), 99991) IPR(538)
              ENDIF
            ENDIF
            IFL(IPR(473)) = NQ1
          ENDIF
        ENDIF
        NQ2 = NQ1
        NQ4 = NQ1
        LOP = 0
   10   CALL PLA046 (MODE, NQ1, IENM1, LBB, LBC, LBD, XNQNR, YNQNR,
     1               NIEN)
        IF (NIEN .LT. 0) THEN
          IF (NIEN .EQ. -12) THEN
            NQ1     = NQ2
            IPR(2) = 57
            GOTO 250
          ENDIF
          IF (IABS(IGBL(8)) .EQ. 3) THEN
            IF (KL .EQ. 3) THEN
              LOP = LOP + 1
              IF (LOP .EQ. 1) THEN
                NQ1 = IFL(3)
              ELSE
                MODE     = 100
                NQ1      = IFL(2)
                IPR(220) = 2
                KL       = 2
                GOTO 10
              ENDIF
            ELSE
              LOP = LOP + 1
              IF (ICHAR(IFL(2)(2:2)) .GE. 48 .AND.
     1            ICHAR(IFL(2)(2:2)) .LE. 57 .AND.
     2            LOP .LT. 3) THEN
                NQ1 = IFL(2)(1:1)//'      '
              ELSE
                IPR(2) = 3
                GOTO 250
              ENDIF
            ENDIF
          ELSE IF (IABS(IGBL(8)) .EQ. 2) THEN
            IF (IAN .GT. 0 .AND. NINT(FN(1)) .LE. IAN) THEN
              NQ1 = LMT(NINT(FN(1)), 1)//'     '
            ELSE
              IPR(2) = 46
              GOTO 250
            ENDIF
          ELSE IF (IGBL(8) .EQ. 1) THEN
          ELSE
            IPR(2) = 3
            GOTO 250
          ENDIF
          IF (NQ1(1:1) .EQ. ' ') THEN
            NQ1(1:1) = NQ1(2:2)
            NQ1(2:4) = '999'
          ELSE IF (NQ1(2:2) .EQ. ' ') THEN
            NQ1(2:4) = '999'
          ELSE
            NQ1(3:4) = '99'
          ENDIF
          MODE = 99
          GOTO 10
        ENDIF
        IF (MODE .EQ. 100) THEN
          DO 20 K = 1, NAT
            IF (NINT(CON(K, 2)) .EQ. NINT(XNQNR)) THEN
              WRITE (LU20, 99994) '_070', 1.0, 1.0, NQ2
              MODE = 99
              GOTO 10
            ENDIF
   20     CONTINUE
        ENDIF
        IF (IABS (IGBL(8)) .EQ. 2) THEN
          IPR(32) = MAX (IPR(32), 1)
          IF (KN .EQ. 7) KN = 6
          IF (KN .NE. 6 .AND. KN .NE. 11) THEN
            IPR(498) = IPR(498) + 1
            IF (KN .EQ. 4) FN(5) = 11.0
            FN(6) = PAR(30)
            KN    = 6
          ENDIF
          IENR = NINT(FN(1))
          DO 30 K = 2, KN
            YY = FN(K)
            IF (ABS(YY) .GT. 5.0) THEN
              I  = NINT(ABS(YY) * 0.1)
              IF (I .EQ. 1) THEN
                RPI = 1.0
              ELSE
                RPI = RP(I)
              ENDIF
              SJ = SIGN(0.5, YY)
              IF (I .NE. 1 .AND. I .GT. IPR(109)) THEN
                IPR(2) = 9
                GOTO 250
              ENDIF
              YY = (YY - I * SJ * 20.0) * (RPI + SJ - 0.5)
            ENDIF
            FN(K - 1) = YY
   30     CONTINUE
          KN = KN - 1
          IF (KN .EQ. 5) THEN
            FN(9)  = FN(5)
            FN(10) = 0.0
            KN     = 10
          ELSE
            IPR(32) = 2
            DO 40 K = 1, 6
              FN(15 - K) = FN(11 - K)
   40       CONTINUE
            CALL GEN074 (FN, 0.0, 15, 20)
            KN = 20
          ENDIF
          CALL GEN074 (FN, 0.0, 5, 8)
          IF (FN(4) .LT. 0.0001) THEN
            IPR(100) = IPR(100) + 1
            IPR(471) = IPR(471) + 1
            IPR(2)   = 0
            GOTO 250
          ENDIF
        ELSE
          IF (KN .EQ. 5) KN = 3
          KNP1 = KN + 1
          DO 70 K = KNP1, 9
            FN(K) = 0.0
   70     CONTINUE
          IF (KN .EQ. 6) THEN
            DO 80 K = 1, 4
              FN(9 - K) = FN(8 - K)
   80       CONTINUE
            FN(4) = 0.0
          ENDIF
          IF (IPR(23) .NE. 0) THEN
            ISU = 0
            DO 90 K = 1, 3
              FN(K)     = FN(K)     * PAR(11)
              FN(K + 4) = FN(K + 4) * PAR(11)
              IF (FN(K + 4) .GT. 0) ISU = 1
   90       CONTINUE
          ENDIF
        ENDIF
        IF (IPR(23) .EQ. 0) CALL PLA080
        CALL GEN002 (1, TM2, FN, XJX, XLNG)
        DO 100 K = 1, 3
          DUMA(K) = 0.0
          FNK4    = FN(K + 4)
          IF (FNK4 .GT. 0.0) IPR(72) = 1
          IF (FNK4 .LT. 0.0) FNK4    = 0.0
          FN(K + 4) = FNK4**2
  100   CONTINUE
        DO 120 K = 1, 3
          IF (IPR(23) .EQ. 0) THEN
            DO 110 L = 1, 3
              DUMA(K) = DUMA(K) + TM2(K, L)**2 * FN(L + 4)
  110       CONTINUE
          ELSE
            DUMA(K) = FN(K + 4)
          ENDIF
  120   CONTINUE
        DO 130 K = 1, 3
          XJX(K)              = XJX(K) + SHFT(K)
          FN(K)               = XJX(K)
          FN(K + 4)           = SQRT(DUMA(K))
          XJX(K + 3)          = 0.0
          CON(NATP1, K + 2)   = FN(K)
          CON(NATP1, K + 5)   = DUMA(K)
          CON(NAT + 2, K + 2) = 0.0
  130   CONTINUE
        IPR94 = 0
        IBORH = 0
        IF (IEN(NIEN + 1) .EQ. 1 .OR. IEN(NIEN + 1) .EQ. 33 .OR.
     1      IEN(NIEN + 1) .EQ. 113) THEN
          IPR94 = 1
          IBORH = 1
        ENDIF
        IF (IEN(NIEN + 1) .EQ. 20) IBORH = 1
        MULT = IPR(23)
        IF (MULT .EQ. 0) THEN
          XJX(10) = 0.0
          CALL SGSM (IDM, 0, XJX, LU6, 19, IERR)
          IF (IGBL(8) .EQ. 3) THEN
            IF (XJX(10) .NE. 1.0) THEN
              FN(4) = FN(4) * XJX(10)
            ELSE
              IF (IPR94 .EQ. 0 .AND. IGBL(94) .EQ. 0) THEN
                IF (FN(5) .LE. 0.0) WRITE (LU20, 99994)
     1                    '_161', 1.0, 1.0, NQ2(1:7)
                IF (FN(6) .LE. 0.0) WRITE (LU20, 99994)
     1                    '_162', 1.0, 1.0, NQ2(1:7)
                IF (FN(7) .LE. 0.0) WRITE (LU20, 99994)
     1                    '_163', 1.0, 1.0, NQ2(1:7)
              ENDIF
            ENDIF
          ENDIF
          IF (IPR94 .EQ. 0) THEN
            ISU = 1
            IF (XJX(10) .EQ. 1.0 .AND. FN(5) .LE. 0.0 .AND.
     1          FN(6) .LE. 0.0 .AND. FN(7) .LE. 0.0) ISU = 0
          ELSE
            ISU = 0
            IF (FN(5) .GT. 0.0 .OR. FN(6) .GT. 0.0 .OR. FN(7) .GT. 0)
     1              ISU = 1
          ENDIF
          IF (ABS(FN(4) / XJX(10) - 0.5) .GT. 0.4998) THEN
            DO 190 J = 1, NSYM
              JSYM = J
              CALL SGSM (ICL, JSYM, XJX, LU7, 3, IERR)
              DO 180 I = 1, NATP1
                VERS = 0.0
                DO 150 K = 1, 3
                  DUMA(K) = CON(I, K + 2) - XJX(K + 6)
  140             IF (DUMA(K) .GT. 0.5) THEN
                    XJX(K + 6) = XJX(K + 6) + 1.0
                    DUMA(K)    = DUMA(K)    - 1.0
                    GOTO 140
                  ENDIF
                  IF (DUMA(K) .LE. - 0.5) THEN
                    XJX(K + 6) = XJX(K + 6) - 1.0
                    DUMA(K)    = DUMA(K)    + 1.0
                    GOTO 140
                  ENDIF
  150           CONTINUE
                VERS = SQRT(PAR(129) * DUMA(1) ** 2
     1                    + PAR(130) * DUMA(2) ** 2
     2                    + PAR(131) * DUMA(3) ** 2
     3                    + PAR(132) * DUMA(1) * DUMA(2)
     4                    + PAR(133) * DUMA(1) * DUMA(3)
     5                    + PAR(134) * DUMA(2) * DUMA(3))
                IF (VERS .LT. GL25) THEN
                  CALL GEN048 (-1, IFG(I), 7, IHAT)
                  IF (IHAT .EQ. 1 .OR. IPR94 .EQ. 1) THEN
                    IF (VERS .GT. PAR(22)) GOTO 180
                  ENDIF
                  IF (NQ2(1:1) .NE. 'Q' .AND. VERS .GT. PAR(22))
     1               GOTO 180
                  IF (I .NE. NATP1) THEN
                    CALL PLA047 (CON(I, 2), NQ2, IENM, JDUM, IPR(119),
     1                           IGBL(55), 0, 0)
                    IPR(100) = IPR(100) + 1
                    WRITE (LU6, 99997) NQ1, VERS, NQ2
                    IF (VERS .LT. PAR(22)) THEN
                      IF (IEN(IENM1) .EQ. JDUM) THEN
                        DO 160 K = 1, 3
                          FN(K) = (CON(I, K + 2) + XJX(K + 6)) / 2.0
                          CON(I, K + 2) = FN(K)
 160                    CONTINUE
                        FN(4) = - 1.0
                        WRITE (LU4) 11, CON(I, 2), (FN(K), K = 1, 8)
                      ENDIF
                      WRITE (LU6, 99996) NQ1, VERS, NQ2,
     1                                  (FN(K), K = 1, 3)
                    ENDIF
                    WRITE (LU20, 99993) '_310', VERS, VERS, NQ1, NQ2
                    IPR(471) = IPR(471) + 1
                    IPR(107) = 1
                    IPR(2)   = 0
                    GOTO 250
                  ELSE
                    IF (MULT .EQ. 0 .OR. IABS(IGBL(8)) .NE. 2 .OR.
     1                             IABS(IGBL(8)) .NE. 3) THEN
                      MULT = MULT + 1
                      DO 170 K = 1, 3
                        CON(NAT + 2, K + 2) = CON(NAT + 2, K + 2)
     1                                      + XJX(K + 6)
  170                 CONTINUE
                    ENDIF
                  ENDIF
                ENDIF
  180         CONTINUE
  190       CONTINUE
          ELSE
            MULT = NINT(1.0 / XJX(10))
          ENDIF
        ENDIF
        CALL PLA047 (XNQNR, NQ2, MN, JDUM, 0, IGBL(55), 0, 0)
        DO 200 K = 1, 7
          IF (NQ2(K : K) .EQ. '#') THEN
            IF (IGBL(71) .EQ. 1) THEN
              WRITE (LU6, 99999)
              IPR(119) = 0
              IPR(350) = 0
            ENDIF
            ALAB(IGBL(71)) = IFL(IPR(473))
            BLAB(IGBL(71)) = NQ2
            M  = INDEX (IFL(IPR(473)), ' ')
            IF (M .GT. 6) THEN
              WRITE (LU6, 99995) IFL(IPR(473)), NQ2
            ELSE
              WRITE (LU6, 99998) IFL(IPR(473)), NQ2
            ENDIF
            GOTO 210
          ENDIF
  200   CONTINUE
  210   IF (IPR(39) .EQ. 0) IPPR(1, 3) = NSYM
        IPR(39)         = IPR(39) + 1
        IPR(37)         = IPR(39)
        CON(IPR(39), 2) = XNQNR
        IF (IABS(IGBL(8)) .EQ. 2) THEN
          CON(IPR(39), NP4 - 1) = IENR
          CON(IPR(39), NP4)     = FN(4)
        ENDIF
        IF (IPR(37) .EQ. 1) THEN
          IF (IGBL(8) .EQ. 3 .AND. IGBL(94) .EQ. 0) THEN
            IF (CCIF(7)(1:11) .NE. CCIF(8)(1:11) .AND.
     1          IPR(319) * IPR(318) .EQ. 1) THEN
              IDM = CCIF(8)
              CALL GEN047 (IDM, 1, 20)
              NQ2 = IDM(1:7)
              IF (NQ2(1:1) .EQ. ' ') NQ2(1:1) = '?'
              IDM = CCIF(6)
              CALL GEN047 (IDM, 1, 20)
              WRITE (LU20, 99994) '_120', 1.0, 1.0, IDM(1:7), NQ2
            ENDIF
          ENDIF
        ENDIF
        IFG(IPR(39)) = 0
        JFG(IPR(39)) = 0
        IF (IABS(IGBL(8)) .EQ. 3) THEN
          IF (FN(21) .NE. 0.0) THEN
            CALL GEN048 (1, JFG(IPR(39)), 29, 1)
            IF ((FN(5) .GT. 0.0 .OR. FN(6) .GT. 0.0 .OR.
     1          FN(7) .GT. 0.0) .AND. FN(22) .NE. 3.0)
     1        WRITE (LU20, 99994) '_166', 1.0, 1.0, IFL(IPR(473))
          ENDIF
          IF (FN(22) .NE. 0.0) THEN
            IF (FN(22) .EQ. 1.0) CALL GEN048 (1, JFG(IPR(39)), 30, 1)
            IF (FN(22) .EQ. 2.0) CALL GEN048 (1, JFG(IPR(39)), 31, 1)
            IF (IPR94 .EQ. 0 .AND. FN(22) .EQ. 1.0)
     1          IPR(164) = IPR(164) + 1
          ENDIF
        ENDIF
        IF (MULT .GT. 1) CALL GEN048 (1, IFG(IPR(39)), 6 , 1)
        CALL GEN048 (4, IFG(IPR(39)), 15, NIEN)
        IF (IPR(165) .GT. 0) THEN
          ITRNS    = IPR(165)
          IPR(165) = 0
        ELSE
          ITRNS    = IPR(95)
        ENDIF
        IATP(IPR(39)) = ITRNS
        CALL GEN048 (1, IFG(IPR(39)), 7, IPR94)
        CALL GEN048 (1, JFG(IPR(39)), 13, IBORH)
        IF (IATPR(IEN(NIEN + 1)) .GT. 0) THEN
          CALL GEN048 (1, IFG(IPR(39)), 19, 1)
          IPR(155) = 1
          PAR(85)  = 2
          PAR(87)  = 1
        ENDIF
        IF (IGBL(99) .NE. 1) THEN
          NORGA = 0
          DO 215 K = 1, NIEN + 1
            IF (IEN(K) .EQ. 1) NORGA = NORGA + 1
            IF (IEN(K) .EQ. 2) NORGA = NORGA + 1
  215     CONTINUE
          IF (NORGA .EQ. 2) IGBL(97) = 1
        ENDIF
        NPOP   = IPR(65)
        POPPAR = FN(4) * MULT
        IF (IABS(IGBL(8)) .EQ. 3) THEN
          IF (POPPAR .GT. 1.001)
     1        WRITE (LU20, 99994) '_075', 1.0, POPPAR, IFL(IPR(473))
          IF (POPPAR .LT. 1.0 .AND.
     1        ABS(MULT * POPPAR - 1.0) .LT. 0.01) THEN
              WRITE (LU20, 99993) '_076', 0.5, POPPAR, IFL(IPR(473))
          ENDIF
        ENDIF
        IF (IGBL(8) .EQ. 3) THEN
          IF (MOD (NINT(YNQNR), 40) .EQ. 0) THEN
            N   = IEN(IENM1)
            IF (N .EQ. 2) THEN
              IF (YNQNR .GT. ATYC) THEN
                ATYC = YNQNR
              ELSE
                IPR(545) = IPR(545) + 1
                IF (IPR(545) .EQ. 1) THEN
                  WRITE (LU20, 99994) '_795', 1.0, 1.0, NQ1
                ENDIF
              ENDIF
            ELSE IF (N .EQ. 3) THEN
              IF (YNQNR .GT. ATYO) THEN
                ATYO = YNQNR
              ELSE
                IPR(546) = IPR(546) + 1
                IF (IPR(546) .EQ. 1) THEN
                  WRITE (LU20, 99994) '_796', 1.0, 1.0, NQ1
                ENDIF
              ENDIF
            ELSE IF (N .EQ. 4) THEN
              IF (YNQNR .GT. ATYN) THEN
                ATYN = YNQNR
              ELSE
                IPR(547) = IPR(547) + 1
                IF (IPR(547) .EQ. 1) THEN
                  WRITE (LU20, 99994) '_797', 1.0, 1.0, NQ1
                ENDIF
              ENDIF
            ENDIF
          ENDIF
        ENDIF
        FN(4) = MIN (1.0, POPPAR)
        FN(8) = FN(8) * MULT
        IF (FN(4) .LT. PAR(12)) FN(4) = 1.0
        IF (FN(8) .LT. 0.0) FN(8) = 0.0
        IF (FN(4) .LT. 0.5) YNQNR = YNQNR + 150 * 4000
        CON(IPR(39), 1) = YNQNR
        INTPOP = NINT(FN(4) * 1000.0)
        IF (INTPOP .EQ. 500) THEN
          IF (FN(4) .GT. 0.5) INTPOP = 501
          IF (FN(4) .LT. 0.5) INTPOP = 499
        ENDIF
        IPPR(NPOP + 1, 1) = INTPOP
        IPPR(NPOP + 1, 2) = NINT(FN(8) * 1000.0)
        IPPR(NPOP + 1, 3) = NSYM  / MULT
        FN(4)             = FN(4) / MULT
        FN(8)             = FN(8) / MULT
        IF (IPR94 .EQ. 0) PAR(386) = PAR(386) + NSYM * FN(4)
        PAR(388) = PAR(388) + NSYM * FN(4) * ATWT(IEN(NIEN + 1))
        PAR(387) = PAR(388) / (PAR(98) * 0.60221)
        IF (MULT .GT. 1 .AND. INTPOP .EQ. 1000) THEN
          DO 220 K = 1, 3
            CON(NAT + 1, K + 2) = CON(NAT + 2, K + 2) / MULT
            FN(K) = CON(NAT + 1, K + 2)
  220     CONTINUE
        ENDIF
        MULT = NSYM / MULT
        IF (MOD(IPPR(NPOP + 1, 1), 1000) .NE. 0) THEN
          IPR(44) = 1
          IF (IPR94 .EQ. 0) IPR(43) = 1
        ENDIF
        DO 230 I = 1, NPOP
          IF (IPPR(I, 3) .EQ. IPPR(NPOP + 1, 3) .AND.
     1        IPPR(I, 1) .EQ. IPPR(NPOP + 1, 1)) THEN
            IPOP = I - 1
            GOTO 240
          ENDIF
  230   CONTINUE
        IPOP = NPOP
        IF (IPOP .GT. 127) THEN
          IPR(71) = IPR(71) + 1
        ELSE
          IPR(65) = IPR(65) + 1
        ENDIF
  240   CALL GEN048 (7, JFG(IPR(39)), 1, IPOP)
        CALL GEN048 (1, JFG(IPR(39)), 10, ISU)
        CALL GEN048 (-1, IFG(IPR(39)), 7, JHAT)
        IF (JHAT .EQ. 1) IPR(564) = IPR(564) + ISU
        CALL GEN048 (1, JFG(IPR(39)), 11, 1)
        WRITE (LU4) 1, XNQNR, (FN(K), K = 1, 8)
        IF (IABS(IGBL(8)) .EQ. 2) THEN
          IF (FN(9) .LT. 0.0) THEN
            FN(9) = - FN(9) * PAR(61)
          ELSE
            IF (IPR94 .EQ. 0) PAR(61) = FN(9)
          ENDIF
        ENDIF
        IF (KN .EQ. 10) WRITE (LU4) 4, XNQNR, (FN(K), K = 9, 16)
        IF (KN .EQ. 20) THEN
          CALL GEN048 (1, IFG(IPR(39)), 4, 1)
          FN(9)  = FN(9)  * PAR(135)**2
          FN(10) = FN(10) * PAR(136)**2
          FN(11) = FN(11) * PAR(137)**2
          FN(12) = FN(12) * PAR(136) * PAR(137)
          FN(13) = FN(13) * PAR(135) * PAR(137)
          FN(14) = FN(14) * PAR(135) * PAR(136)
          CALL GEN025 (DUMV, FN(9), -1)
          CALL GEN001 (1, TM2, DUMV, UIJ)
          CALL GEN025 (UIJ, FN(9), 1)
          FN(9)  = FN(9)  / PAR(113)**2
          FN(10) = FN(10) / PAR(114)**2
          FN(11) = FN(11) / PAR(115)**2
          FN(12) = FN(12) / (PAR(114) * PAR(115))
          FN(13) = FN(13) / (PAR(113) * PAR(115))
          FN(14) = FN(14) / (PAR(113) * PAR(114))
          IF (IABS(IGBL(8)) .EQ. 2 .AND. IPR94 .EQ. 0) THEN
            CALL GEN025 (UIJ, FN(9), -1)
            CALL PLA210 (PAR, OR, UIJ, UIJC, DUMA, DUMV, PAR(61))
          ENDIF
          WRITE (LU4) 2, XNQNR, (FN(K), K =  9, 16)
          WRITE (LU4) 3, XNQNR, (FN(K), K = 15, 22)
        ENDIF
      ENDIF
  250 RETURN
99999 FORMAT (//, ':: Changed not acceptable ATOM labels on',
     1 ' INPUT with substituted ALIASES', /, 71('-'))
99998 FORMAT (':: ', A, ' ======> ', A)
99997 FORMAT (':: ATOM ', A, ' DELETED from INPUT STREAM, ',
     1          F5.2, ' Ang. From ', A)
99996 FORMAT (':: ATOM ', A, ' at', F5.2, ' Ang. from ', A,
     1        ' - New Av Pos:', 3F8.4)
99995 FORMAT (':: ', A, ' ======> ', A, 2X, 'NO BACKSUBSTITUTION')
99994 FORMAT (A, 2F10.0, 2A)
99993 FORMAT (A, 2F10.3, 2A)
99992 FORMAT ('_', I1)
99991 FORMAT ('_', I2)
99990 FORMAT (A, 2I10, 2A)
      END
      SUBROUTINE PLA080
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16,
     1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP22=256,NP25=99,
     2 NP29=63,NP38=125,NP39=30,NP41=200,NP45=2048,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /Q/ ICL, IFL(NP17)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      DIMENSION KAX(3)
      IF (IPR(39) .EQ. 0) THEN
        IF (IPR(48) .GT. 48) THEN
          IPR(129) = 9
          PAR(42)  = 10.0
          WRITE (LU6, 99999)
        ENDIF
        IF (PAR(101) .LT. 1.1) THEN
          IGBL(52) = 1
          IPR(23)  = 1
          IPR(34)  = 1
          IPR(35)  = 2
          IPR(36)  = 3
        ELSE
          CALL SGSM (ICL, 0, XJX, LU7, 18, IERR)
          SPGRNM(1) = ICL(1:26)
          SPGRNM(4) = ICL(15:26)
          IF (IGBL(8) .EQ. 3 .AND. IPR(522) .EQ. 0) THEN
            IF (SPGRNM(1)(1:1) .EQ. ' ')
     1          WRITE (LU20, 99998) '_123', 1, 1
          ENDIF
          KRSYST = ICL(27:38)
          LAUEGR = ICL(39:43)
          IF (ICL(72:72) .EQ. 'C') CHSG = 'Chiral'
          CALL GEN020 (-1, SPGRNM(1), 16, 26)
          IPR(202) = NINT(XJX(1))
          IPR(241) = NINT(XJX(7))
          IPR(242) = NINT(XJX(8))
          IPR(255) = NINT(XJX(4))
          IPR(256) = NINT(XJX(6))
          IPR(257) = NINT(XJX(5))
          IPR(258) = NINT(XJX(3))
          IPR(259) = NINT(XJX(2))
          IF (ICL(12:12) .EQ. 'h') THEN
            PAR(261) = 120.0
          ELSE
            PAR(261) = 90.0
          ENDIF
        ENDIF
        IF (PAR(104) .EQ. 0.0) PAR(104) = 90.0
        IF (PAR(105) .EQ. 0.0) PAR(105) = 90.0
        IF (PAR(106) .EQ. 0.0) PAR(106) = PAR(261)
        PAR(13) = 0
        PAR(14) = 0
        IF (INDEX (KRSYST, 'Trigonal') .NE. 0) THEN
          IF (ABS(PAR(106) - PAR(105)) .LT. 0.5) THEN
            KRSYST = 'Rhombohedral'
          ENDIF
        ENDIF
        IF (IGBL(94) .EQ. 0 .AND. IPR(522) .EQ. 0) THEN
          IF (PAR(107) / PAR(101) .LT. 0.00001) WRITE (LU20, 99998)
     1      '_141', 1, NINT(PAR(107) * 100000)
          IF (INDEX (KRSYST, 'Triclinic') .NE. 0) THEN
            IF (PAR(108) / PAR(102) .LT. 0.00001)
     1        WRITE (LU20, 99998) '_142', 1, NINT(PAR(108) * 100000)
            IF (PAR(109) / PAR(103) .LT. 0.00001)
     1        WRITE (LU20, 99998) '_143', 1, NINT(PAR(109) * 100000)
            IF (PAR(110) .LT. 0.0005)
     1        WRITE (LU20, 99998) '_144', 1, NINT(PAR(110) * 10000)
            IF (PAR(111) .LT. 0.0005)
     1        WRITE (LU20, 99998) '_145', 1, NINT(PAR(111) * 10000)
            IF (PAR(112) .LT. 0.0005)
     1        WRITE (LU20, 99998) '_146', 1, NINT(PAR(112) * 10000)
            IF (PAR(101) .GT. PAR(102) .OR. PAR(102) .GT. PAR(103))
     1        WRITE (LU20, 99998) '_156', 1, 1
          ELSE IF (INDEX (KRSYST, 'Monoclinic') .NE. 0) THEN
            N90 = 0
            IF (PAR(104) .NE. 90.0) N90 = N90 + 1
            IF (PAR(105) .NE. 90.0) N90 = N90 + 1
            IF (PAR(106) .NE. 90.0) N90 = N90 + 1
            IF (N90 .GT. 1) WRITE (LU20, 99998) '_138', 1, 1
            IF (ZSPG(2:4) .EQ. '112') THEN
              MSET = 3
            ELSE
              MSET = 2
            ENDIF
            IF (PAR(108) /PAR(102) .LT. 0.00001)
     1        WRITE (LU20, 99998) '_142', 1, NINT(PAR(108) * 100000)
            IF (PAR(109) /PAR(103) .LT. 0.00001)
     1        WRITE (LU20, 99998) '_143', 1, NINT(PAR(109) * 100000)
            IF (MSET .EQ. 2) THEN
              IF (PAR(111) .LT. 0.0005)
     1          WRITE (LU20, 99998) '_145', 1, NINT(PAR(111) * 10000)
            ELSE IF (MSET .EQ. 3) THEN
              IF (PAR(112) .LT. 0.0005)
     1          WRITE (LU20, 99998) '_146', 1, NINT(PAR(111) * 10000)
            ENDIF
            IF (PAR(105) .LT. 90.0)
     1        WRITE (LU20, 99997) '_157', 1.0, PAR(105)
            IF (PAR(104) .EQ. 90.0 .AND. PAR(105) .NE. 90.0 .AND.
     1          PAR(106) .EQ. 90.0) THEN
              IF (PAR(110) .NE. 0.0 .OR. PAR(112) .NE. 0.0)
     1            WRITE (LU20, 99998) '_147', 1, 1
            ENDIF
          ELSE IF (INDEX (KRSYST, 'Orthorhombic') .NE. 0) THEN
            IF (PAR(104) .NE. 90.0 .OR. PAR(105) .NE. 90.0 .OR.
     1          PAR(106) .NE. 90.0) WRITE (LU20, 99998) '_137', 1, 1
            IF (PAR(108) / PAR(102) .LT. 0.00001)
     1        WRITE (LU20, 99998) '_142', 1, NINT(PAR(108) * 100000)
            IF (PAR(109) / PAR(103) .LT. 0.00001)
     1        WRITE (LU20, 99998) '_143', 1, NINT(PAR(109) * 100000)
            IF (PAR(110) .NE. 0.0 .OR. PAR(111) .NE. 0.0 .OR.
     1          PAR(112) .NE. 0.0) WRITE (LU20, 99998) '_147', 1, 1
          ELSE IF (INDEX (KRSYST, 'Tetragonal') .NE. 0) THEN
            IF (PAR(101) .NE. PAR(102))
     1          WRITE (LU20, 99998) '_135', 1, 1
            IF (PAR(109) / PAR(103) .LT. 0.00001)
     1        WRITE (LU20, 99998) '_143', 1, NINT(PAR(109) * 100000)
            IF (PAR(104) .NE. 90.0 .OR. PAR(105) .NE. 90.0 .OR.
     1          PAR(106) .NE. 90.0) WRITE (LU20, 99998) '_136', 1, 1
            IF (PAR(110) .NE. 0.0 .OR. PAR(111) .NE. 0.0 .OR.
     1          PAR(112) .NE. 0.0) WRITE (LU20, 99998) '_147', 1, 1
          ELSE IF (INDEX (KRSYST, 'Rhombohedral') .NE. 0) THEN
            IF (PAR(101) .NE. PAR(102) .OR. PAR(101) .NE. PAR(103))
     1          WRITE (LU20, 99998) '_139', 1, 1
            IF (PAR(104) .NE. PAR(105) .OR. PAR(104) .NE. PAR(106))
     1          WRITE (LU20, 99998) '_140', 1, 1
            IF (PAR(110) .LT. 0.0005)
     1          WRITE (LU20, 99998) '_144', 1, NINT(PAR(110) * 10000)
          ELSE IF (INDEX (KRSYST, 'Trigonal') .NE. 0 .OR.
     1             INDEX (KRSYST, 'Hexagonal') .NE. 0) THEN
            IF (PAR(101) .NE. PAR(102))
     1          WRITE (LU20, 99998) '_132', 1, 1
            IF (PAR(104) .NE. 90.0 .OR. PAR(105) .NE. 90.0)
     1          WRITE (LU20, 99998) '_133', 1, 1
            IF (PAR(106) .NE. 120.0)
     1          WRITE (LU20, 99998) '_134', 1, 1
            IF (PAR(109) / PAR(103) .LT. 0.00001)
     1          WRITE (LU20, 99998) '_143', 1, NINT(PAR(109) * 100000)
          ELSE IF (INDEX (KRSYST, 'Cubic') .NE. 0) THEN
            IF (PAR(101) .NE. PAR(102) .OR. PAR(101) .NE. PAR(103))
     1          WRITE (LU20, 99998) '_130', 1, 1
            IF (PAR(104) .NE. 90.0 .OR. PAR(105) .NE. 90.0 .OR.
     1          PAR(106) .NE. 90.0) WRITE (LU20, 99998) '_131', 1, 1
            IF (PAR(110) .NE. 0.0 .OR. PAR(111) .NE. 0.0 .OR.
     1          PAR(112) .NE. 0.0) WRITE (LU20, 99998) '_147', 1, 1
          ENDIF
        ENDIF
        CALL GEN026 (1, RAA, PAR(101), GL(5))
        CALL GEN026 (-1, RAA, PAR(241), GL(5))
        CALL GEN003 (RAA, RBB, DET, 0)
        IF (DET .LT. 0.0) STOP 'CANNOT INVERT METRICAL MATRIX'
        CALL GEN026 (-1, RBB, PAR(135), GL(5))
        CALL GEN025 (RBB, PAR(391), 1)
        CALL GEN001 (1, TM1, RAA, AA)
        CALL GEN003 (AA, BB, DET, 0)
        IF (DET .LT. 0.0) STOP 'CANNOT INVERT METRICAL MATRIX'
        PAR(98) = SQRT(DET)
        DO 10 I = 1, 3
          PAR(128 + I) = AA(I, I)
          PAR(112 + I) = SQRT(BB(I, I))
          PAR(190 + I) = BB(I, I)
   10   CONTINUE
        PAR(194) = BB(2, 3)
        PAR(195) = BB(1, 3)
        PAR(196) = BB(1, 2)
        PAR(132) = AA(1, 2) * 2.0
        PAR(133) = AA(1, 3) * 2.0
        PAR(134) = AA(2, 3) * 2.0
        CALL GEN026 (-1, AA, PAR(101), GL(5))
        CALL GEN067 (TM1, PAR(241), PAR(101), PAR(107), PAR(107))
        CALL GEN066 (1, PAR(101), PAR(107), SPGRNM(1)(12:12))
        DO 50 I = 1, 3
          CALL GEN041 (PAR(100 + I), PAR(106 + I), IPR(280 + I), 5,
     1         IPR(286 + I), IPR(68))
          CALL GEN041 (PAR(103 + I), PAR(109 + I), IPR(283 + I), 4,
     1         IPR(289 + I), IPR(68))
   50   CONTINUE
        DO 60 I = 1, 3
          R = PAR(106 + I) / PAR(100 + I)
          IF (R .GT. PAR(13)) PAR(13) = R
          IF (PAR(109 + I) .GT. PAR(14)) PAR(14) = PAR(109 + I)
   60   CONTINUE
        DO 70 I = 1, 3
          V4(I) = COS(PAR(103 + I) / GL(5))
          IF (ABS(V4(I)) .LT. 1E-6) V4(I) = 0.0
          V3(I) = SIN(PAR(103 + I) / GL(5))
   70   CONTINUE
        CALL GEN068 (PAR(101), PAR(98), PAR(107), PAR(21))
        CALL GEN041 (PAR(98), PAR(21), IPR(293), 2, IPR(294), IPR(68))
        XDUM = 100.0 * ABS (PAR(164) - PAR(98)) / PAR(98)
        IF (IPR(522) .EQ. 0) THEN
          IF (XDUM .GT. 0.01 .AND. IGBL(94) .EQ. 0)
     1        WRITE (LU20, 99997) '_150', XDUM, PAR(164)
          IF (PAR(327) .GT. 0.0 .AND. PAR(21) .GT. 0.0) THEN
            IF (PAR(21) / PAR(327) .GT. 1.1 .OR.
     1          PAR(327) / PAR(21) .GT. 1.1) THEN
                      WRITE (LU20, 99998) '_152', 1, 1
            ENDIF
          ENDIF
        ENDIF
        PAR(116) = (V4(2) * V4(3) - V4(1)) / (V3(2) * V3(3))
        PAR(117) = (V4(1) * V4(3) - V4(2)) / (V3(1) * V3(3))
        PAR(118) = (V4(1) * V4(2) - V4(3)) / (V3(1) * V3(2))
        DO 100 K = 16, 18
          PAR(103 + K) = SQRT(1.0 - PAR(100 + K)**2)
  100   CONTINUE
        CALL GEN044 (PAR(101), OR)
        CALL GEN003 (OR, ROR, DET, 0)
        IF (DET .LT. 0.0) STOP 'CANNOT INVERT OR MATRIX'
        DO 110 I = 1, 3
          KAX(I) = NINT(PAR(100 + I) * 10.0) * 10 + I
  110   CONTINUE
        CALL GEN022 (KAX, 1, 3)
        DO 120 I = 1, 3
          K = KAX(4 - I) / 10
          IPR(33 + I) = KAX(4 - I) - K * 10
  120   CONTINUE
        IPR(185) = IPR(36)
        IPR(186) = IPR(35)
        IPR(187) = IPR(34)
        CALL GEN108 (LU4, 0)
        IF (IPR(23) .EQ. 0) THEN
          NEWLAT(1) = 0
          CALL PLA087 (1)
        ENDIF
        IPR(522) = 1
      ENDIF
99999 FORMAT (':: Maximum number of allowed residues reduced:',
     1        ' Round ARU to 0.1 units!', /)
99998 FORMAT (A, 2I10)
99997 FORMAT (A, 2F10.2)
      RETURN
      END
      SUBROUTINE PLA081 (LOC, XM1, XM2, XM3)
      PARAMETER (NP12=600,NP13=500,NP17=99,NP38=125,NP39=30)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      DIMENSION XJX(12)
      CHARACTER ICLX*1
      IPR(2) = 0
      ISW    = 9
      M1     = NINT(XM1 * PAR(42))
      CALL GEN098 (M1, PAR(42), MS1, MT11, MT12, MT13, MR3)
      XJX(1) = MS1
      XJX(2) = MT11
      XJX(3) = MT12
      XJX(4) = MT13
      M2     = NINT(XM2 * PAR(42))
      IF (M2 .NE. 0) THEN
        ISW    = 8
        CALL GEN098 (M2, PAR(42), MS2, MT21, MT22, MT23, MR3)
        XJX(5) = MS2
        XJX(6) = MT21
        XJX(7) = MT22
        XJX(8) = MT23
      ENDIF
      CALL SGSM (ICLX, 0, XJX, LU6, ISW, IERR)
      DO 10 I = 10, 12
        IF (ABS(XJX(I)) .GT. 4.1) THEN
          WRITE (LU6, 99999) LOC, XM1, XM2, (XJX(I), J = 10, 12)
          IF (IGBL(63) .GT. 0)
     1    WRITE (LU7, 99999) LOC, XM1, XM2, (XJX(I), J = 10, 12)
          WRITE (LU20, 99998) '_804', 1, 1
          IPR(150) = 1
          IPR(210) = 0
          GOTO 20
        ENDIF
   10 CONTINUE
      XM3  = (((XJX(9) * 10 + XJX(10)) * 10 + XJX(11)) * 10 + XJX(12))
      XM3 = NINT(XM3) + 555 + FLOAT(MR3) / PAR(42)
   20 RETURN
99999 FORMAT (':: ARU-Pack Problem at Loc:', I2, 5F10.2, /,
     1        ':: IPR(210) Reset to ZERO i.e. no SQUEEZE etc.')
99998 FORMAT (A, 2I10)
      END
      SUBROUTINE PLA082
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16,
     1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP22=256,NP25=99,
     2 NP29=63,NP38=125,NP39=30,NP41=200,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      DIMENSION DHX(3, 37), DUMVA(3, 3), DUMVB(3, 3), EWA(3), EWB(3),
     1 V2A(3), V2B(3), IANG(3, 3)
      COMMON /PAGENM/ PAGET, PAGEIND(25)
      CHARACTER PAGET*8, PAGEIND*8
      IF (IPR(23) .EQ. 1) GOTO 230
      NX   = 0
      NVEC = 0
      NMAX = IPR(39)
      NRES = IPR(75)
      PAGET = 'NONSYM'
      CALL GEN101 (2, NVEC, DHX)
      DO 30 I = 1, NRES
        CALL PLA083 (I, DUMVA, EWA, V2A, WHTA, NATA, NATTA, IDETA)
        IF (NATA .GT. 0) THEN
          NX = NX + 1
          IF (NX .EQ. 1) THEN
            IF (IGBL(63) .GT. 0) THEN
              CALL PLA269 (0)
              WRITE (LU7, 99999)
              WRITE (LU7, 99991)
            ENDIF
          ENDIF
          DO 20 J = 1, 3
            DO 10 K = 1, 3
              ANG = 0.0
              DO 1 L = 1, 3
                ANG = ANG + DUMVA(L, J) * OR(L, K) / PAR(100 + K)
    1         CONTINUE
              IF (ANG .GT.  1.0) ANG =  1.0
              IF (ANG .LT. -1.0) ANG = -1.0
              IANG(J, K) = NINT(ACOS(ANG) * GL(5))
   10       CONTINUE
   20     CONTINUE
          II = I * IDETA
          IF (IGBL(63) .GT. 0) THEN
            WRITE (LU7, 99987) II, (XXO(NMAX + I, K), K = 1, 3),
     1        (DUMVA(I0, 1), I0 = 1, 3), NINT(EWA(1)), ABS(V2A(1)),
     2        (IANG(1, I0), I0 = 1, 3)
            WRITE (LU7, 99986) (XXO(NMAX + I, K), K = 4, 6),
     1        (DUMVA(I0, 2), I0 = 1, 3), NINT(EWA(2)), ABS(V2A(2)),
     2        (IANG(2, I0), I0 = 1, 3)
            WRITE (LU7, 99985) WHTA, (DUMVA(I0, 3), I0 = 1, 3),
     1        NINT(EWA(3)), ABS(V2A(3)), (IANG(3, I0), I0 = 1, 3)
          ENDIF
        ENDIF
   30 CONTINUE
      IF (NX .GT. 1) THEN
        DO 50 I = 1, NMAX
          CALL GEN048 (-6, IFG(I), 9, IRES)
          DIST = 0.0
          DO 40 J = 4, 6
            DIST = DIST + (XXO(NMAX + IRES, J) - XXO(I, J))**2
   40     CONTINUE
          IATC(I) = I
          DATC(I) = SQRT(DIST)
   50   CONTINUE
        CALL GEN013 (DATC, IATC, 1, NMAX)
        IF (NRES .GT. 1) THEN
          DO 220 IRES = 1, NRES - 1
            CALL PLA083 (IRES, DUMVA, EWA, V2A, WHTA, NATA, NATTA,
     1                   IDETA)
            IF (NATA .EQ. 0) GOTO 220
            II = IRES * IDETA
            DO 210 JRES = IRES + 1, NRES
              CALL PLA083 (JRES, DUMVB, EWB, V2B, WHTB, NATB, NATTB,
     1                     IDETB)
              IF (NATB .EQ. 0) GOTO 210
              JJ = JRES * IDETB
              IF (ABS (WHTB - WHTA) .LT. 0.1 .AND.
     1          NATTA .EQ. NATTB) THEN
                IDETR = IDETA * IDETB
                CALL GEN005 (DUMVA, QM)
                CALL GEN004 (DUMVB, QM, UIJ)
                UIJSUM = (UIJ(1, 1) + UIJ(2, 2) + UIJ(3, 3)) * IDETR
                DO 60 K = 4, 6
                  V2(K - 3) = (XXO(NMAX + JRES, K)
     1                      +  XXO(NMAX + IRES, K)) / 2.0
                  V3(K - 3) =  XXO(NMAX + JRES, K)
     1                      -  XXO(NMAX + IRES, K)
   60           CONTINUE
                IF (UIJSUM .LT. 2.999) THEN
                  CALL GEN074 (V1, 0.0, 1, 3)
                  DO 90 I1 = 1, 3
                    J1 = MOD(I1, 3) + 1
                    DO 80 K1 = 1, 3
                      V4(K1) = UIJ(K1, I1) * IDETR
                      V5(K1) = UIJ(K1, J1) * IDETR
   80               CONTINUE
                    V4(I1) = V4(I1) - 1
                    V5(J1) = V5(J1) - 1
                    CALL GEN008 (V4, V5, V6, 1)
                    IF (GEN009 (V1, V6) .GE. 0.0) THEN
                      CALL GEN015 (V1, V6, V1)
                    ELSE
                      CALL GEN016 (V1, V6, V1)
                    ENDIF
   90             CONTINUE
                  XX = GEN017 (V1)
                  ANGMAX = 99999.0
                  DO 100 I = 1, 37
                    CALL GEN002 (-2, ROR, DHX(1, I), V8, XLNG)
                    CALL GEN008 (V8, V1, V5, -1)
                    IF (V5(1) .LT. ANGMAX) THEN
                      ANGMAX = V5(1)
                      V6(1) = DHX(1, I)
                      V6(2) = DHX(2, I)
                      V6(3) = DHX(3, I)
                    ENDIF
  100             CONTINUE
                  ANGMAX = ABS(ASIN(SQRT(ANGMAX)) * GL(5))
                  ANGMAX = MIN (ANGMAX, 180 - ANGMAX)
                  WRITE (LU6, 99989) (V6(I), I = 1, 3), ANGMAX
                  IF (IGBL(63) .GT. 0) THEN
                    CALL PLA269 (0)
                    CALL PLA269 (3)
                    WRITE (LU7, 99989) (V6(I), I = 1, 3), ANGMAX
                  ENDIF
                  DO 110 I1 = 1, 3
                    PAT(I1, 3) = V1(I1)
  110             CONTINUE
                  XX = SQRT(V1(1)**2 + V1(2)**2)
                  IF (XX .GT. 0.0001) THEN
                    PAT(1, 1) =   V1(2) / XX
                    PAT(2, 1) = - V1(1) / XX
                    PAT(3, 1) =   0.0
                  ELSE
                    PAT(1, 1) = 0.0
                    PAT(2, 1) = 1.0
                    PAT(3, 1) = 0.0
                  ENDIF
                  CALL GEN008 (PAT(1, 3), PAT(1, 1), PAT(1, 2), 1)
                  CALL GEN005 (PAT, PAT)
                  CALL GEN004 (PAT, UIJ, UIJC)
                  CALL GEN005 (PAT, PAT)
                  CALL GEN004 (UIJC, PAT, UIJC)
                  V1(4) = (ATAN2((UIJC(2, 1) - UIJC(1, 2)) * IDETR,
     1              (UIJC(1, 1) + UIJC(2, 2)) * IDETR)) * GL(5)
                  CALL GEN002 (1, ROR, V1, V4, DUM)
                  V4MX = MAX (ABS(V4(1)), ABS(V4(2)), ABS(V4(3)))
                  DO 120 K = 1, 3
                    V4(K) = V4(K) / V4MX
  120             CONTINUE
                  IF (IDETR .GT. 0) THEN
                    GLIDEA = GEN009 (V1, V3)
                    WRITE (LU6, 99996) II, JJ,
     1                (V4(I2), I2 = 1, 3), V1(4), GLIDEA
                    IF (IGBL(63) .GT. 0) THEN
                      CALL PLA269 (4)
                      WRITE (LU7, 99990)
                      WRITE (LU7, 99996) II, JJ,
     1                    (V4(I2), I2 = 1, 3), V1(4), GLIDEA
                    ENDIF
                  ELSE
                    WRITE (LU6, 99994) II, JJ,
     1                (V4(I2), I2 = 1, 3), V1(4)
                    IF (IGBL(63) .GT. 0) THEN
                      CALL PLA269 (4)
                      WRITE (LU7, 99990)
                      WRITE (LU7, 99994) II, JJ,
     1                  (V4(I2), I2 = 1, 3), V1(4)
                    ENDIF
                    CALL GEN008 (V1, V3, V8, 1)
                    CALL GEN008 (V8, V1, V5, 1)
                    GLIDEB = GEN009 (V5, V3)
                    CALL GEN002 (1, ROR, V5, V6, DUM)
                    V6MX = MAX (ABS(V6(1)), ABS(V6(2)), ABS(V6(3)))
                    DO 130 K = 1, 3
                      V6(K) = V6(K) / V6MX
  130               CONTINUE
                    WRITE (LU6, 99995) II, JJ,
     1                  (V6(I2), I2 = 1, 3), GLIDEB
                    IF (IGBL(63) .GT. 0) THEN
                      CALL PLA269 (1)
                      WRITE (LU7, 99995) II, JJ, (V6(I2), I2 = 1, 3),
     1                                 GLIDEB
                    ENDIF
                  ENDIF
                ELSE
                  IF (IDETR .LT. 0) THEN
                    CALL GEN002 (1, ROR, V2, V8, DUM)
                    WRITE (LU6, 99998) II, JJ, (V8(K), K = 1, 3)
                    IF (IGBL(63) .GT. 0) THEN
                      CALL PLA269 (4)
                      WRITE (LU7, 99990)
                      WRITE (LU7, 99998) II, JJ, (V8(K), K = 1, 3)
                    ENDIF
                  ELSE
                    CALL GEN002 (1, ROR, V3, V8, DUM)
                    V8MX = MAX (ABS(V8(1)), ABS(V8(2)), ABS(V8(3)))
                    DO 140 K = 1, 3
                      V8(K) = V8(K) / V8MX
  140               CONTINUE
                    WRITE (LU6, 99997) II , JJ, (V8(K), K = 1, 3)
                    IF (IGBL(63) .GT. 0) THEN
                      CALL PLA269 (4)
                      WRITE (LU7, 99990)
                      WRITE (LU7, 99997) II , JJ, (V8(K), K = 1, 3)
                    ENDIF
                  ENDIF
                ENDIF
                VARDIST = 0.0
                NVAR    = 0
                IPR(12) = 0
                DO 150 L = 1, NMAX
                  IATC(L) = IABS(IATC(L))
  150           CONTINUE
                DO 200 L0 = 1, NMAX
                  L = IATC(L0)
                  IF (L .GT. 0) THEN
                    CALL GEN048 (-6, IFG(L), 9, IRESL)
                    IF (IRESL .EQ. IRES) THEN
                      CALL GEN048 (-1, IFG(L), 7, IVL)
                      IF (IVL .EQ. 0) THEN
                        DO 160 I = 1, 3
                          V6(I) = XXO(L, I + 3)
     1                          - XXO(NMAX + IRES, I + 3)
  160                   CONTINUE
                        CALL GEN002 (1, UIJ, V6, V8, DUM)
                        DO 170 I = 1, 3
                          V8(I) = V8(I) + XXO(NMAX + IRES, I + 3)
  170                   CONTINUE
                        CALL GEN015 (V8, V3, V8)
                        DISTMN = 99999.0
                        MDIST  = 0
                        CALL PLA047 (XLAB(L), NQ1, IDUM, IENR1, 0,
     1                               IGBL(55), 0, 0)
                        CALL GEN048 (-10, JFG(L), 14, LBN1)
                        DO 190 M0 = 1, NMAX
                          M = IATC(M0)
                          IF (M .GT. 0) THEN
                            CALL GEN048 (-6, IFG(M), 9, IRESM)
                            IF (IRESM .EQ. JRES) THEN
                              CALL PLA047 (XLAB(M), NQ2, IDUM, IENR2, 0,
     1                                     IGBL(55), 0, 0)
                              IF (IENR1 .EQ. IENR2) THEN
                                CALL GEN048 (-1, IFG(M), 7, IVL)
                                IF (IVL .EQ. 0) THEN
                                  CALL GEN048 (-10, JFG(M), 14, LBN2)
                                  IF (LBN2 .EQ. LBN1) THEN
                                    DO 180 I = 1, 3
                                      V6(I) = XXO(M, I + 3)
  180                               CONTINUE
                                    CALL GEN016 (V8, V6, V5)
                                    DIST = SQRT(GEN009 (V5, V5))
                                    IF (DIST .LT. DISTMN) THEN
                                      DISTMN = DIST
                                      MDIST  = M0
                                    ENDIF
                                  ENDIF
                                ENDIF
                              ENDIF
                            ENDIF
                          ENDIF
  190                   CONTINUE
                        M0 = MDIST
                        IF (M0 .EQ. 0) GOTO 200
                        MDIST  = IATC(M0)
                        JCA(L) = MDIST
                        IATC(M0) = - IATC(M0)
                        JR(IPR(12) + 1) = L
                        JR(IPR(12) + 2) = MDIST
                        IPR(12)         = IPR(12) + 2
                        VARDIST         = VARDIST + DISTMN**2
                        NVAR            = NVAR    + 1
                        IF (IGBL(63) .GT. 0) THEN
                          CALL PLA047 (XLAB(MDIST), NQ2, IDUM, IENR2, 0,
     1                                 IGBL(55), 0, 0)
                          IF (NVAR .EQ. 1) THEN
                            CALL PLA269 (5)
                            WRITE (LU7, 99992)
                          ENDIF
                          CALL PLA269 (1)
                          WRITE (LU7, 99993)
     1                         NQ1, (V8(J), J = 1, 3), DATC(L0),
     2                      NQ2, (XXO(MDIST, J + 3), J = 1, 3),
     3                      DATC(M0), DISTMN, LBN1
                        ENDIF
                      ENDIF
                    ENDIF
                  ENDIF
  200           CONTINUE
                IF (NVAR .NE. 0) THEN
                  VARDIST = SQRT(VARDIST / NVAR)
                  WRITE (LU6, 99988) VARDIST
                  IF (IGBL(63) .GT. 0) THEN
                    CALL PLA269 (2)
                    WRITE (LU7, 99988) VARDIST
                  ENDIF
                ELSE
                  VARDIST = 999.0
                ENDIF
C * QUATERNION-FIT
                IF (IGBL(63) .GT. 0 .AND. NVAR .GT. 5) THEN
                  CALL PLA085 (0, VARDIST)
                  WRITE (LU6, 99977)
                  CALL PLA269 (3)
                  WRITE (LU7, 99977)
                  IF (VARDIST .LT. 0.5) CALL PLA084 (IRES, JRES)
                ENDIF
              ENDIF
  210       CONTINUE
  220     CONTINUE
        ENDIF
      ENDIF
  230 RETURN
99999 FORMAT ('NONSYM Search for Additional (Non)Crystallographic',
     1  ' Symmetry between Residues (Experimental)', /, 132('='), //,
     2  '- Residue numbers with opposite signs indicate ',
     3  'potential enantiomeric pairs', /,
     4  '- Hydrogen atoms omitted from the analysis', /,
     5  '- Residues with more than 6 atoms are analysed only', /)
99998 FORMAT (':: Inversion at  :', 2I5, '   ', 3F7.3)
99997 FORMAT (':: Translation   :', 2I5, '   ', 3F7.3)
99996 FORMAT (':: Rotation      :', 2I5, '  [', 3F7.3, ']', F8.2, F8.3)
99995 FORMAT (':: GlidePlane    :', 2I5, '  [', 3F7.3, ']', 8X,   F8.3)
99994 FORMAT (':: Rota-Inversion:', 2I5, '  [', 3F7.3, ']', F8.2)
99993 FORMAT (A, 3F7.3, F6.2, 2X, A, 3F7.3, F6.2, F10.3, I5)
99992 FORMAT (/, 'Comparison of Orthogonal Coordinates of Transformed',
     1        ' Residue #I with those of Residue #J', /, 132('='), /,
     2        'Atom I', 6X, 'XI', 5X, 'YI', 5X, 'ZI', 4X, 'RI', 2X,
     3        'Atom J', 6X, 'XJ', 5X, 'YJ', 5X, 'ZJ', 4X, 'RJ', 1X,
     4        'Dist(Ang)  Tnr', /, 85('-'))
99991 FORMAT (/, 'RES#', ' Coords Center of Gravity', 8X,
     1           'Main axes (hor)', 3X, 'EigenV', 3X, 'Asym',
     2         ' Angle a,b,c', /, 80('-'))
99990 FORMAT (/, 3X, 'Symm Op', 8X, 'Res#i Res#j', 6X, 'DirLatt Vector',
     1   3X, 'Angle(Deg)', 1X, 'Shift(Ang)', /, 80('='))
99989 FORMAT (/, ':: Smallest angle of [RotAx] with Plane normal (',
     1           3F4.0, ') = ', F6.3, ' Deg.', /)
99988 FORMAT (/, ':: RMS-Fit = ', F10.3, ' Ang.',
     1           ' (Note: Use Quaternion FIT for an accurate fit)')
99987 FORMAT (I3, F8.4, 2F9.4, 2X, 3F7.3, I8, F8.2, 3I4)
99986 FORMAT (3X, F8.4, 2F9.4, 2X, 3F7.3, I8, F8.2, 3I4)
99985 FORMAT (7X, 'Res.Mol.Wt. =', F9.2, 2X, 3F7.3, I8, F8.2, 3I4, /)
99977 FORMAT (/, ':: Warning: The Pairwise Atom Association',
     1           ' is Tentative and may be Erroneous', /)
      END
      SUBROUTINE PLA083 (NR, DUMVX, EWX, V2X, WHTX, NATX, NATT, IDETX)
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118,
     1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP25=99,
     2 NP29=63,NP38=125,NP39=30,NP41=200,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9),
     1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10),
     2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10),
     3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770)
      DIMENSION DUMW(3, 3), EV(3, 3), EWX(3), DUMVX(3, 3), V2X(3)
      NMAX = IPR(39)
      CALL GEN074 (V1, 0.0, 1, 3)
      CALL GEN074 (DXI, 0.0, 1, 3)
      KP  = 0
      KPT = 0
      WM  = 0
      DO 30 N = 1, NMAX
        CALL GEN048 (-6, IFG(N), 9, IRESN)
        IF (IRESN .EQ. NR) THEN
          CALL GEN048 (-7, JFG(N), 1, IPP)
          IF (IPPR(IPP + 1, 1) .LT. 1000) THEN
            KP = 0
            GOTO 130
          ENDIF
          KPT = KPT + 1
          CALL GEN048 (-1, IFG(N), 7, IVL)
          IF (IVL .EQ. 0) THEN
            CALL GEN048 (-4, IFG(N), 15, IVL)
            WHT = SATWT(IVL + 1)
            KP  = KP + 1
            WM  = WM + WHT
            DO 20 J = 1, 3
              V1 (J) = V1 (J) + WHT * XXO(N, J)
              DXI(J) = DXI(J) + WHT * XXO(N, J + 3)
   20       CONTINUE
          ENDIF
        ENDIF
   30 CONTINUE
      IF (KP .LE. 6 .OR. WM .EQ. 0.0) THEN
        KP = 0
        GOTO 130
      ENDIF
      WHTX = WM
      DO 50 I = 1, 3
        V1 (I) = V1 (I) / WM
        DXI(I) = DXI(I) / WM
        XXO(NMAX + NR, I)     = V1 (I)
        XXO(NMAX + NR, I + 3) = DXI(I)
        DO 40 J = 1, 3
          DUMW(I, J) = 0.0
   40   CONTINUE
   50 CONTINUE
      DO 60 N = 1, NMAX
        CALL GEN048 (-6, IFG(N), 9, IRESN)
        IF (IRESN .EQ. NR) THEN
          CALL GEN048 (-1, IFG(N), 7, IVL)
          IF (IVL .EQ. 0) THEN
            CALL GEN048 (-4, IFG(N), 15, IVL)
            WHT = SATWT(IVL + 1)
            XX  = XXO(N, 4) - DXI(1)
            YY  = XXO(N, 5) - DXI(2)
            ZZ  = XXO(N, 6) - DXI(3)
            XSQ = XX**2
            YSQ = YY**2
            ZSQ = ZZ**2
            DUMW(1, 1) = DUMW(1, 1) + WHT * (YSQ + ZSQ)
            DUMW(1, 2) = DUMW(1, 2) - WHT * XX * YY
            DUMW(1, 3) = DUMW(1, 3) - WHT * XX * ZZ
            DUMW(2, 2) = DUMW(2, 2) + WHT * (ZSQ + XSQ)
            DUMW(2, 3) = DUMW(2, 3) - WHT * YY * ZZ
            DUMW(3, 3) = DUMW(3, 3) + WHT * (XSQ + YSQ)
          ENDIF
        ENDIF
   60 CONTINUE
      CALL GEN024 (DUMW, EV, EWX, DUMVX)
      CALL GEN074 (V2X, 0.0, 1, 3)
      DO 100 N = 1, NMAX
        CALL GEN048 (-6, IFG(N), 9, IRESN)
        IF (IRESN .EQ. NR) THEN
          CALL GEN048 (-1, IFG(N), 7, IVL)
          IF (IVL .EQ. 0) THEN
            CALL GEN048 (-4, IFG(N), 15, IVL)
            WHT   = SATWT(IVL + 1)
            DO 70 I = 1, 3
              V3(I) = XXO(N, I + 3) - DXI(I)
   70       CONTINUE
            DO 90 J = 1, 3
              DO 80 I = 1, 3
                V2X(J) = V2X(J) + (WHT * DUMVX(I, J) * V3(I))**3
   80         CONTINUE
   90       CONTINUE
          ENDIF
        ENDIF
  100 CONTINUE
      DO 120 J = 1, 3
        IF (V2X(J) .LT. 0.0) THEN
          DO 110 I = 1, 3
            DUMVX(I, J) = - DUMVX(I, J)
  110     CONTINUE
          V2X(J) = - ABS(V2X(J)) ** (1.0 / 3.0)
        ELSE
          V2X(J) =   V2X(J) ** (1.0 / 3.0)
        ENDIF
  120 CONTINUE
      CALL GEN010 (DUMVX, IDETX, 0)
  130 NATX = KP
      NATT = KPT
      RETURN
      END
      SUBROUTINE PLA084 (IRES, JRES)
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16,
     1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP22=256,NP25=99,
     2 NP29=63,NP38=125,NP39=30,NP41=200,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      CHARACTER FORMA*74, FORMB*66
      FORMB(1 :37) = '(A,''-'',A,5X,A,''-'',A,F10.4,''('',I3,'')'','
      FORMB(38:66) = 'F10.4,''('',I3,'')'',F10.4,F10.4)'
      FORMA(1:32)  =  '(A,''-'',A,''-'',A,3X,A,''-'',A,''-'',A,'
      FORMA(33:64) = 'F8.2,''('',I3,'')'',F8.2,''('',I3,'')'','
      FORMA(65:74) = 'F8.2,F8.2)'
      D1   = 0.0
      D2   = 0.0
      A1   = 0.0
      SA1  = 0.0
      SD1  = 0.0
      SD2  = 0.0
      ND1  = 0
      ND2  = 0
      ISD1 = 0
      ISD2 = 0
      ISA1 = 0
      CALL PLA269 (0)
      CALL PLA269 (5)
      WRITE (LU7, 99999) IRES, JRES
      IPR(133) = 0
      VDIF     = 0.0
      NV       = 0
      IFIN     = -1
   10 CALL PLA038 (I, J, IFIN)
      IF (IFIN .NE. 1) THEN
        CALL GEN048 (-6, IFG(I), 9, IRESI)
        IF (IRESI .EQ. IRES) THEN
          CALL PLA053 (I, J, 0, 0, D1, SD1, ISD1, ND1, IER)
          IF (IER .EQ. 0) THEN
            IAT = JCA(I)
            JAT = JCA(J)
            CALL PLA053 (IAT, JAT, 0, 0, D2, SD2, ISD2, ND2, IER)
            IF (IER .EQ. 0) THEN
              CALL PLA047 (XLAB(I), NQ3, IDUM, JDUM, IPR(119),
     1                     IGBL(55), 0, 0)
              CALL PLA047 (XLAB(J), NQ4, IDUM, JDUM, IPR(119),
     1                     IGBL(55), 0, 0)
              CALL PLA047 (XLAB(IAT), NQ1, IDUM, JDUM, IPR(119),
     1                     IGBL(55), 0, 0)
              CALL PLA047 (XLAB(JAT), NQ2, IDUM, JDUM, IPR(119),
     1                     IGBL(55), 0, 0)
              DIF = D1 - D2
              DS  = SQRT (SD1**2 + SD2**2)
              IF (DS .NE. 0) DS = DIF / DS
              VDIF = VDIF + DIF**2
              NV   = NV + 1
              FORMB(25:25) = CHAR(ICHAR('0') + ND1)
              FORMB(42:42) = CHAR(ICHAR('0') + ND2)
              WRITE (PRBUF, FORMB)
     1          NQ3, NQ4, NQ1, NQ2, D1, ISD1, D2, ISD2, DIF, DS
              CALL PLA067 (LU7, PRBUF, 132, 1, 3)
              DATC(NV) = ABS(DS)
            ENDIF
          ENDIF
        ENDIF
        GOTO 10
      ENDIF
      VDIF = SQRT (VDIF / NV)
      CALL PLA269 (2)
      WRITE (LU7, 99997) VDIF
      IF (NV .GT. 5) THEN
        CALL PLA269 (0)
        CALL PLA282 (1, DATC(1), DATC(NV + 1), NV, LU7)
      ENDIF
      CALL PLA269 (0)
      CALL PLA269 (5)
      WRITE (LU7, 99996) IRES, JRES
      IPR(133) = 0
      VDIS     = 0.0
      NV       = 0
      KB       = 0
      IFIN     = -1
   20 CALL PLA039 (I, J, K, IRES, A, SA, ISA, NDEC, KB, IFIN)
      IF (IFIN .NE. 1) THEN
        IAT = JCA(I)
        JAT = JCA(J)
        KAT = JCA(K)
        IF (IAT .NE. 0 .AND. JAT .NE. 0 .AND. KAT .NE. 0) THEN
          CALL PLA047 (XLAB(IAT), NQ1, IDUM, JDUM,
     1                 IPR(119), IGBL(55), 0, 0)
          CALL PLA047 (XLAB(JAT), NQ2, IDUM, JDUM,
     1                 IPR(119), IGBL(55), 0, 0)
          CALL PLA047 (XLAB(KAT), NQ3, IDUM, JDUM,
     1                 IPR(119), IGBL(55), 0, 0)
          CALL PLA053 (IAT, JAT, KAT, 0, A1, SA1, ISA1, ND1, IER)
          IF (IER .EQ. 0) THEN
            DIF = A - A1
            DS  = SQRT (SA**2 + SA1**2)
            IF (DS .NE. 0) DS = DIF / DS
            VDIS = VDIS + DIF**2
            NV   = NV + 1
            FORMA(36:36) = CHAR(ICHAR('0') + NDEC)
            FORMA(52:52) = CHAR(ICHAR('0') + ND1)
            WRITE (PRBUF, FORMA) (NAMS(1, M)(2:8), M = 1, 3),
     1        NQ1, NQ2, NQ3, A, ISA, A1, ISA1, DIF, DS
              CALL PLA067 (LU7, PRBUF, 132, 1, 3)
            DATC(NV) = ABS(DS)
          ENDIF
        ENDIF
        GOTO 20
      ENDIF
      VDIS = SQRT (VDIS / NV)
      CALL PLA269 (2)
      WRITE (LU7, 99994) VDIS
      IF (NV .GT. 5) THEN
        CALL PLA269 (0)
        CALL PLA282 (1, DATC(1), DATC(NV + 1), NV, LU7)
      ENDIF
      RETURN
99999 FORMAT ('Comparison of the Bonds of the Fitted Residues', /,
     1        46('='), //, 'Resd#',I1, 14X, 'Resd#', I1, 18X, 'Dist#1',
     2        9X, 'Dist#2', 6X, 'Diff', 2X, 'Diff/Sig', /, 85('='))
99997 FORMAT (/, ':: RMS Bond Fit = ', F10.4, ' Ang.')
99996 FORMAT ('Comparison of the Bond Angles of the Fitted Residues', /,
     1        52('='), //, 'Resd#', I1, 20X, 'Resd#', I1, 25X,
     2        'Ang#1', 8X, 'Ang#2', 4X, 'Diff', 1X, 'Diff/Sig', /,
     3         91('='))
99994 FORMAT (/, ':: RMS Angle Fit = ', F10.3, ' Deg.')
      END
      SUBROUTINE PLA085 (LU, VARDIST)
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16,
     1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP22=256,NP25=99,
     2 NP29=63,NP38=125,NP39=30,NP41=200,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      DIMENSION DUMW(3), V(3)
      COMMON /FNAME/ KNM(8), KXT, KNM16
      COMMON /NAMES/ NAME(8), EXTENS, PROGNM, FNLU1, FNLU16, RDTYPE
      CHARACTER NAME*80, EXTENS*9, PROGNM*28, FNLU1*80, FNLU16*80,
     1          RDTYPE*7
      CHARACTER INVRT*8, INCF*1
      COMMON /PATHS/ PLAPATH, BROWSER, CGETENV
      CHARACTER PLAPATH*255, BROWSER*255, CGETENV*255
      EXTERNAL SYSTEM
      ISN = 0
      NATC = IPR(12) / 2
      NAT1 = IPR(12) - 1
      NAT2 = IPR(12)
      CALL GEN048 (-6, IFG(JR(1)), 9, NRES1)
      CALL GEN048 (-6, IFG(JR(2)), 9, NRES2)
      IF (LU .EQ. 1) WRITE (LU6, 99999)
      CALL PLA269 (-3)
      WRITE (LU7, 99999)
      IF (LU .NE. 0) OPEN (UNIT = LU60,
     1   FILE = NAME(1)(1:KNM(1))//'_fit.spf', STATUS = 'UNKNOWN')
      CALL GEN074 (DUMA, 0.0, 1, 6)
      DO 30 I = 1, IPR(39)
        DO 20 J = 1, IPR(12)
          IF (JR(J) .EQ. I) THEN
            K = MOD(J + 1, 2) * 3
            DO 10 N = 1, 3
              DUMA(N + K) = DUMA(N + K) + XXO(JR(J), 3 + N) / NATC
   10       CONTINUE
            GOTO 30
          ENDIF
   20   CONTINUE
        CALL GEN048 (-6, IFG(I), 9, NRES)
        IF (NRES .EQ. NRES1) THEN
          NAT1     = NAT1 + 2
          JR(NAT1) = I
        ELSE IF (NRES .EQ. NRES2) THEN
          NAT2     = NAT2 + 2
          JR(NAT2) = I
        ENDIF
   30 CONTINUE
   40 IF (NAT2 .GT. NAT1 + 1) THEN
        NAT1     = NAT1 + 2
        JR(NAT1) = 0
        GOTO 40
      ELSE IF (NAT2 .LT. NAT1 +1) THEN
        NAT2 = NAT2 + 2
        JR(NAT2) = 0
        GOTO 40
      ENDIF
      ISN1 = 1
      ISN7 = 7
      IF (IPR(33) .NE. 0) THEN
        ISNS = 2
        IF (IPR(33) .EQ. 2) THEN
          ISN1 = 2
          ISN7 = 8
        ENDIF
      ELSE
        ISNS = 1
      ENDIF
      TH   = 0.0
      BEST = 99999.0
      ISNB = 1
      MBST = 0
      DO 140 ISN0 = ISN1, ISN7, ISNS
        IF (ISN0 .EQ. ISN7) THEN
          ISN = ISNB
          M   = MBST
          IF (ISN .EQ. -1) THEN
            IF (LU .EQ. 1) WRITE (LU6, 99994) NRES1, NRES2
            CALL PLA269 (2)
            WRITE (LU7, 99994) NRES1, NRES2
            CALL PLA269 (2)
            INVRT = '(INVERT)'
          ELSE
            INVRT = '        '
          ENDIF
          IF (LU .NE. 0)
     1      WRITE (LU60, 99991) JID(1:8), NRES1, INVRT, NRES2, NATC
        ELSE
          M = INT((ISN0 - 1) / 2)
          IF (MOD(ISN0, 2) .EQ. 0) THEN
            ISN = -1
          ELSE
            ISN = 1
          ENDIF
        ENDIF
        CALL GEN021 (DUMV, 0)
        CALL GEN074 (DUMW, 0.0, 1, 3)
        CALL GEN074 (V5,   0.0, 1, 3)
        CALL GEN074 (V6,   0.0, 1, 3)
        DO 60 I = 1, IPR(12), 2
          DO 50 J = 1, 3
            V1(J) =  (XXO(JR(I), MOD(J + M, 3) + 4)
     1             - DUMA(MOD(J + M, 3) + 1)) * ISN
            V2(J) = XXO(JR(I + 1), J + 3) - DUMA(J + 3)
            V3(J) =   V1(J) + V2(J)
            V4(J) = - V1(J) + V2(J)
   50     CONTINUE
          DUMV(1, 1) = DUMV(1, 1) + V3(2)**2 + V3(3)**2
          DUMV(2, 2) = DUMV(2, 2) + V3(1)**2 + V3(3)**2
          DUMV(3, 3) = DUMV(3, 3) + V3(1)**2 + V3(2)**2
          DUMV(1, 2) = DUMV(1, 2) - V3(1) * V3(2)
          DUMV(1, 3) = DUMV(1, 3) - V3(1) * V3(3)
          DUMV(2, 3) = DUMV(2, 3) - V3(2) * V3(3)
          DUMW(1)    = DUMW(1)    - V3(3) * V4(2) + V3(2) * V4(3)
          DUMW(2)    = DUMW(2)    + V3(3) * V4(1) - V3(1) * V4(3)
          DUMW(3)    = DUMW(3)    - V3(2) * V4(1) + V3(1) * V4(2)
   60   CONTINUE
        DUMV(2, 1) = DUMV(1, 2)
        DUMV(3, 1) = DUMV(1, 3)
        DUMV(3, 2) = DUMV(2, 3)
        CALL GEN003 (DUMV, RMAT, DET, 0)
        CALL GEN002 (1, RMAT, DUMW, V8, XLNG)
        THETA = 2 * ATAN(SQRT(GEN009(V8, V8)))
        IF (THETA .EQ. 0.0) THEN
          CALL PLA269 (5)
          IF (LU .EQ. 1) THEN
            WRITE (LU6, 99993)
            WRITE (LU6, 99998) TH, V5, V6
          ENDIF
          WRITE (LU7, 99993)
          WRITE (LU7, 99998) TH, V5, V6
          GOTO 160
        ENDIF
        DO 70 I = 1, 3
          V(I) = V8(I) / TAN(THETA / 2)
   70   CONTINUE
        TH = THETA * GL(5)
        IF (ISN0 .EQ. ISN7) THEN
          STHH  = SIN(THETA / 2.0)
          CTHH  = COS(THETA / 2.0)
          V5(1) = STHH * V(1)
          V5(2) = STHH * V(2)
          V5(3) = STHH * V(3)
          VAL   = SIN( -(M + 1) * 60.0 / GL(5)) / SQRT(3.0)
          CALL GEN074 (V6, VAL, 1, 3)
          VAL   = COS(-(M + 1) * 60.0 / GL(5))
          THH   = CTHH * VAL  - GEN009 (V5, V6)
          THH   = MAX (-1.0, MIN (THH, 1.0))
          TH    = MOD (2.0 * ACOS(THH) *  GL(5) + 360.0, 360.0)
          IF (TH .GT. 180.0) TH = TH - 360.0
          CALL GEN008 (V5, V6, V1, 0)
          SHH   = SQRT (1.0 - THH **2)
          IF (SHH .NE. 0.0) THEN
            DO 90 I = 1, 3
              V1(I) = (V1(I) + V5(I) * VAL + CTHH * V6(I)) / SHH
   90       CONTINUE
          ENDIF
          CALL GEN002 (1, ROR, V1, V2, DUM)
          V2MAX = MAX (ABS(V2(1)), ABS(V2(2)), ABS(V2(3)))
          IF (V2MAX .NE. 0) THEN
            DO 100 I = 1, 3
              V2(I) = V2(I) / V2MAX
  100       CONTINUE
          ENDIF
          IF (LU .EQ. 1) WRITE (LU6, 99998) TH, (V1(I), I = 1, 3),
     1                                          (V2(I), I = 1, 3)
          CALL PLA269 (6)
          WRITE (LU7, 99998) TH, (V1(I), I = 1, 3), (V2(I), I = 1, 3)
        ENDIF
        THH   = THETA / 2
        F1    = COS(THH)**2 - SIN(THH)**2
        F2    = SIN(THETA)
        F3    = 2 * SIN(THH)**2
        RMSQ  = 0.0
        URMS  = 0.0
        SUMW  = 0.0
        RMSQ1 = 0.0
        URMS1 = 0.0
        SUMW1 = 0.0
        NONHA = 0
        DO 130 J = 1, NAT1, 2
          I    = JR(J)
          K    = JR(J + 1)
          WGHT = 0.0
          DO 110 N = 1, 3
            IF (I .EQ. 0) THEN
              V1(N) = 0.0
            ELSE
              MODNM = MOD(N + M, 3)
              V1(N) =  (XXO(I, MODNM + 4) - DUMA(MODNM + 1)) * ISN
            ENDIF
            IF (K .EQ. 0) THEN
              V2(N) = 0.0
            ELSE
              V2(N) = XXO(K, N + 3) - DUMA(N + 3)
            ENDIF
            WGHT  = WGHT + V1(N)**2
  110     CONTINUE
          F4 = F3 * GEN009 (V, V1)
          CALL GEN008 (V, V1, V4, 0)
          DO 120 N = 1, 3
            V3(N) = F1 * V1(N) + F2 * V4(N) + F4 * V(N)
  120     CONTINUE
          DIST = (V2(1) - V3(1))**2 + (V2(2) - V3(2))**2
     1         + (V2(3) - V3(3))**2
          IF (J .LT. IPR(12)) THEN
            INCF = '*'
            RMSQ = RMSQ + WGHT * DIST
            SUMW = SUMW + WGHT
            URMS = URMS + DIST
          ELSE
            INCF = ' '
          ENDIF
          CALL GEN048 (-1, IFG(I), 7, IHAT)
          IF (IHAT .EQ. 0) THEN
            NONHA = NONHA + 1
            RMSQ1 = RMSQ1 + WGHT * DIST
            SUMW1 = SUMW1 + WGHT
            URMS1 = URMS1 + DIST
          ENDIF
          DIST = SQRT(DIST)
          IF (ISN0 .EQ. ISN7) THEN
            IF (I .NE. 0) THEN
              CALL PLA047 (XLAB(I), NQ1, IDUM, JDUM, IPR(119), IGBL(55),
     1                     0, 0)
              CALL PLA047 (XLAB(I), NQ3, IDUM, JDUM, IPR(119), 1, 0, 0)
            ELSE
              CALL GEN038 (NQ1, 1, 7)
              NQ3 = NQ1
            ENDIF
            IF (K .NE. 0) THEN
              CALL PLA047 (XLAB(K), NQ2, IDUM, JDUM, IPR(119), IGBL(55),
     1                     0, 0)
            ELSE
              CALL GEN038 (NQ2, 1, 7)
            ENDIF
            IF (JR(J) .NE. 0 .AND. LU .NE. 0) THEN
              WRITE (LU60, 99992) NQ1, NQ3, (V3(N), N = 1, 3)
            ENDIF
            CALL PLA269 (1)
            IF (LU .EQ. 1)
     1        WRITE (LU6, 99996) NQ1(1:6), (V3(N), N = 1, 3),
     2                   NQ2(1:6), (V2(N), N = 1, 3), DIST, INCF
            WRITE (LU7, 99996) NQ1(1:6), (V3(N), N = 1, 3),
     1                 NQ2(1:6), (V2(N), N = 1, 3), DIST, INCF
          ENDIF
  130   CONTINUE
        URMS  = SQRT(URMS  / NATC)
        RMSQ  = SQRT(RMSQ  / SUMW)
        URMS1 = SQRT(URMS1 / NONHA)
        RMSQ1 = SQRT(RMSQ1 / SUMW1)
        IF (ISN0 .EQ. ISN7) THEN
          CALL PLA269 (5)
          IF (LU .EQ. 1) WRITE (LU6, 99995) RMSQ, URMS, NATC,
     1                                     RMSQ1, URMS1, NONHA
          WRITE (LU7, 99995) RMSQ, URMS, NATC, RMSQ1, URMS1, NONHA
        ELSE
          IF (RMSQ .LT. BEST) THEN
            BEST = RMSQ
            ISNB = ISN
            MBST = M
          ENDIF
        ENDIF
  140 CONTINUE
      IF (LU .NE. 0) THEN
        WRITE (LU60, 99990)
        DO 150 I = 1, NAT2, 2
          K    = JR(I + 1)
          IF (K .NE. 0) THEN
            CALL PLA047 (XLAB(K), NQ2, IDUM, JDUM, IPR(119), 1, 0, 0)
            CALL PLA047 (XLAB(K), NQ4, IDUM, JDUM, IPR(119), IGBL(55),
     1                   0, 0)
            WRITE (LU60, 99992) NQ4, NQ2,
     1        (XXO(K, N) - DUMA(N), N = 4, 6)
          ENDIF
  150   CONTINUE
        WRITE (LU60, 99997)
        CLOSE (UNIT = LU60)
        IF (IGBL(25) .NE. 0 .OR. IGBL(3) .EQ. 41) CALL SYSTEM
     1    (PLAPATH(1:IGBL(80))//' -p '//NAME(1)(1:KNM(1))//'_fit.spf')
      ENDIF
      VARDIST = RMSQ
  160 RETURN
99999 FORMAT ('Molfit with Quaternion Transformation Method',
     1 ' (see: A.L. Mackay, Acta Cryst.(1984), A40, 165-166)', /,
     2 132('='), /)
99998 FORMAT ('Fit Rotation angle about (Pseudo)axis [l,m,n] = ',
     1  F10.2,  ' Degree', /,
     2  'Direction Cosines with Orthogonal Cell l,m,n  = ',
     2 3F10.6, /, 'Components in crystal system', 20X, 3F10.6, //,
     3 'Transf. Orthogonal Coord. Mol1', 5X,
     4 'Orth. Coord. Mol2 with Resp. to C.G.', 1X,
     5 'Dist (A)', /, 80('-'))
99997 FORMAT ('STRAW', /, 'COLOR RESD', /, 'OVERLAP MARGIN 0.0', /,
     1 'SET PAR 149 0.0', /, 'LABEL ON', /, 'PLOT')
99996 FORMAT (1X, 2(A, 1X, 3F8.3, 4X), F7.3, 1X, A)
99995 FORMAT (/, ':: Weighted and Unit Weight RMS-Fit: ',
     1  2F7.3 ,' Ang, No of Fitted Atoms:', I4, /,
     2        /, ':: Weighted and Unit Weight RMS-Fit: ',
     3  2F7.3 ,' Ang, No of Non-H  Atoms:', I4)
99994 FORMAT (':: FIT Inverted Resd', I2, '  on Resd', I2,
     1        ' gives the best fit', /)
99993 FORMAT (':: Residues are IDENTICAL', /)
99992 FORMAT (A, A, 3F10.3)
99991 FORMAT ('TITL ', A, ' - FIT RESD', I3, A, ' TO RESD', I3,
     1        ', N =', I3, /, 'RESD 1')
99990 FORMAT ('RESD 2')
      END
      SUBROUTINE PLA086 (LU)
      PARAMETER (NP12=600,NP13=500,NP17=99,NP38=125,NP39=30)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      CALL PLA080
      CONST = 16.0 * GL(6) * PAR(98) / 3.0
      IF (LU .EQ. LU7) CALL PLA269 (0)
      WRITE (LU, 99999) IPR(48)
      DO 10 I = 20, 30
        STHL = SIN (I / GL(5)) / 0.71073
        NREF1 = NINT (CONST * STHL ** 3)
        NREF2 = NREF1 / IPR(48)
        NREF3 = NREF2 / (3 - IPR(257))
        XJ    = ASIN (MIN(1.0, STHL * 1.5418)) * GL(5)
        WRITE (LU, 99998) I, NREF1, NREF2, NREF3, XJ , STHL
   10 CONTINUE
99999 FORMAT (/, 'Expected number of reflections in sphere ',
     1 '(NSYM =', I3, ')', //,
     2 'THMAX(MoKa)       N      N/NSYM   N(LAUE) ',
     3 'THMAX(CuKa) SINT/LAMBDA', /, 80('='), /)
99998 FORMAT (I5, 5X, 3I10, F10.2, F12.3)
      RETURN
      END
      SUBROUTINE PLA087 (NLTX)
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16,
     1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP25=99,NP29=63,
     2 NP38=125,NP39=30,NP41=200,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /LATICE/ TRNSX(3, 3, 128), ROT(3, 5, 5), TRDAT(3, 3, 8)
C * CELL REDUCTION, SEE KRIVY & GRUBER, ACTA CRYST (1976), A32, 297-298)
      DO 20 J = 1, 3
        DO 10 K = 1, 3
          TRNS(J, K) = TRNSX(J, K, IPR(241))
          DUMV(J, K) = TRNSX(J, K, NLTX)
   10   CONTINUE
   20 CONTINUE
      CALL GEN004 (TRNS, DUMV, TRNS)
      CALL GEN001 (1, TRNS, AA, DUMV)
      CALL PLA088 (DUMV, TRNS, PAR(440))
      CALL GEN025 (DUMV, PAR(151), 1)
      CALL GEN026 (-1, DUMV, PAR(123), GL(5))
      CALL GEN005 (TRNS, TRNS)
      CALL GEN003 (TRNS, TRNSM1, DET, 0)
      PAR(99) = PAR(98) * DET
      CALL GEN044 (PAR(123), ADIR)
      CALL GEN003 (ADIR, AINV, DET, 0)
      RETURN
      END
      SUBROUTINE PLA088 (DUMV, TRNS, SCL)
      COMMON /LATICE/ TRNSX(3, 3, 128), ROT(3, 5, 5), TRDAT(3, 3, 8)
      DIMENSION TRNS(3, 3), DUMV(3, 3)
      REAL KSI, ETA, ZETA
C * CELL REDUCTION, SEE KRIVY & GRUBER, ACTA CRYST (1976), A32, 297-298)
      A    = NINT(DUMV(1, 1) * SCL)
      B    = NINT(DUMV(2, 2) * SCL)
      C    = NINT(DUMV(3, 3) * SCL)
      KSI  = NINT(2.0 * SCL * DUMV(2, 3))
      ETA  = NINT(2.0 * SCL * DUMV(1, 3))
      ZETA = NINT(2.0 * SCL * DUMV(1, 2))
   10 IF ((A .GT. B) .OR. ((NINT(A) .EQ. NINT(B)) .AND.
     1    (ABS(KSI) .GT. ABS(ETA)))) THEN
        CALL GEN018 (A, B)
        CALL GEN018 (KSI, ETA)
        ETA = - ETA
        KSI = - KSI
        CALL GEN004 (TRNSX(1, 1, 8), TRNS, TRNS)
      ENDIF
      IF ((B .GT. C) .OR. ((NINT(B) .EQ. NINT(C)) .AND.
     1   (ABS(ETA) .GT. ABS(ZETA)))) THEN
        CALL GEN018 (B, C)
        CALL GEN018 (ETA, ZETA)
        ETA  = - ETA
        ZETA = - ZETA
        CALL GEN004 (TRNSX(1, 1, 9), TRNS, TRNS)
        GOTO 10
      ENDIF
      IF (KSI * ETA * ZETA .GT. 0) THEN
        TRNSX(1, 1, 10) = SIGN(1.0, KSI)
        TRNSX(2, 2, 10) = SIGN(1.0, ETA)
        TRNSX(3, 3, 10) = SIGN(1.0, ZETA)
        KSI  = ABS(KSI)
        ETA  = ABS(ETA)
        ZETA = ABS(ZETA)
        CALL GEN004 (TRNSX(1, 1, 10), TRNS, TRNS)
      ELSE
        TRNSX(1, 1, 11) = - SIGN(1.0, KSI)
        TRNSX(2, 2, 11) = - SIGN(1.0, ETA)
        TRNSX(3, 3, 11) = - SIGN(1.0, ZETA)
        IF (KSI * ETA * ZETA .EQ. 0.0) THEN
          IF (KSI .EQ. 0.0)
     1       TRNSX(1, 1, 11) = TRNSX(2, 2, 11) * TRNSX(3, 3, 11)
          IF (ETA .EQ. 0.0)
     1       TRNSX(2, 2, 11) = TRNSX(1, 1, 11) * TRNSX(3, 3, 11)
          IF (ZETA .EQ. 0.0)
     1       TRNSX(3, 3, 11) = TRNSX(1, 1, 11) * TRNSX(2, 2, 11)
        ENDIF
        KSI  = - ABS(KSI)
        ETA  = - ABS(ETA)
        ZETA = - ABS(ZETA)
        CALL GEN004 (TRNSX(1, 1, 11), TRNS, TRNS)
      ENDIF
      IF ((ABS(KSI) .GT. B) .OR. ((KSI .EQ. B) .AND.
     1  (2.0 * ETA .LT. ZETA)) .OR. ((KSI .EQ. -B) .AND.
     2  (ZETA .LT. 0.0))) THEN
        TRNSX(3, 2, 12) = - SIGN(1.0, KSI)
        C   = B   + C - KSI * SIGN(1.0, KSI)
        ETA = ETA - ZETA * SIGN(1.0, KSI)
        KSI = KSI - 2.0 * B * SIGN(1.0, KSI)
        CALL GEN004 (TRNSX(1, 1, 12), TRNS, TRNS)
        GOTO 10
      ENDIF
      IF ((ABS(ETA) .GT. A) .OR. ((ETA .EQ. A) .AND.
     1  (2.0 * KSI .LT. ZETA)) .OR. ((ETA .EQ. -A) .AND.
     2  (ZETA .LT. 0))) THEN
        TRNSX(3, 1, 13) = - SIGN(1.0, ETA)
        C   = A + C - ETA * SIGN(1.0, ETA)
        KSI = KSI - ZETA * SIGN(1.0, ETA)
        ETA = ETA - 2.0 * A * SIGN(1.0, ETA)
        CALL GEN004 (TRNSX(1, 1, 13), TRNS, TRNS)
        GOTO 10
      ENDIF
      IF ((ABS(ZETA) .GT. A) .OR. ((ZETA .EQ. A) .AND.
     1  (2.0 * KSI .LT. ETA)) .OR. ((ZETA .EQ. -A) .AND.
     2  (ETA .LT. 0))) THEN
        TRNSX(2, 1, 14) = - SIGN(1.0, ZETA)
        B    = A + B - ZETA * SIGN(1.0, ZETA)
        KSI  = KSI - ETA * SIGN(1.0, ZETA)
        ZETA = ZETA - 2.0 * A * SIGN(1.0, ZETA)
        CALL GEN004 (TRNSX(1, 1, 14), TRNS, TRNS)
        GOTO 10
      ENDIF
      IF ((KSI + ETA + ZETA + A + B .LT. 0) .OR.
     1   ((KSI + ETA + ZETA + A + B .EQ. 0) .AND.
     2    (2.0 * (A + ETA) + ZETA .GT. 0.0))) THEN
        C   = A + B + C + KSI + ETA + ZETA
        KSI = 2.0 * B + KSI + ZETA
        ETA = 2.0 * A + ETA + ZETA
        CALL GEN004 (TRNSX(1, 1, 15), TRNS, TRNS)
        GOTO 10
      ENDIF
      DUMV(1, 1) = A / SCL
      DUMV(2, 2) = B / SCL
      DUMV(3, 3) = C / SCL
      DUMV(1, 2) = ZETA * 0.5 / SCL
      DUMV(1, 3) = ETA  * 0.5 / SCL
      DUMV(2, 3) = KSI  * 0.5 / SCL
      DUMV(3, 2) = DUMV(2, 3)
      DUMV(3, 1) = DUMV(1, 3)
      DUMV(2, 1) = DUMV(1, 2)
      RETURN
      END
      SUBROUTINE PLA089
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118,
     1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,
     2 NP25=99,NP29=63,NP38=125,NP39=30,NP41=200,NP45=2048,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9),
     1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10),
     2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10),
     3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770)
      COMMON /Q/ ICL, IFL(NP17)
      CHARACTER ICL*(NP45), IFL*7
      IF (IPR(30) .EQ. 0) THEN
        KINC   = IPR(4)
        NDOAC  = IPR(480)
        NAT    = IPR(37)
        IPR(4) = 0
        IF (IPR(208) .EQ. 0) THEN
          CALL PLA042 (1)
          MODE = 0
          DO 10 I = 1, IAN
            IF (IEN(I) .EQ. 2) THEN
              MODE = 1
              GOTO 20
            ENDIF
   10     CONTINUE
   20     CALL GEN123 (MODE, IEN, IENS, IEL, IAN)
          DO 50 I = 1, NAT
            CALL GEN048 (-4, IFG(I), 15, NO1)
            NO1  = NO1 + 1
            IVAL = 1
            IF (KINC .GT. 0) THEN
              DO 30 J = 1, KINC
                IF (NO1 .EQ. NINT(RADR(J, 2))) THEN
                  IVAL = IPR(70)
                  GOTO 40
                ENDIF
   30         CONTINUE
              IVAL = 1 - IPR(70)
   40         CON(I, 1) = CON(I, 1) * IVAL
            ENDIF
   50     CONTINUE
          IF (NAT .EQ. 0) GOTO 230
          IF (IGBL(33) .NE. 0) THEN
            ND = 2**(INT((ALOG(FLOAT(NAT)) / ALOG(2.0)) + 1.0e-5)) - 1
   60       IF (ND .GT. 0) THEN
              I    = 1
   70         J    = I
              NIFL = IFG(I  + ND)
              NJFL = JFG(I  + ND)
              NIAP = IATP(I + ND)
              DO 80 K = 1, NP4
                DBUF(K) = CON(I + ND, K)
   80         CONTINUE
   90         IF (DBUF(1) .LT. CON(J, 1)) THEN
                IFG(J  + ND) = IFG(J)
                JFG(J  + ND) = JFG(J)
                IATP(J + ND) = IATP(J)
                DO 100 K = 1, NP4
                  CON(J + ND, K) = CON(J, K)
  100           CONTINUE
                J = J - ND
                IF (J .GT. 0) GOTO 90
              ENDIF
              DO 110 K = 1, NP4
                CON(J + ND, K) = DBUF(K)
  110         CONTINUE
              IFG(J  + ND) = NIFL
              JFG(J  + ND) = NJFL
              IATP(J + ND) = NIAP
              I            = I + 1
              IF (I + ND .LE. NAT) GOTO 70
              ND = (ND - 1) / 2
              GOTO 60
            ENDIF
          ENDIF
          K = 0
          DO 130 I = 1, NAT
            IF (CON(I, 1) .NE. 0) THEN
              K       = K + 1
              XLAB(K) = CON(I, 2)
              IFG(K)  = IFG(I)
              JFG(K)  = JFG(I)
              IATP(K) = IATP(I)
              DO 120 J = 1, 3
                XXO(K, J) = CON(I, J + 2)
                IF (IABS(IGBL(8)) .NE. 2) THEN
                  XSD(K, J) = CON(I, J + 5)
                ELSE
                  XSD(K, J) = 0.0
                ENDIF
  120         CONTINUE
            ENDIF
  130     CONTINUE
          IPR(37)  = K
          IPR(39)  = K
          NAT      = K
          IPR(208) = 1
        ENDIF
        IF(IPR(205) .GT. 0) THEN
          CALL PLA022
        ELSE
          CALL PLA041 (0, 1, NP1, 0)
          IPR(13) = 1
          MOL(1)  = NINT(1555 * PAR(42))
          IPR(51) = IPR(13)
          IPR(75) = 0
          IPR(17) = 0
          DO 160 I = 1, NAT
            CALL GEN048 (-4, IFG(I), 15, NO1)
            NO1 = NO1 + 1
            CALL GEN048 (3, IFG(I), 1, 0)
            IKAT = I
            CALL PLA059 (IKAT, IKAT)
            IVAL = 1
            DO 140 J = 1, NDOAC
              IF (IEN(NO1) .EQ. IDOAC(J)) GOTO 150
  140       CONTINUE
            IVAL = 0
  150       CALL GEN048 (1, IFG(I), 23, IVAL)
            IF (IGBL(30) .EQ. 1 .OR. IATP(I) .GT. 0)  CALL PLA078 (I)
  160     CONTINUE
        ENDIF
      ENDIF
      IF (IPR(205) .EQ. 0) THEN
        IF (IPR(17) .LT. 0) THEN
          DO 170 I = 1, IAN
            RADR(I, 2) = RADR(I, 4)
  170     CONTINUE
          IF (IPR(189) .EQ. 0) THEN
            PAR(1) = PAR(3)
          ELSE
            PAR(1) = 0.0
          ENDIF
        ELSE IF (IPR(17) .EQ. 0) THEN
          DO 190 I = 1, IAN
            RADR(I, 2) = RADR(I, 3)
  190     CONTINUE
          PAR(1) = PAR(2)
          IF (IPR(31) .NE. 0) GOTO 220
        ELSE
          PAR(1) = 0.0
          DO 200 I = 1, IAN
            RVAL = 0.0
            IF (IPR(57) .EQ. 1) THEN
              IELTP = IATPR(IEN(I))
              IF (IELTP .GT. 0) RVAL = PAR(262)
            ELSE IF (IPR(57) .EQ. 2) THEN
              RVAL = PAR(262)
            ELSE IF (IPR(57) .LT. 0) THEN
              IF (IPR(57) + I .EQ. 0) RVAL = PAR(262)
            ELSE
              IF (IABS(IGBL(8)) .EQ. 2 .OR. IABS(IGBL(8)) .EQ. 3) THEN
                ICARB = 1
              ELSE
                ICARB = 2
              ENDIF
              IF (IEN(I) .GT. ICARB .AND. IEN(I) .NE. 33 .AND.
     1            IEN(I) .NE. 113) RVAL = PAR(262)
            ENDIF
            RADR(I, 2) = RVAL
  200     CONTINUE
          IPR(168) = 0
          IF (IPR(220) .GE. 3) THEN
            IF (IFL(3)(1:3) .EQ. 'NOA') THEN
              IPR(7) = 0
            ELSE
              CALL PLA037 (3, NID, 3)
              IF (NID .LT. 0) THEN
                IPR(168) = - NID
              ELSE IF (NID .EQ. 0) THEN
                IPR(2) = 18
                GOTO 230
              ENDIF
            ENDIF
          ENDIF
        ENDIF
        DO 210 J = 1, IAN
          RADJ     = RADR(J, 1)
          RADR(J, 1) = -1.0
          IF (RADJ .GE. 0.0) RADR(J, 2) = RADJ
  210   CONTINUE
  220   IPR(15)  = 0
        IPR(104) = 1
        IPR(24)  = 0
        IF (IPR(23) .EQ. 1 .OR. IGBL(52) .EQ. 1) THEN
          IPR(27)  = 1
          IGBL(30) = 1
        ELSE
          IPR(27) = 0
        ENDIF
      ENDIF
  230 RETURN
      END
      SUBROUTINE PLA090
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118,
     1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP22=256,
     2 NP25=99,NP29=63,NP38=125,NP39=30,NP41=200,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9),
     1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10),
     2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10),
     3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      CHARACTER FORM*105, FORMA*70, FORMB*43, CXMOL3*9
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      CHARACTER INTRA*6, IYH*1, NYH*1
      COMMON /PAGENM/ PAGET, PAGEIND(25)
      CHARACTER PAGET*8, PAGEIND*8
      COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0
      IGBL(23) = 10
      IF (IGBL(25) * IGBL(32) .EQ. 1 .AND. IPR(121) .EQ. 0 .AND.
     1    IPR(430) .EQ. 0) THEN
        IWIN = 1
      ELSE
        IWIN = 0
      ENDIF
      FORM(1 :40)  = '(I2,A,I2,   A,''--'',A,''..'',A,''['',A   ,'']'''
      FORM(41:56)  = ',F7.4,''('',I2,'')'''
      FORM(57:105) = FORM(41:56)//FORM(41:56)//',F7.1,''('',I2,'')'')'
      FORMB(1:36)  = '(8X,I2,A,''--'',A,''.. ?'',16X,F7.4,''('','
      FORMB(37:43) = 'I2,'')'')'
      A1  = 0.0
      A2  = 0.0
      A3  = 0.0
      D1  = 0.0
      D2  = 0.0
      D3  = 0.0
      SA1 = 0.0
      SA2 = 0.0
      SA3 = 0.0
      SD1 = 0.0
      SD2 = 0.0
      SD3 = 0.0
      IDEC1 = 0
      IDEC2 = 0
      IDEC3 = 0
      IDEC4 = 0
      IDEC5 = 0
      IDEC6 = 0
      ISA1  = 0
      ISA2  = 0
      ISD1  = 0
      ISD2  = 0
      ISD3  = 0
      ISA3  = 0
      NHEAD = 0
      ITLC  = 0
      KOLD  = 0
      IOLD  = 0
      IDC   = 0
      NTEL  = 0
      A0    = 0.0
      SA0   = 0.0
      IF (IPR(87) .NE. 0) WRITE (LU6, 99983)
      NAT   = IPR(37)
      NATM  = IPR(39)
      IPR(88) = 0
      CALL GEN097 (IATP, 1, NATM, 0)
      CALL GEN097 (IFNT, 1, NATM, 0)
      CALL GEN097 (JCA,  1, NATM, 0)
      CALL GEN097 (MP,   1, NP11, 0)
      WRITE (PRBUF, 99992)
      WRITE (LU6, 99986) PRBUF(1:80)
      IF (IWIN .EQ. 1) THEN
        CALL GGIP (HORS, VERT, 0.0, 1)
        CALL GGIP20 (0.0, JID, 9, 0.30, 5 + IGBL(68), 2, HORS - 3.0,
     1               0.1)
        VRT = VERT - 0.6
        CALL GGIP20 (0.0, PRBUF, 80, 0.35, 5 + IGBL(68), 2, 1.0, VRT)
        VRT = VRT - 0.4
      ENDIF
      DO 80 III = 1, 2
        INRM  = 0
        DO 70 I = 1, NAT
          CALL GEN048 (-1, IFG(I), 7, IHA)
          IF (IHA .NE. 0) THEN
            INRM  = INRM + 1
            INORM = NATM + IPR(24) + INRM
            IF (III .EQ. 1) THEN
              DO 20 J = 1, 6
                XXO(INORM, J) = XXO(I, J)
                XSD(INORM, J) = XSD(I, J)
   20         CONTINUE
              XLAB(INORM) = XLAB(I)
              IFG(INORM)  = IFG(I)
              JFG(INORM)  = JFG(I)
            ENDIF
            CALL PLA036 (I, 1, 2, IPOPI, IDUM1, IDUM2,
     1        IPR(119), IGBL(55))
            IF (IPOPI .GE. 500) THEN
              NC = - NINT(CON(I, NP4))
              IF (NC .LT. 0) NC = NP4
              IF (NC .NE. 0) THEN
                K = NINT(CON(I, 1))
                IF (K .GT. NP1) GOTO 70
                IF (K .LE. 0) THEN
                  WRITE (LU6, 99989) I, K, NC
                  CALL PLA004 (0)
                ENDIF
                CALL GEN048 (-6, IFG(K), 9, IRES)
                CALL GEN048 (-4, IFG(K), 19, IMET)
                IF (IMET .EQ. 1) GOTO 70
                CALL GEN048 (-4, IFG(K), 15, IVLC)
                IVLC = IEN(IVLC + 1)
                IF (IVLC .EQ. 20) GOTO 70
                CALL PLA036 (K, 1, 1, IPOPK, IDIM1, IDUM2,
     1                       IPR(119), IGBL(55))
                IF (III .EQ. 1) THEN
                  IF (IPR(87) .GT. 0) THEN
                    CALL GEN048 (1, JFG(INORM), 10, 0)
                    CALL PLA050 (K, INORM, 0, 0, D1)
                    IF (IVLC .EQ. 2) THEN
                      D1 = PAR(296) / D1
                    ELSE IF (IVLC .EQ. 4) THEN
                      D1 = PAR(297) / D1
                    ELSE IF (IVLC .EQ. 3) THEN
                      D1 = PAR(298) / D1
                    ELSE IF (IVLC .EQ. 20) THEN
                      D1 = PAR(294) / D1
                    ELSE IF (IVLC .EQ. 85) THEN
                      D1 = PAR(295) / D1
                    ENDIF
                    DO 30 L = 4, 6
                      YUNK = (XXO(INORM, L) - XXO(K, L)) * D1
                      XXO(INORM, L) = XXO(K, L) + YUNK
                      XSD(INORM, L) = 0.0
   30               CONTINUE
                  ENDIF
                  IF (IVLC .EQ. 2) GOTO 70
                  IF (NC .LT. 2) THEN
                    IF (IGBL(63) .GT. 2) THEN
                      IF (NHEAD .NE. 1) THEN
                        NHEAD = 1
                        CALL PLA269 (-7)
                        WRITE (LU7, 99997) PAR(8), PAR(9), PAR(10)
                        WRITE (LU7, 99996)
                      ENDIF
                    ENDIF
                    CALL PLA053 (K, INORM, 0, 0, D1, SD1, ISD1,
     1                           IDEC1, IER)
                    IF (IER .EQ. 0) THEN
                      IF (ISD1 .EQ. 0) THEN
                        IDEC1 = 2
                        D1    = NINT (D1 * 100.0) / 100.0
                      ENDIF
                    ENDIF
                    IF (IGBL(63) .GT. 2) THEN
                      IF (NHEAD .NE. 1) THEN
                        NHEAD = 1
                        CALL PLA269 (-5)
                        WRITE (LU7, 99997) PAR(8), PAR(9), PAR(10)
                        IF (IPR(87) .GT. 0) THEN
                          CALL PLA269 (3)
                          WRITE (LU7, 99988)
                        ENDIF
                        CALL PLA269 (2)
                        WRITE (LU7, 99996)
                      ENDIF
                      ISD1 = MIN (99, ISD1)
                      FORMB(31:31) = CHAR(ICHAR('0') + IDEC1)
                      WRITE (PRBUF, FORMB) IRES, NAMS(1, 1)(1:7),
     1                       NAMS(1, 2)(2:8), D1, ISD1
                      CALL PLA067 (LU7, PRBUF, 132, 1, 3)
                      WRITE (LU6, 99980) PRBUF(12:79)
                      IF (IWIN .EQ. 1) THEN
                        VRT = VRT - 0.5
                        CALL GGIP20 (0.0, PRBUF(12:90), 79, 0.35, 2, 2,
     1                               1.0, VRT)
                      ENDIF
                      CALL PLA269 (1)
                    ENDIF
                    IF (NAMS(1, 1)(2:2) .NE. 'B' .AND.
     1                  NAMS(1, 1)(2:2) .NE. 'P') THEN
                      IF (NAMS(1, 1)(2:2) .EQ. 'O') THEN
                        W = 2.0
                      ELSE
                        W = 1.0
                      ENDIF
                      WRITE (LU20, 99982) '_420', W, W,
     1                      (NAMS(1, KK)(1:7), KK = 1, 2)
                    ENDIF
                    IPR(405) = IPR(405) + 1
                    GOTO 70
                  ENDIF
                ELSE
                  IF (NC .LT. 2) GOTO 70
                  IF (IVLC .NE. 2) GOTO 70
                ENDIF
                IF (IPOPK .LT.  501) THEN
                  IF (IPOPK .LT. 500) GOTO 70
                  IDISK = 10
                ELSE
                  IDISK = 0
                ENDIF
                CALL PLA053 (K, INORM, 0, 0, D1, SD1, ISD1,
     1            IDEC1, IER)
                IF (IER .NE. 0) GOTO 70
                CALL GEN048 (-1, IFG(I), 20, IHB)
                DO 50 L = 2, NC
                  M = NINT(CON(I, L))
                  M = MOD(M, NP1)
                  CALL GEN048 (-1, IFG(M), 23, IVAL)
                  CALL GEN048 (-1, JFG(M), 28, IVAL1)
                  IF (IVAL .EQ. 0 .AND. IVAL1 .EQ. 0) GOTO 50
                  CALL PLA036 ( M, 1, 4, IPOPM, IDUM1, IDUM2, IPR(119),
     1                          IGBL(55))
                  CALL PLA036 (-M, 1, 3, IPOPM, IDUM1, IDUM2, IPR(119),
     1                   IGBL(55))
                  IF (IPOPM .LT. 501) THEN
                    IF (IPOPM .LT. 500 .AND. IPR(303) .EQ. 0) GOTO 50
                    IDSORD = IDISK + 1
                  ELSE
                    IDSORD = IDISK
                  ENDIF
                  XLABM = - XLAB(M)
                  CALL PLA047 (XLABM, NQ3, MNM, JDUM, IPR(119),
     1                         IGBL(55), 0, 0)
                  CALL PLA046 (-2, NQ3, IENM, LBB, LBC, LBD,
     1                         XLMP, YNQNR, NIEN)
                  IF (NIEN .LT. 0) THEN
                    NQ1 = NQ3
                    IPR(2) = 3
                    GOTO 130
                  ENDIF
                  IF (IEL(IEN(IENM)) .EQ. 321) GOTO 50
                  MPRIM = NIEN
                  CALL GEN048 (-6, IFG(M), 9, IRESM)
                  XMOL3 = MOL(MNM) / PAR(42)
                  IF (NINT(XMOL3) .EQ. 1555)
     1               XMOL3 = XMOL3 + IRESM / PAR(42)
                  CALL GEN048 (-4, IFG(K), 15, IVWK)
                  CALL GEN048 (-4, IFG(I), 15, IVWI)
                  CALL GEN048 (-4, IFG(M), 15, IVWM)
                  CALL PLA053 (M, INORM, 0, 0, D2, SD2, ISD2, IDEC2,
     1                         IER)
                  IF (IER .NE. 0) GOTO 50
                  IF (D2 .GT. (RADR(IVWI + 1, 2) + RADR(IVWM + 1, 2) +
     1                PAR(9))) GOTO 50
                  CALL PLA053 (K, INORM, M, 0, A1, SA1, ISA1, IDEC4,
     1                         IER)
                  IF (IER .NE. 0) GOTO 50
                  IF (A1 .LT. PAR(10)) GOTO 50
                  CALL PLA053 (K, M, 0, 0, D3, SD3, ISD3, IDEC3, IER)
                  IF (IER .NE. 0) GOTO 50
                  IF (D3 .GT. (RADR(IVWK + 1, 2) + RADR(IVWM + 1, 2) +
     1                PAR(8))) GOTO 50
                  ISD1 = MIN (99, ISD1)
                  FORM(45:45) = CHAR(ICHAR('0') + IDEC1)
                  ISD2 = MIN (99, ISD2)
                  FORM(61:61) = CHAR(ICHAR('0') + IDEC2)
                  ISD3 = MIN (99, ISD3)
                  FORM(77:77) = CHAR(ICHAR('0') + IDEC3)
                  ISA1 = MIN (99, ISA1)
                  FORM(93:93) = CHAR(ICHAR('0') + IDEC4)
                  IF (NHEAD .NE. 1) THEN
                    NHEAD = 1
                    IF (IGBL(63) .GT. 2) THEN
                      PAGET = 'H-BONDS'
                      CALL PLA269 (-7)
                      WRITE (LU7, 99997) PAR(8), PAR(9), PAR(10)
                      WRITE (LU7, 99996)
                    ENDIF
                  ENDIF
                  XMOL2 = (1555 * PAR(42) + IRES) / PAR(42)
                  IF (IHB .NE. 0) THEN
                    IPR(88) = IPR(88) + 1
                    IF (IPR(88) .LE. NP2) THEN
                      XLS(1,  IPR(88)) = K
                      XLS(2,  IPR(88)) = XMOL2
                      XLS(3,  IPR(88)) = MPRIM
                      XLS(4,  IPR(88)) = XMOL3
                      XLS(8,  IPR(88)) = IDSORD
                      XLS(9,  IPR(88)) = A1
                      XLS(10, IPR(88)) = I
                      IATP(K)          = IATP(K) + 1
                      IFNT(MPRIM)      = IFNT(MPRIM) + 1
                      CALL GEN048 (1, IFG(MPRIM), 22, 1)
                    ELSE
                      IPR(149)        = IPR(149) + 10000
                    ENDIF
                  ELSE
                    JCA(MPRIM) = JCA(MPRIM) + 1
                  ENDIF
                  IF (IRESM .EQ. IRES .AND. MNM .LE. IPR(51)) THEN
                    INTRA = ' Intra'
                  ELSE
                    INTRA = '      '
                  ENDIF
                  IF (III .EQ. 2) THEN
                    IF (IDC .EQ. 0 .AND. IGBL(63) .GT. 2) THEN
                      CALL PLA269 (1)
                      VRT = VRT - 0.3
                      WRITE (LU6, 99981)
                      WRITE (LU7, 99981)
                    ENDIF
                    IDC = IDC + 1
                  ENDIF
                  ITLC    = ITLC + 1
                  MP(MNM) = 1
                  IF (INT(XMOL3) .EQ. 1555) THEN
                    CXMOL3 = '         '
                  ELSE
                    WRITE (CXMOL3, 99994) XMOL3
                  ENDIF
                  WRITE (PRBUF, FORM) ITLC, INTRA, IRES,
     1               NAMS(1, 1)(1:7), (NAMS(1, L9)(2:8), L9 = 2, 3),
     2                 CXMOL3, D1, ISD1, D2, ISD2, D3, ISD3, A1, ISA1
                  IF (IPR(438) .EQ. 1) THEN
                    IPR(452) = IPR(452) + 1
                    WRITE (LU2, 99987) (NAMS(1, L9)(2:8), L9 = 1, 2),
     1                NAMS(1, 4)(2:8), D1, SD1, D2, SD2, D3, SD3,
     2                A1, SA1, XLAB(M)
                  ENDIF
                  IF (K .NE. KOLD .OR. I .NE. IOLD) THEN
                    KOLD  = K
                    IOLD  = I
                    MPRM  = M
                    MDPRM = 0
                    A0    = A1
                    SA0   = SA1
                    GOTO 40
                  ENDIF
                  CALL PLA053 (MPRM, INORM, M, 0, A2, SA2, ISA2,
     1                         IDEC5, IER)
                  IF (IER .NE. 0) GOTO 50
                  FORMA(1:21)  = '(A,F6.1,''('',I2,'')'',A,'
                  ISA2 = MIN (99, ISA2)
                  FORMA(7:7) = CHAR(ICHAR('0') + IDEC5)
                  IF (A2 .GT. 0.1) THEN
                    SUM  = A0 + A1 + A2
                    SSUM = SQRT(SA0**2 + SA1**2 + SA2**2)
                    CALL GEN041 (SUM, SSUM, ISUM, 2, IDEC7, IPR(68))
                    ISUM = MIN (99, ISUM)
                    IF (MDPRM .EQ. 0) THEN
                      FORMA(22:41) = '10X,F6.1,''('',I2,'')'')'
                      FORMA(29:29) = CHAR(ICHAR('0') + IDEC7)
                      WRITE (PRBUF(91:132), FORMA(1:41))
     1                  CHAR(39), A2, ISA2, CHAR(39), SUM, ISUM
                      MDPRM = M
                      SUM4  = A1
                      SSUM4 = SA1**2
                      GOTO 40
                    ENDIF
                    FORMA(22:37) = 'F6.1,''('',I2,'')'','
                    FORMA(38:70) = FORMA(22:37)//FORMA(22:37)//')'
                    CALL PLA053 (MDPRM, INORM, M, 0, A3, SA3, ISA3,
     1                           IDEC6, IER)
                    IF (IER .NE. 0) GOTO 50
                    ISA3 = MIN (99, ISA3)
                    FORMA(25:25) = CHAR(ICHAR('0') + IDEC6)
                    FORMA(41:41) = CHAR(ICHAR('0') + IDEC7)
                    IF (A3 .GT. 0.1) THEN
                      SUM4  = SUM4 + A1 + A3
                      SSUM4 = SQRT(SSUM4 + SA1**2 + SA3**2)
                      CALL GEN041 (SUM4, SSUM4, ISUM4, 2, IDEC8,
     1                             IPR(68))
                      ISUM4 = MIN (99, ISUM4)
                      FORMA(57:57) = CHAR(ICHAR('0') + IDEC8)
                      WRITE (PRBUF(91:132), FORMA) CHAR(34), A2, ISA2,
     1                     CHAR(34), A3, ISA3, SUM, ISUM, SUM4, ISUM4
                      GOTO 40
                    ENDIF
                  ENDIF
                  ITLC = ITLC - 1
                  GOTO 50
   40             IF (IGBL(63) .GT. 2) THEN
                    CALL PLA067 (LU7, PRBUF, 132, 1, 3)
                    IF (IWIN .EQ. 1) THEN
                      VRT = VRT - 0.5
                      CALL GGIP20 (0.0, PRBUF(12:90), 79, 0.35, 1, 2,
     1                             1.0, VRT)
                      NTEL = NTEL + 1
                    ENDIF
                    WRITE (LU6, 99980) PRBUF(12:90)
                  ENDIF
   50           CONTINUE
              ENDIF
            ENDIF
          ENDIF
   70   CONTINUE
   80 CONTINUE
      IF (IPR(88) .EQ. 0) THEN
        LINE = ':: No Classic Hydrogen Bonds Found'
        CALL PLA015 (0, 1)
        WRITE (LU6, 99986) LINE
        IF (IWIN .EQ. 1) THEN
          VRT = VRT - 2.5
          CALL GGIP20 (0.0, LINE, 50, 0.70, 2, 2, 2.5, VRT)
          VRT = VRT - 1.5
        ENDIF
        IF (IGBL(63) .GT. 2) THEN
          CALL PLA269 (1)
          WRITE (LU7, 99986) LINE
        ENDIF
      ELSE
        CALL PLA015 (0, 2)
      ENDIF
      IF (IPR(87) .NE. 0 .AND. INRM .NE. 0) THEN
        CALL PLA269 (5)
        WRITE (LU7, 99985)
        DO 100 I = 1, INRM
          J = NATM + IPR(24) + I
          CALL PLA047 (XLAB(J), NQ1, MNM, JDUM, IPR(119), IGBL(55),
     1                 0, 0)
          DO 90 K = 1, 3
            V5(K) = XXO(J, K + 3)
   90     CONTINUE
          CALL GEN002 (1, ROR, V5, V4, XLNG)
          CALL PLA269(1)
          WRITE (LU7, 99984) NQ1, (V4(K), K = 1, 3),
     1                            (V5(K), K = 1, 3)
  100   CONTINUE
      ENDIF
      IF (IPR(300) .GT. 0 .AND. NHEAD .NE. 0) THEN
        IF (NTEL .GT. 0) THEN
          VRT = VRT - 0.4
          CALL PLA043 (0, 0, 0, 0)
          CALL PLA043 (0, 0, LU6, 0)
        ENDIF
        CALL PLA043 (0, 0, LU7, 0)
        IF (IDC .GT. 0 .AND. IGBL(63) .GT. 2) THEN
          CALL PLA269 (2)
          WRITE (LU7, 99995)
        ENDIF
        IF (ITLC .GT. 0 .AND. IGBL(63) .GT. 2) THEN
          CALL PLA269 (6)
          WRITE (LU7, 99993)
        ENDIF
        IF (IPR(88) .GT. 0) THEN
          IF (IGBL(63) .GT. 2) THEN
            CALL PLA269 (6)
            WRITE (LU7, 99999)
          ENDIF
          DO 120 I = 1, NAT
            CALL GEN048 (-1, IFG(I), 23, IDA)
            IF (IDA .EQ. 1) THEN
              CALL PLA036 (I, 1, 1, IDS1, IDUM1, IDUM2, IPR(119),
     1                     IGBL(55))
              IF (IDS1 .GE. 500) THEN
                CALL GEN048 (-1, IFG(I), 21, IH)
                IF (IH .EQ. 1) THEN
                  IYH = 'H'
                ELSE
                  IYH = '-'
                ENDIF
                NC   = - NINT(CON(I, NP4))
                NCV  = 0
                NCVH = 0
                DO 110 J = 1, NC
                  K = NINT(CON(I, J))
                  IF (K .LE. NP1) THEN
                    NCV = NCV + 1
                    CALL GEN048 (-1, IFG(K), 7, IHA)
                    NCVH = NCVH + IHA
                  ENDIF
  110           CONTINUE
                IF (NCVH .EQ. 0) THEN
                  NYH = ' '
                ELSE
                  WRITE (NYH, 99979) NCVH
                ENDIF
                IF (IGBL(63) .GT. 2) THEN
                  CALL PLA269 (1)
                  NSUMH = IATP(I) + IFNT(I) + JCA(I)
                  NSUMT = NSUMH   + NCV - NCVH
                  WRITE (LU7, 99998) I, NAMS(1, 1), NCV, NYH, IYH,
     1               IATP(I), IFNT(I), JCA(I), NSUMH, NSUMT
                ENDIF
              ENDIF
            ENDIF
  120     CONTINUE
        ENDIF
      ENDIF
  130 CONTINUE
      RETURN
99999 FORMAT (/, 'Analysis of Potential Donor/Acceptor Atoms',
     1 ' -- (Major Disorder Form Only)', /, 132('='), //,
     2 'At.Nr  D/A', 4X, '#Cov.Bonds', 4X, '# H', 5X, '#D-H..A', 3X,
     3 '#A..H', 3X, '#A..H-C', 2X, 'Sum(A-H)', 3X, 'Sum(A-X)', /,
     4 132('-'))
99998 FORMAT (I4, 2X, A, 2X, I6, 6X, A, 1X, A, 5I9)
99997 FORMAT ('Analysis of Potential Hydrogen Bonds and Schemes with ',
     1 'd(D...A) < R(D)+R(A)+0', F3.2, ', d(H...A) < R(H)+R(A)',
     2 F5.2, ' Ang., D-H...A >', F6.1, ' Deg', /,
     3 132('='), /, 'Note: - ARU codes in [] are with reference to',
     4 ' the Coordinates printed above (Possibly transformed, when',
     5 ' MOVE .NE. 1.555)', /, 132('='), /)
99996 FORMAT ('Nr Typ Res Donor --- H....Acceptor [    ARU  ]', 6X,
     1 'D - H', 6X, 'H...A', 6X, 'D...A', 2X, 'D - H...A', 4X, 'A..H',
     2 '..A*', 1X, 'A''..H..A" Sum(XY,YZ)  Sum(XZ)', /, 132('-'))
99995 FORMAT (/, 'For C--H...Acceptor Interactions See: ',
     1 'Th. Steiner, Cryst. Rev, (1996), 6, 1-57')
99994 FORMAT (F9.2)
99993 FORMAT (/, 'H-Bond classification [G.A.Jeffrey, H.Maluszynska &',
     1 ' J.Mitra., Int.J.Biol.Macromol.(1985),7,336-348]', /, 132('-'),
     3 /, '2-Centre   (linear)     D-H...X most prob. angle 160 deg',
     4 '  - also: G.A.Jeffrey & W.Saenger, Hydrogen Bonding in ',
     5 'Biological Structures', /,
     6 '3-Centre (bifurcated)   SUM of 3 angl. about H = 360 deg',
     7 20X, 'Springer-Verlag, Berlin, 1991, pp 20.', /,
     8 '4-Centre (trifurcated)')
99992 FORMAT ('Donor --- H....Acceptor [    ARU  ]', 6X,
     1 'D - H', 6X, 'H...A', 6X, 'D...A', 2X, 'D - H...A')
99989 FORMAT (/, 'Problem in PLA090', 3I10, /)
99988 FORMAT ('X-H Bonds normalized: G.A. Jeffrey & L. Lewis',
     1 ', Carbohydr.Res. (1978), 60, 179', /,
     2 22X, 'R.Taylor & O.Kennard, Acta Cryst. (1983), B39, 133)', /)
99987 FORMAT ('HBON ', 3(A, ' '), 4F8.4, ' = ', /,
     1        5X, 2F10.4, 2F10.2, F12.0)
99986 FORMAT (/, A, /)
99985 FORMAT (/, 'Normalized X-H Atom Positions', /, 132('='), /,
     1        'Atom', 10X,  'x', 9X, 'y', 9X, 'z', 9X, 'XO', 8X, 'YO',
     2        8X, 'ZO', /, 132('-'))
99984 FORMAT (A, 6F10.4)
99983 FORMAT (/, ':: X-H Distances have been NORMALIZED', /)
99982 FORMAT (A, 2F10.0, 2A)
99981 FORMAT (1X)
99980 FORMAT (A)
99979 FORMAT (I1)
      END
      SUBROUTINE PLA091 (MODE)
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16,
     1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NPVD=40000000,
     2 NP22=256,NP23=18000,NP25=99,NP29=63,NP38=125,NP39=30,NP41=200,
     3 NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON // JNSC(2 * NP23), VOID(NPVD)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      CHARACTER IDS1*1, IDS2*1, FORMI*58, FORMJ*31, FORMK*16
      FORMI( 1:40) = '(I4,6X,2A,''['',F9.2,''] ... '',2A,''['',F9.2,'
      FORMI(41:58) = ' ''] = '',F6.3,F7.2)'
      FORMJ( 1:31) = '(I2,I3,F9.2,''  -- '',11(F9.2,A))'
      FORMK( 1:16) = '(19X,11(F9.2,A))'
      IF (PAR(42) .LT. 100.0) THEN
        FORMI(18:18) = '1'
        FORMI(39:39) = '1'
        FORMJ(11:11) = '1'
        FORMJ(27:27) = '1'
        FORMK(12:12) = '1'
      ENDIF
      NR1   = 0
      NS1   = 0
      NT11  = 0
      NT12  = 0
      NT13  = 0
      IAGGP = 0
      IARU  = NINT(PAR(42))
      NTOP  = IPR(299)
      NADD  = 25
      ITL   = IPR(88)
      IF (ITL .GT. 0) THEN
        IF (MODE .EQ. 0) THEN
          ITL2 = ITL * 2
          IF (ITL2 .GT. NP2) THEN
            WRITE (LU6, 99989)
            GOTO 150
          ENDIF
        ELSE
          ITL2 = ITL
        ENDIF
        NRES = IPR(75)
        NSYM = IPR(48)
        IF (IGBL(63) .GT. 2) CALL PLA269 (0)
        IF (MODE .EQ. 0) THEN
          IF (IGBL(63) .GT. 3) THEN
            CALL PLA269 (10)
            WRITE (LU7, 99999)
            WRITE (LU7, 99990)
          ENDIF
          DO 10 I = 1, ITL
            IATC(I)         = 1
            XLS(5, I)       = MOD(NINT(XLS(2, I) * IARU), IARU)
            MR1             = MOD(NINT(XLS(4, I) * IARU), IARU)
            XLS(5, ITL + I) = MR1
            XLS(9, ITL + I) = XLS(9, I)
            CALL PLA081 (5, XLS(4, I),       0.0,       XLS(2, ITL + I))
            IF (IPR(2) .NE. 0) GOTO 150
            CALL PLA081 (6, XLS(2, ITL + I), XLS(2, I), XLS(4, ITL + I))
            IF (IPR(2) .NE. 0) GOTO 150
            XLS(2, ITL + I) = (1555 * PAR(42) + MR1) / PAR(42)
            J               = NINT(XLS(1, I))
            K               = NINT(XLS(3, I))
            XLS(1, ITL + I) = K
            XLS(3, ITL + I) = J
            IDSORD = NINT(XLS(8, I))
            IF (IDSORD .EQ. 10) THEN
              IDISO = 1
            ELSE IF (IDSORD .EQ. 1) THEN
              IDISO = 10
            ELSE
              IDISO = IDSORD
            ENDIF
            XLS(8, ITL + I) = IDISO
            CALL PLA093 (I, J, K, 1)
            ITLPI = ITL + I
            CALL PLA093 (ITLPI, K, J, -1)
   10     CONTINUE
        ELSE
          IF (IGBL(63) .GT. 3) THEN
            CALL PLA269 (5)
            WRITE (LU7, 99992)
          ENDIF
          DO 20 I = 1, ITL
            IDSORD = NINT(XLS(8, I))
            IF (IDSORD / 10 .EQ. 1) THEN
              IDS1 = '*'
            ELSE
              IDS1 = ' '
            ENDIF
            IF (MOD(IDSORD, 10) .EQ. 1) THEN
              IDS2 = '*'
            ELSE
              IDS2 = ' '
            ENDIF
            CALL PLA047 (XLS(1, I), NQ1, IDUM, JDUM, IPR(119), IGBL(55),
     1                   0, 0)
            CALL PLA047 (XLS(3, I), NQ2, IDUM, JDUM, IPR(119), IGBL(55),
     1                   0, 0)
            IF (IGBL(63) .GT. 2) THEN
              CALL PLA269 (1)
              WRITE (LU7, FORMI) I, IDS1, NQ1(1:6), XLS(2, I), IDS2,
     1          NQ2(1:6), XLS(4, I), XLS(6, I), XLS(7, I)
            ENDIF
   20     CONTINUE
        ENDIF
        ITL0 = 0
        DO 40 J = 1, NSYM
          DO 30 I = 1, NRES
            IF (ITL0 .GE. NP1) GOTO 50
            ITL0 = ITL0 + 1
            IATP(ITL0) = (J * 1000 + 555) * IARU + I
   30     CONTINUE
   40   CONTINUE
   50   IAGG = 0
        N51  = IPR(51)
        L0   = 1
        CALL PLA040 (-1, 0, 0, 0, 0)
        DO 140 I = 1, ITL0
          N1   = 0
          LMX  = 1
          DMOL = IATP(I) / PAR(42)
          VOID(NTOP + (I - 1) * NADD + 1) = DMOL
          CALL GEN098 (IATP(I), PAR(42), MS1, MT1, MT2, MT3, MR0)
          IF (N51 .GT. 1) THEN
            DO 55 K = 2, N51
              ML = MOL(K)
              IF (MOD(ML, IARU) .EQ. MR0) THEN
                XMOL1 = ML / PAR(42)
                CALL PLA081 (7, DMOL, XMOL1, XMOL2)
                IF (IPR(2) .NE. 0) GOTO 150
                LMX = LMX + 1
                VOID(NTOP + (I - 1) * NADD + LMX) = XMOL2
                IFNT(LMX) = ICHAR('*')
              ENDIF
   55       CONTINUE
          ENDIF
          IF (L0 .LE. I) THEN
            CALL PLA040 (0, 0, 0, 0, 0)
            IAGGP = 1
            L0    = L0 + 1
            IF (N51 .GT. 1) THEN
              DO 70 K = 2, N51
                ML = MOL(K)
                IF (MOD(ML, IARU) .EQ. MR0) THEN
                  XMOL1 = ML / PAR(42)
                  DMOL =  VOID(NTOP + (I - 1) * NADD + 1)
                  CALL PLA081 (7, DMOL, XMOL1, XMOL2)
                  IF (IPR(2) .NE. 0) GOTO 150
                  MOL1 = INT(XMOL2 / 1000.0)
                  ML   = NINT(XMOL2 * PAR(42))
                  NMOL = MOL1 * 1000 * IARU + 555 * IARU + MR0
                  DO 60 L = L0, ITL0
                    IF (IATP(L) .EQ. NMOL) THEN
                      IATP(L)  = IATP(L0)
                      IATP(L0) = ML
                      L0       = L0 + 1
                      GOTO 70
                    ENDIF
   60             CONTINUE
                ENDIF
   70         CONTINUE
            ENDIF
          ENDIF
          DO 120 K = 1, ITL2
            N = NINT(XLS(5, K))
            IF (MR0 .EQ. N) THEN
              CALL PLA081 (8, DMOL, XLS(4, K), XMOL)
              IF (IPR(2) .NE. 0) GOTO 150
              N1 = N1 + 1
              DO 80 L = 1, LMX
                DMOLL = VOID(NTOP + (I - 1) * NADD + L)
                IF (NINT((DMOLL - XMOL) * PAR(42)) .EQ. 0) THEN
                  IF (L .EQ. 1) N1 = N1 - 1
                  GOTO 120
                ENDIF
   80         CONTINUE
              LMX = LMX + 1
              VOID(NTOP + (I - 1) * NADD + LMX) = XMOL
              IFNT(LMX) = ICHAR(' ')
              NMOL      = NINT(XMOL * PAR(42))
              CALL GEN098 (NMOL, PAR(42), MS2, MT21, MT22, MT23, MR2)
              DO 110 L = 1, ITL0
                CALL GEN098 (IATP(L), PAR(42), MS1, MT11, MT12,
     1               MT13, MR1)
                IF (MS2 .EQ. MS1 .AND. MR2 .EQ. MR1) THEN
                  IF (L .LT. L0) THEN
                    MD1 = MT21 - MT11
                    MD2 = MT22 - MT12
                    MD3 = MT23 - MT13
                    IF (IABS(MD1) + IABS(MD2) + IABS(MD3) .GT. 0)
     1               THEN
                      CALL PLA040 (1, MD1, MD2, MD3, 0)
                      IFNT(LMX) = ICHAR('T')
                    ENDIF
                  ELSE
                    IATP(L)  = IATP(L0)
                    IATP(L0) = NMOL
                    L0       = L0 + 1
                    IF (N51 .GT. 1) THEN
                      DO 100 K2 = 2, N51
                        ML = MOL(K2)
                        IF (MOD(ML, IARU) .EQ. MR2) THEN
                          XMOL1 = ML / PAR(42)
                          CALL PLA081 (9, XMOL, XMOL1, XMOL2)
                          IF (IPR(2) .NE. 0) GOTO 150
                          MOL2  = INT(XMOL2 / 1000.0)
                          NMOL2 = (MOL2 * 1000 + 555) * IARU + MR2
                          DO 90 L2 = L0, ITL0
                            IF (IATP(L2) .EQ. NMOL2) THEN
                              IATP(L2) = IATP(L0)
                              IATP(L0) = NINT(XMOL2 * PAR(42))
                              L0       = L0 + 1
                              GOTO 100
                            ENDIF
   90                     CONTINUE
                        ENDIF
  100                 CONTINUE
                    ENDIF
                  ENDIF
                ENDIF
  110         CONTINUE
            ENDIF
  120     CONTINUE
          M1 = LMX - 1
          IF (M1 .GT. 0) THEN
            IF (IAGGP .GT. 0) THEN
              IAGG  = IAGG + 1
              IF (IGBL(63) .GT. 2) THEN
                CALL PLA269 (7)
                IF (MODE .EQ. 0) THEN
                  WRITE (LU7, 99998) ' Aggregate =', IAGG
                  WRITE (LU7, 99997)
                ELSE
                  WRITE (LU7, 99998) '  Cluster  =', IAGG
                  WRITE (LU7, 99995)
                ENDIF
              ENDIF
              IAGGP = 0
            ENDIF
            IF (LMX .GT. 12) THEN
              LMZ = 12
            ELSE
              LMZ = LMX
            ENDIF
            NTP = NTOP + (I - 1) * NADD
            VOID(NTP + 25) = LMX
            IF (IGBL(63) .GT. 2) THEN
              CALL PLA269 (1)
              WRITE (LU7, FORMJ) N1, M1, VOID(NTP + 1),
     1          (VOID(NTP + L), CHAR(IFNT(L)), L = 2, LMZ)
            ENDIF
            IF (LMX .GT. 12) THEN
              LMB = 2
  130         LMB = LMB + 11
              LMZ = LMB + 10
              IF (LMZ .GT. LMX) LMZ = LMX
              IF (IGBL(63) .GT. 2) THEN
                CALL PLA269 (1)
              NTP = NTOP + (I - 1) * NADD
                WRITE (LU7, FORMK)
     1                (VOID(NTP + L), CHAR(IFNT(L)), L = LMB, LMZ)
              ENDIF
              IF (LMZ .LT. LMX) GOTO 130
            ENDIF
          ENDIF
  140   CONTINUE
        CALL PLA040 (0, 0, 0, 0, 0)
        IF (MODE .NE. 0 .OR. IGBL(63) .LE. 2) GOTO 150
        NCIR = 0
        N1   = 1
        N2   = 2
        MCIR = IPR(66)
        IF (MCIR .EQ. 0) N1 = 2
        MCHN = IPR(82)
        IF (MCHN .EQ. 0) N2 = 1
        IF (N2 .GE. N1) THEN
          DO 595 N3 = N1, N2
            IF (N3 .EQ. 1) THEN
              MC   = MCIR
              NCRA = 0
            ELSE
              MC   = MCHN
              NCRA = NCIR + 1
            ENDIF
            DO 590 NR = 1, NRES
              DO 505 I = 1, ITL0
                IF (MOD(IATP(I), IARU) .EQ. NR) GOTO 506
  505         CONTINUE
  506         NRT  = 1
              L0   = ITL0
              K    = I
  510         JR(NRT)   = NTOP + (K - 1) * NADD
              DATC(NRT) = VOID(JR(NRT) + 1)
              IF (NRT .GT. 1) THEN
                MOL2 = NINT(DATC(NRT) * PAR(42))
                CALL GEN098 (MOL2, PAR(42), NS2, NT21, NT22, NT23, NR2)
                IF (NS1 .EQ. NS2 .AND. NR1 .EQ. NR2) THEN
                  ND1 = NT21 - NT11
                  ND2 = NT22 - NT12
                  ND3 = NT23 - NT13
                  ND123 = IABS(ND1) + IABS(ND2) + IABS(ND3)
                  IF (N3 .EQ. 1) THEN
                    IF (ND123 .NE. 0) GOTO 526
                  ELSE
                    IF (ND123 .EQ. 0 .OR. NRT .GT. MCHN) GOTO 526
                  ENDIF
                  DO 509 KK = 1, NRT
                    JNSC(NCIR * 100 + KK) = NINT(DATC(KK) * PAR(42))
  509             CONTINUE
                  IF (NCIR .GT. NCRA + 1) THEN
                    DO 501 J = NCRA + 1, NCIR - 1
                      DO 515 K0 = 1, NRT - 1
                        DO 502 KK = 1, NRT - 1
                          KK0 = MOD(KK + K0 - 2, NRT - 1) + 1
                          IF (JNSC(NCIR * 100 + KK0) .NE.
     1                        JNSC(J * 100 + KK)) GOTO 504
  502                   CONTINUE
                        NRT = NRT - 1
                        GOTO 530
  504                   DO 503 KK = 1, NRT - 1
                          KK0 = MOD(KK + K0 - 2, NRT - 1) + 1
                          IF (JNSC(NCIR * 100 + NRT - KK0) .NE.
     1                        JNSC(J * 100 + KK)) GOTO 515
  503                   CONTINUE
                        NRT = NRT - 1
                        GOTO 530
  515                 CONTINUE
  501               CONTINUE
                  ENDIF
                  NCIR = NCIR + 1
                  IF (NCIR .EQ. 1) THEN
                    CALL PLA269 (4)
                    WRITE (LU7, 99985) IPR(66) - 1, IPR(82) - 1
                  ELSE IF ((NCIR + 1) * 100 .GT. 2.0 * NP23) THEN
                    GOTO 150
                  ENDIF
                  CALL PLA269 (3 + NRT / 14)
                  IF (ND123 .EQ. 0) THEN
                    WRITE (LU7, 99988) NRT - 1
                    WRITE (LU7, 99987) (DATC(KK), KK = 1, NRT)
                  ELSE
                    WRITE (LU7, 99986) NRT - 1, ND1, ND2, ND3
                    WRITE (LU7, 99987) (DATC(KK), KK = 1, NRT)
                  ENDIF
                  NRT = NRT - 1
                  GOTO 530
                ENDIF
              ELSE
                MOL1 = NINT(DATC(1) * PAR(42))
                CALL GEN098 (MOL1, PAR(42), NS1, NT11, NT12, NT13, NR1)
              ENDIF
  526         NCN(NRT)  = NINT(VOID(JR(NRT) + 25))
              IF (NRT .EQ. 1) THEN
                IF (NCN(1) .LT. 3) GOTO 590
              ENDIF
              IF (NRT .LT. MC) THEN
                NRT       = NRT + 1
                JLN(NRT)  = 1
              ENDIF
  530         JLN(NRT)  = JLN(NRT) + 1
              IF (NRT .LE. 1) GOTO 590
              IF (JLN(NRT) .GT. NCN(NRT - 1)) THEN
                NRT = NRT - 1
                IF (NRT .GT. 1) GOTO 530
                GOTO 590
              ENDIF
              XMOL = VOID(JR(NRT - 1) + JLN(NRT))
              IF (NRT .GT. 2) THEN
                IF (XMOL .EQ. DATC(NRT - 2)) GOTO 530
              ENDIF
              NMOL = NINT(XMOL * PAR(42))
              CALL GEN098 (NMOL, PAR(42), MS2, MT21, MT22, MT23, MR2)
              DO 540 L = 1, ITL0
                CALL GEN098 (IATP(L), PAR(42), MS1, MT11, MT12, MT13,
     1                       MR1)
                IF (MS2 .EQ. MS1 .AND. MR2 .EQ. MR1) THEN
                  MD1 = MT21 - MT11
                  MD2 = MT22 - MT12
                  MD3 = MT23 - MT13
                  IF (IABS(MD1) + IABS(MD2) + IABS(MD3) .NE. 0) THEN
                    NAD = MD1 * 100 + MD2 * 10 + MD3
                    L0 = L0 + 1
                    IF (L0 .GT. NP1) GOTO 590
                    IATP(L0) = IATP(L) + NAD * 100
                    N0 = INT(VOID(NTOP + (L - 1) * NADD + 25))
                    VOID(NTOP + (L0 - 1) * NADD + 25) = N0
                    DO 545 N = 1, N0
                      MOLY = NINT(VOID(NTOP + (L  - 1) * NADD + N)
     1                         * PAR(42))
                      CALL GEN098 (MOLY, PAR(42), MS3, MT31, MT32,
     1                             MT33, MR3)
                      MT31 = MT31 + MD1
                      IF (MT31 .LT. -5 .OR. MT31 .GT. 4) GOTO 530
                      MT32 = MT32 + MD2
                      IF (MT32 .LT. -5 .OR. MT32 .GT. 4) GOTO 530
                      MT33 = MT33 + MD3
                      IF (MT33 .LT. -5 .OR. MT33 .GT. 4) GOTO 530
                      VOID(NTOP + (L0 - 1) * NADD + N) =
     1                VOID(NTOP + (L  - 1) * NADD + N) + NAD
  545               CONTINUE
                    K = L0
                  ELSE
                    K = L
                  ENDIF
                ENDIF
  540         CONTINUE
              GOTO 510
  590       CONTINUE
  595     CONTINUE
        ENDIF
      ENDIF
  150 RETURN
99999 FORMAT ('Analysis of Hydrogen Bonded Molecular Aggregates',
     1 ' (See also Acta Cryst. B36, 1980, 2113 - 2115)',
     2 ' -- (Major Disorder Component Only)', /, 132('='), /)
99998 FORMAT (/, 57X, 14('='), /, 56('*'), A, I3,
     1 1X, 60('*'), /, 57X, 14('='), /)
99997 FORMAT ('(N:M)  :  ARU   --    Connected with N Hydrogen Bonds',
     1 ' to/from M ARU(S).', 4X, 'T = Translated Molecule (Infinite',
     2 ' chain etc.)', /, 132('-'))
99995 FORMAT ('(N:M)  :  ARU   --    Connected  with (N) Interactions',
     1 ' to/from (M) ARU(S).', 4X, 'T = Translated Molecule (Infinite',
     2 ' chain etc.)', /, 132('-'))
99992 FORMAT ('Analysis of Short Non-Hydrogen Inter-Molecular',
     1 ' Contacts For Inter-Molecular Clusters and/or Networks',
     2   3X,'(Minor Disorder Excluded)', /, 132('='), //,
     3 'Contact-Nr Atom I[   ARU   ]', 6X, 'Atom J[   ARU   ]', 4X,
     4 'd(I-J)', 3X, 'Del', /, 132('-'))
99990 FORMAT (/, 20X, 'Coordinates of Donor and Acceptor Atoms', 32X,
     1 'Coordinates of D/A-Bonded Atom(s)', /, 20X, 39('='), 32X,
     2 33('='), //, '  D/A I  [    ARU  ]      X      Y      Z   --',
     3 '  D/A J  [    ARU  ]      X      Y      Z', 3X,
     4 'Atom K     X      Y      Z   I..J--K Angle', /, 132('-'))
99989 FORMAT (':: Too Many Interactions for Aggregate Analysis', /)
99988 FORMAT (/, I3, '-Membered ARU-Circuit')
99987 FORMAT (14F9.2)
99986 FORMAT (/, I3, '-Membered Infinite ARU-Chain (Translation [',
     1        3I3, '])')
99985 FORMAT (/, 'Search for ARU-Circuits (Max =', I3, ') and',
     1        ' Infinite ARU-Chains (Max =', I3, ')', /, 132('='), /)
      END
      SUBROUTINE PLA092
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16,
     1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP22=256,NP25=99,
     2 NP29=63,NP38=125,NP39=30,NP41=200,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      CHARACTER IDS1*1, IDS2*1, IYA*1, COPT*5
      ITL = IPR(88)
      IF (ITL .EQ. 0) GOTO 250
      MXLSP = NP2
      CALL PLA040 (-1, 0, 0, 0, 0)
      MXRING = IPR(218)
      IF (IGBL(63) .GT. 2) THEN
        CALL PLA269 (-3)
        WRITE (LU7, 99998) MXRING
      ENDIF
      NETW = 0
      L0   = 0
      KAT  = IPR(39) + IPR(24) + 1
      JAT  = KAT + 1
      IAT  = JAT + 1
      I    = 0
   10 I    = I + 1
      IF (I .GT. ITL) GOTO 240
      LFORW = 1
      IF (L0 .LE. I) THEN
        L0 = 0
        DO 40 J = I, ITL
          IF (IATC(J) .GT. 0) THEN
            L1 = NINT(XLS(1, J))
            CALL GEN048 (-1, IFG(L1), 22, IA)
            IF (IA .EQ. 0) GOTO 50
            IF (L0 .EQ. 0) L0 = J
          ENDIF
   40   CONTINUE
        IF (L0 .EQ. 0) THEN
          GOTO 240
        ELSE
          J = L0
        ENDIF
   50   CALL PLA040 (0, 0, 0, 0, 0)
        NETW = NETW + 1
        IF (IGBL(63) .GT. 2) THEN
          CALL PLA269 (7)
          WRITE (LU7, 99997) NETW
          WRITE (LU7, 99996)
        ENDIF
        J0    = J
        L0    = I
        XLSI3 = XLS(1, J0)
        XLSI4 = XLS(2, J0)
        JMX   = 99
        GOTO 90
      ENDIF
   70 IF (XLS(8, I) .LE. 0) THEN
        J0        = I
        LFORW     = -1
        XLS(8, I) = 1
        XLSI3     = XLS(1, J0)
        XLSI4     = XLS(2, J0)
        JMX       = 99
        GOTO 90
      ENDIF
      XLSI2 = XLS(2, I)
      XLSI3 = XLS(3, I)
      XLSI4 = XLS(4, I)
      M     = NINT(XLS(1, I))
      N     = NINT(XLSI3)
      NH    = NINT(XLS(10, I))
      CALL PLA047 (XLAB(M),  NQ1, IDUM, JDUM, IPR(119), IGBL(55), 0, 0)
      CALL PLA047 (XLAB(N),  NQ2, IDUM, JDUM, IPR(119), IGBL(55), 0, 0)
      CALL PLA047 (XLAB(NH), NQ3, IDUM, JDUM, IPR(119), IGBL(55), 0, 0)
      CALL GEN048 (-7, JFG(M), 1, IDIS1)
      IPOPM = IPPR(IDIS1 + 1, 1)
      IF (IPOPM .LT. 1000) THEN
        IDS1 = '*'
      ELSE
        IDS1 = ' '
      ENDIF
      CALL GEN048 (-7, JFG(N), 1, IDIS2)
      IPOPN = IPPR(IDIS2 + 1, 1)
      IF (IPOPN .LT. 1000) THEN
        IDS2 = '*'
      ELSE
        IDS2 = ' '
      ENDIF
      MS1 = NINT(XLSI2 * PAR(42))
      CALL GEN098 (MS1, PAR(42), IPR(54), ITR(1), ITR(2), ITR(3), IML)
      CALL PLA059 (M,  KAT)
      CALL PLA059 (NH, IAT)
      MS2 = NINT(XLSI4 * PAR(42))
      CALL GEN098 (MS2, PAR(42), IPR(54), ITR(1), ITR(2), ITR(3), IML)
      CALL PLA059 (N, JAT)
      CALL GEN048 (-1, IFG(M), 22, IA)
      IF (IA .EQ. 1) THEN
        IYA = 'A'
      ELSE
        IYA = ' '
      ENDIF
      JMX = 4
   90 K   = 0
  100 K   = K + 1
      IF (K .GT. ITL) GOTO 220
      IF (IATC(K) .NE. 0) THEN
        IF (XLS(1, K) .EQ. XLSI3) THEN
          IHBD = 1
          CALL PLA081 (10, XLS(2, K), 0.0, XLSK2)
          IF (IPR(2) .NE. 0) GOTO 250
          CALL PLA081 (11, XLSK2, XLS(4, K), XLSK4)
          IF (IPR(2) .NE. 0) GOTO 250
          CALL PLA081 (12, XLSI4, XLSK4, XLS4)
          IF (IPR(2) .NE. 0) GOTO 250
          XLS2 = XLSI4
          GOTO 140
        ENDIF
        IF (K .NE. I) THEN
          IF (NINT(XLS(3, K)) .EQ. NINT(XLSI3)) THEN
            IHBD = -1
            CALL PLA081 (13, XLS(4, K), 0.0, XLSK4)
            IF (IPR(2) .NE. 0) GOTO 250
            CALL PLA081 (14, XLSK4, XLS(2, K), XLSK2)
            IF (IPR(2) .NE. 0) GOTO 250
            CALL PLA081 (15, XLSI4, XLSK2, XLS2)
            IF (IPR(2) .NE. 0) GOTO 250
            XLS4 = XLSI4
            GOTO 140
          ENDIF
        ENDIF
      ENDIF
      GOTO 100
  140 XML = K + 0.555
      L = L0
  150 L = L - 1
      IF (L .NE. 0) THEN
        IF (XLS(1, L) .NE. XLS(1, K)) GOTO 150
        IF (XLS(3, L) .NE. XLS(3, K)) GOTO 150
        ID1 = INT(XLS2)
        ID2 = INT(XLS(2, L))
        IF (ID1 / 1000 .NE. ID2 / 1000) GOTO 150
        IDF1 = ID1 - ID2
        ID3  = INT(XLS4)
        ID4  = INT(XLS(4, L))
        IF (ID3 / 1000 .NE. ID4 / 1000) GOTO 150
        IDF2 = ID3 - ID4
        IF (IDF1 .NE. IDF2) GOTO 150
        XML = L + (IDF1 + 555) / 1000.0
        IF (IDF1 .EQ. 0) THEN
          IF (LFORW .GT. 0) THEN
             IXPVJ = 82
          ELSE
             IXPVJ = 32
          ENDIF
        ELSE
          IXPVJ = 84
          IDFX  = IDF1 + 555
          MD1   = IDFX / 100
          IDFX  = IDFX - MD1 * 100
          MD1   = MD1 - 5
          MD2   = IDFX / 10
          MD3   = IDFX - MD2 * 10 - 5
          MD2   = MD2 - 5
          CALL PLA040 (1, MD1, MD2, MD3, 0)
        ENDIF
        GOTO 210
      ENDIF
      IXPVJ  = 32
      IATCK  = IATC(K)
      IATCL0 = 0
      IF (IATCK .GE. 0) THEN
        IATCL0 = -1
        IATCK  = 0
      ENDIF
      IATCTL = IATC(L0)
      IF (L0 .EQ. K) IATCTL = 0
      IF (ITL .EQ. MXLSP) GOTO 100
      ITL = ITL + 1
      DO 180 J = 1, 10
        XLS(J, ITL) = XLS(J, L0)
  180 CONTINUE
      IATC(K)     = IATCK
      IATC(ITL)   = IATCTL
      IATC(L0)    = IATCL0
      XLS(1,  L0) = XLS(1, K)
      XLS(3,  L0) = XLS(3, K)
      XLS(2,  L0) = XLS2
      XLS(4,  L0) = XLS4
      XLS(5,  L0) = 0.0
      XLS(6,  L0) = 0.0
      XLS(7,  L0) = 0.0
      XLS(8,  L0) = IHBD
      XLS(9,  L0) = XLS(9, K)
      XLS(10, L0) = XLS(10, K)
      XML        = L0 + 0.555
      L0         = L0 + 1
      IF (L0 .GT. ITL) GOTO 210
      IF (IATCTL  .EQ. 0) GOTO 200
      IF (IATC(K) .NE. 0) GOTO 210
      DO 190 J = 1, 10
         XLS(J, K) = XLS(J, ITL)
  190 CONTINUE
      IATC(K) = IATC(ITL)
  200 ITL     = ITL - 1
  210 IF (JMX  .GT. 7) GOTO 100
      IF (IHBD .LT. 0) GOTO 100
      JMX         = JMX + 1
      XLS(JMX, I) = XML
      IXPV(JMX)   = IXPVJ
      GOTO 100
  220 CONTINUE
      IF (JMX .EQ. 99) GOTO 70
      YI   = I + 0.555
      JMX0 = JMX
      IF (JMX0 .GT. 7) JMX0 = 7
      IF (IGBL(63) .GT. 2) THEN
        CALL PLA269 (2)
        WRITE (LU7, 99995) YI, IYA, IDS1, NQ1(1:6), XLSI2,
     1    (XXO(KAT, J), J = 1, 3),  IDS2, NQ2(1:6), XLS(4, I),
     2    (XXO(JAT, J), J = 1, 3),
     3    (XLS(J, I), CHAR(IXPV(J)), J = 5, JMX0)
        WRITE (LU7, 99993) NQ3, (XXO(IAT, J), J = 1, 3)
      ENDIF
  230 CONTINUE
      IF (JMX0 .LT. JMX) THEN
        JMXB = JMX0 + 1
        JMX0 = JMX
        IF (JMX0 .GT. JMXB + 2) JMX0 = JMXB + 2
        IF (IGBL(63) .GT. 2) THEN
          CALL PLA269 (1)
          WRITE (LU7, 99994) (XLS(J, I), CHAR(IXPV(J)), J = JMXB, JMX0)
        ENDIF
        GOTO 230
      ENDIF
      GOTO 10
  240 CALL PLA040 (0, 0, 0, 0, 0)
      IF (IGBL(63) .GT. 2) THEN
        CALL PLA269 (9)
        WRITE (LU7, 99999)
      ENDIF
      IPR(224) = ITL
      NRRING = 0
      KAT    = IPR(39) + IPR(24)
      NRTM     = MXRING + 1
      DO 390 J = 1, ITL
        JAT = NINT(XLS(1, J))
        CALL GEN048 (-1, IFG(JAT), 22, IA)
        IF (IA .GT. 0) THEN
          JR(1) = J * 1000 + 555
          ML    = NINT(XLS(2, J) * PAR(42))
          CALL GEN098 (ML, PAR(42), IPR(54), ITR(1), ITR(2), ITR(3),
     1                 MR1)
          JRAT = KAT + 1
          CALL PLA059 (JAT, JRAT)
          NRT      = 1
  310     NCN(NRT) = 4
          JRNRT    = JR(NRT) / 1000
          DO 320 I = 5, 7
            IF(XLS(I, JRNRT) .NE. 0.0) NCN(NRT) = I
  320     CONTINUE
          NRT      = NRT + 1
          JLN(NRT) = 4
  330     JLN(NRT) = JLN(NRT) + 1
          IF (JLN(NRT) .GT. NCN(NRT - 1)) THEN
            NRT = NRT - 1
            IF (NRT .GT. 1) GOTO 330
            GOTO 390
          ENDIF
          NRTM1   = NRT - 1
          NRTM2   = NRT - 2
          JRNRTM1 = JR(NRTM1) / 1000
          JRDIF   = MOD(JR(NRTM1), 1000)
          IF (NRT .EQ. NRTM) NRTM2 = 1
          JR(NRT) = NINT(XLS(JLN(NRT), JRNRTM1) * 1000 - 555 + JRDIF)
          J0    = JR(NRT) / 1000
          JRDIF = MOD(JR(NRT), 1000)
          IF (J0 .EQ. 0) THEN
            WRITE (LU6, '(''>> J0=0 Problem in PLA092, Loop abort'')')
            GOTO 250
          ENDIF
          ML    = NINT((XLS(2, J0) - 555 + JRDIF) * PAR(42))
          CALL GEN098 (ML, PAR(42), IPR(54), ITR(1), ITR(2), ITR(3),
     1                 MR1)
          JAT = NINT(XLS(1, J0))
          JRAT = KAT + NRT
          IF (JAT .LE. 0) THEN
            WRITE (LU6, 99989) NRT, J0, JAT
            WRITE (LU7, 99989) NRT, J0, JAT
            GOTO 250
          ENDIF
          CALL PLA059 (JAT, JRAT)
          IF (NRT .GT. 3) THEN
            DO 340 I = 2, NRTM2
              IF (JR(NRT) .EQ. JR(I)) GOTO 330
  340       CONTINUE
          ENDIF
          JRD  = JR(NRT) / 1000
          JRDT = JR(NRT) - JRD * 1000
          IF (JRD .EQ. J) THEN
            IF (JRDT .EQ. 555) THEN
              COPT = 'Ring '
            ELSE
              COPT = 'Chain'
              GOTO 355
            ENDIF
          ELSE
            IF (JR(NRT) .LT. JR(1)) THEN
              GOTO 330
            ELSE IF (JR(NRT) .GT. JR(1)) THEN
              GOTO 380
            ENDIF
          ENDIF
          IF (NRTM1 .LT. 3) GOTO 330
  355     IF (IGBL(63) .GT. 2) THEN
            CALL PLA269 (NRTM1 + 5)
            WRITE (LU7, 99992) NRTM1, COPT, JRDT
          ENDIF
          NRRING = NRRING + 1
          IF (NRRING .GT. 15) THEN
            WRITE (LU6, 99988)
            GOTO 250
          ENDIF
          WRITE (LU6, 99990) NRTM1, COPT, JRDT
          DO 370 K = 1, NRTM1
            L    = JR(K) / 1000
            IDIF = JR(K) - L * 1000
            M    = NINT(XLS(1, L))
            CALL PLA047 (XLAB(M), NQ1, IDUM, JDUM, IPR(119), IGBL(55),
     1                   0, 0)
            IF (IGBL(63) .GT. 2) WRITE (LU7, 99991)
     1        JR(K) / 1000.0, NQ1(1:6), XLS(2, L) - 555 + IDIF,
     2         (XXO(KAT + K, N), N = 1, 6), XLS(9, L)
  370     CONTINUE
          IF (NRT .EQ. NRTM) NRT = NRT - 1
          GOTO 330
  380     IF (NRT .EQ. NRTM) GOTO 330
          GOTO 310
        ENDIF
  390 CONTINUE
  250 RETURN
99999 FORMAT (/, 44X, 30('-'), //, 'Hydrogen Bonds are Coded as',
     1 ' N.IJK Where N       = Sequence Number of Hydrogen Bond',
     2 ' (NOTE: New Hbond Numbering system)', /,
     3   40X, 'I - 5   = Nr of Translation Units Along A-Axis', /,
     4   40X, 'J - 5   = Nr of Translation Units Along B-Axis', /,
     5   40X, 'K - 5   = Nr of Translation Units Along C-Axis', //,
     6 'Ring Closure Links are Indicated',
     7 ' with ''R'' and Infinite Chain Links With ''T'' ')
99998 FORMAT ('Analysis of the (Cooperative) Hydrogen Bond Network',
     1 '  (i.e. (In)Finite O-H...O-H...O-H..  Chains and/or Rings',
     2 ' (Max =', I3, ' Membered))', /, 132('='), /)
99997 FORMAT (/, 57X, 12('='), /, 56('*'), ' NetworK =', I3, 1X,
     1 62('*'), /, 57X, 12('='), /)
99996 FORMAT (2X, 'Code Acc    Donor Atom', 10X, 'X', 7X, 'Y', 7X, 'Z',
     1 7X, 'Acceptor Atom', 7X, 'X', 7X, 'Y', 7X, 'Z ',
     2 'up to BondCode(s) of Forward Link(s)', /, 132('-'))
99995 FORMAT (F6.3, 2X, A, 2X, A, A, '[', F9.2,']', 3F8.4, 2X, A,
     1 A, '[', F9.2, ']', 3F8.4, 3(F9.3, A))
99994 FORMAT (96X, 3(F9.3, A))
99993 FORMAT (12X, A, 10X, 3F8.4)
99992 FORMAT (/, 'Directed', I3,
     1  '-Membered Cooperative O-H...O-H...O-H.. ', A, ', - Code',
     2  I4, /, 90('='), /, 'BondCode', 2X, 'Donor Atom', 12X, 'X',
     3 7X, 'Y', 7X, 'Z', 10X, 'XO', 7X, 'YO', 7X, 'ZO', 4X, 'D-H...A',
     4 /, 90('='))
99991 FORMAT (F7.3, 2X, A, '[', F9.2, ']', 2X, 3F8.4, 2X, 3F9.4, F9.2)
99990 FORMAT (':: Directed', I3, '-Membered O-H...O-H...O-H.. ',
     1        A, ' - Code', I4)
99989 FORMAT (/, '=>> Problem with ring-search; aborted', 3I10, /)
99988 FORMAT (/, ':: Too many rings - Listing Aborted')
      END
      SUBROUTINE PLA093 (I, J, K, IDIRCT)
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16,
     1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP22=256,NP25=99,
     2 NP29=63,NP38=125,NP39=30,NP41=200,NP45=2048,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /Q/ ICL, IFL(NP17)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      CHARACTER DIRECT*4, IDS*1, FORMA*27, FORMB*78, FORMC*32
      A3   = 0.0
      SA3  = 0.0
      ISA3 = 0
      NDEC = 0
      FORMA(1:27)  = '   A,3F7.4,F8.2,''('',I3,'')'')'
      FORMB(1:39)  = '(1X,A,''['',F9.2,''], '',3F7.4,2A,''['',F9.2,'
      FORMB(40:51) = '''], '',3F7.4,'
      FORMC(1:5)   = '(89X,'
      IF (IDIRCT .GT. 0) THEN
        DIRECT = ' >> '
      ELSE
        DIRECT = ' << '
      ENDIF
      IDSORD = NINT(XLS(8, I))
      CALL PLA047 (XLAB(J), NQ1, IDUM, JDUM, IPR(119), IGBL(55), 0, 0)
      IF (IDSORD / 10 .EQ. 1) THEN
        IDS = '*'
      ELSE
        IDS = ' '
      ENDIF
      NAMS(1, 1) = IDS//NQ1
      CALL PLA047 (XLAB(K), NQ2, IDUM, JDUM, IPR(119), IGBL(55), 0, 0)
      IF (MOD(IDSORD, 10) .EQ. 1) THEN
        IDS = '*'
      ELSE
        IDS = ' '
      ENDIF
      NAMS(1, 2) = IDS//NQ2
      NMOL = NINT(XLS(4, I) * PAR(42))
      CALL GEN098 (NMOL, PAR(42), MS1, MT1, MT2, MT3, MR1)
      DO 10 L = 1, 3
         XJX(L) = XXO(K, L)
   10 CONTINUE
      XJX(4) = MT1
      XJX(5) = MT2
      XJX(6) = MT3
      CALL SGSM (ICL, MS1, XJX, LU7, 3, IERR)
      IF (IPR(39) + 2 .LE. NP1 - IPR(75)) THEN
        K0 = IPR(39) + 1
        DO 20 L = 1, 3
          XXO(K0, L) = XJX(L + 6)
   20   CONTINUE
        IF (IPR(167) .EQ. 1) THEN
          WRITE (LU2, 99999)
     1     NQ1(1:6), XLS(2, I), (XXO(J,  L), L = 1, 3),
     2     NQ2(1:6), XLS(4, I), (XXO(K0, L), L = 1, 3)
        ENDIF
        CALL PLA059 (K0, K0)
        NC = - NINT(CON(K, NP4))
        IF (NC .LT. 0) NC = NP4
        IF (NC .GT. 0) THEN
          DO 50 L = 1, NC
            M = NINT(CON(K, L))
            IF (M .LE. NP1) THEN
              CALL PLA047 (XLAB(M), NQ3, IDUM, JDUM, IPR(119), IGBL(55),
     1                     0, 0)
              CALL GEN048 (-7, JFG(M), 1, IDIS3)
              IPOPM = IPPR(IDIS3 + 1, 1)
              IF (IPOPM .LT. 1000) THEN
                IDS = '*'
              ELSE
                IDS = ' '
              ENDIF
              NAMS(1, 3) = IDS//NQ3
              DO 30 N = 1, 3
                XJX(N) = XXO(M, N)
   30         CONTINUE
              CALL SGSM (ICL, MS1, XJX, LU7, 3, IERR)
              N0 = IPR(39) + 2
              DO 40 N = 1, 3
                XXO(N0, N) = XJX(N + 6)
   40         CONTINUE
              CALL PLA059 (N0, N0)
              CALL PLA053 (J, K0, N0, 0, A3, SA3, ISA3, NDEC, IER)
              IF (IER .NE. 0) GOTO 50
              FORMA(15:15) = CHAR(ICHAR('0') + NDEC)
              IF (IGBL(63) .GT. 3) THEN
                IF (L .EQ. 1) THEN
                  FORMB(52:78) = FORMA
                  WRITE (PRBUF, FORMB) NAMS(1, 1), XLS(2, I),
     1              (XXO(J,  N), N = 1, 3), DIRECT, NAMS(1, 2),
     2              XLS(4, I), (XXO(K0, N), N = 1, 3), NAMS(1, 3),
     3              (XXO(N0, N), N = 1, 3), A3, ISA3
                ELSE
                  FORMC(6:32) = FORMA
                  WRITE (PRBUF, FORMC) NAMS(1, 3),
     1              (XXO(N0, N), N = 1, 3), A3, ISA3
                ENDIF
                CALL PLA067 (LU7, PRBUF, 132, 1, 3)
              ENDIF
            ENDIF
   50     CONTINUE
        ENDIF
      ENDIF
      RETURN
99999 FORMAT ('HBON ', A, '[', F8.2, ']', 3F7.4,
     1        1X, A, '[', F8.2, ']', 3F7.4)
      END
      SUBROUTINE PLA094 (MODE)
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118,
     1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NPVD=40000000,
     2 NP23=18000,NP25=99,NP29=63,NP38=125,NP39=30,NP41=200,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9),
     1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10),
     2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10),
     3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770)
      COMMON // JNSC(2 * NP23), VOID(NPVD)
      COMMON /PL40/ LHNT(4, 3, 5), NETH(64, 3), MXL
      DIMENSION IRCONT(63), JRCONT(63)
      IPR(30)  =  1
      IPR(18)  = -1
      IGBL(60) =  0
      CALL PLA040 (-1, 0, 0, 0, 0)
      NATC = IPR(37)
      NSYM = IPR(48)
      NRES = IPR(75)
      IARU = NINT(PAR(42))
      DO 10 I = 1, NATC
        IF (IATP(I) .NE. 1555) IGBL(60) = IGBL(60) + 1
   10 CONTINUE
      IF (IPR(13) .GT. 1) THEN
        MMO = IPR(13)
        IF (MODE .LE. 0) GOTO 120
        MMO = MMO + 1
   20   MMO = MMO - 1
        IF (MMO .GT. 1) THEN
          CALL GEN098 (MOL(MMO), PAR(42), IS1, IX1, IY1, IZ1, IR1)
          MM1 = MMO
   30     MM1 = MM1 - 1
          IF (MM1 .EQ. 0) GOTO 20
          CALL GEN098 (MOL(MM1), PAR(42), IS2, IX2, IY2, IZ2, IR2)
          IF (IS1 .EQ. IS2) THEN
            IF (IR2 .EQ. 0) IR2 = IR1
            IF (IR1 .EQ. IR2) THEN
              IX3 = IX2 - IX1
              IY3 = IY2 - IY1
              IZ3 = IZ2 - IZ1
              IF (IABS(IX3) + IABS(IY3) + IABS(IZ3) .NE. 0) THEN
                CALL PLA040 (1, IX3, IY3, IZ3, IR2)
              ENDIF
            ENDIF
          ENDIF
          GOTO 30
        ENDIF
   40   CALL GEN022 (MOL, 2, IPR(13))
        MMO  = IPR(13)
        IF (IGBL(97) .NE. 0) THEN
          MMO  = MMO + 1
   50     MMO  = MMO - 1
          IF (MOL(MMO) / (1000 * IARU) .GT. NSYM) GOTO 50
          IPR(101) = IPR(13) - MMO
          MM1  = MMO + 1
   60     MM1  = MM1 - 1
          IF (MM1 .GT. 1) THEN
            CALL GEN098 (MOL(MM1), PAR(42), IS1, IX1, IY1, IZ1, IR1)
            XM1  = MOL(MM1) / PAR(42)
            MM2  = MMO + 1
   70       MM2  = MM2 - 1
            IF (MM2 .EQ. 1) GOTO 60
            CALL GEN098 (MOL(MM2), PAR(42), IS2, IX2, IY2, IZ2, IR2)
            XM2  = MOL(MM2) / PAR(42)
            IF (IR2 .NE. IR1) GOTO 70
            CALL PLA081 (16, XM1, XM2, XM3)
            IF (IPR(2) .NE. 0) THEN
              IF (IPR(210) .NE. 1) THEN
                IPR(2) = 0
                GOTO 90
              ELSE
                WRITE (LU6, 99999)
                CALL PLA004 (0)
              ENDIF
            ENDIF
            MOLN = NINT(XM3 * PAR(42))
            CALL GEN098 (MOLN, PAR(42), IS3, IX3, IY3, IZ3, IR3)
            IF (IS3 .EQ. 1) THEN
              IF (IABS(IX3) + IABS(IY3) + IABS(IZ3) .NE. 0) THEN
                MLTI(IR3) = -1
                CALL PLA040 (1, IX3, IY3, IZ3, IR3)
              ENDIF
              GOTO 70
            ENDIF
            DO 80 L = 1, MMO
              CALL GEN098 (MOL(L), PAR(42), IS4, IX4, IY4, IZ4, IR4)
              IF (L .EQ. 1) IR4 = IR3
              IF (IR3 .EQ. IR4 .AND. IS3 .EQ. IS4) THEN
                IX5 = IX4 - IX3
                IY5 = IY4 - IY3
                IZ5 = IZ4 - IZ3
                IF (IABS(IX5) + IABS(IY5) + IABS(IZ5) .NE. 0) THEN
                  CALL PLA040 (1, IX5, IY5, IZ5, IR3)
                ENDIF
                GOTO 70
              ENDIF
   80       CONTINUE
            IF (IPR(13) + 3 .LT. NP11) THEN
              IPR(13) = IPR(13) + 1
              MOL(IPR(13)) = MOLN
              IF (MLTI(IR3) .GT. 0) MLTI(IR3) = MLTI(IR3) + 1
              GOTO 40
            ELSE
              IPR(138) = IPR(138) + 1
            ENDIF
          ENDIF
        ENDIF
   90   DO 100 MM = 2, MMO
          M1 = MOD(MOL(MM), IARU)
          M2 = MOL(MM) / IARU
          MOL(MM) = M1 * 1000000 + M2
  100   CONTINUE
        CALL GEN022 (MOL, 2, MMO)
        DO 110 MM = 2, MMO
          M1 = MOL(MM) / 1000000
          M2 = MOD(MOL(MM), 1000000)
          MOL(MM) = M2 * IARU + M1
  110   CONTINUE
  120   DO 150 MM = 2, MMO
          CALL GEN098 (MOL(MM), PAR(42), IPR(54), ITR(1), ITR(2),
     1         ITR(3), IR)
          IF (MM .GT. IPR(463) - 1) THEN
            IPR(2) = 54
            GOTO 340
          ENDIF
          MN = MM - 1
          I = 0
  130     I = I + 1
          IF (I .LE. NATC) THEN
            CALL GEN048 (-6, IFG(I), 9, IRESI)
            IF (IRESI .NE. IR) GOTO 130
            CALL GEN048 (-7, JFG(I), 1, IPP)
            IPR(128) = IPPR(IPP + 1, 1) * IPPR(IPP + 1, 3) / NSYM
            IPR(127) = IPPR(IPP + 1, 1)
            IF (IPR(127) .LT. 1000) THEN
              IPR(98) = 1
            ELSE
              IPR(98) = 0
            ENDIF
            KAT = IPR(39) + 1
            IF (KAT .GE. NP1) THEN
              IPR(2) = 1
              GOTO 280
            ENDIF
            CALL PLA059 (I, KAT)
            NAT = IPR(39)
            J   = 0
  140       J   = J + 1
            IF (J .LE. NAT) THEN
              CALL PLA050 (J, KAT, 0, 0, DIJ)
              IF (DIJ .LT. PAR(18)) GOTO 130
              GOTO 140
            ENDIF
            IPR(39) = IPR(39) + 1
            IF (MN .GT. IPR(463) - 1) THEN
              IPR(2) = 54
              GOTO 340
            ENDIF
            XLAB(KAT) = XLAB(I) + MN
            IFG(KAT)  = IFG(I)
            JFG(KAT)  = JFG(I)
            CALL GEN048 (1, IFG(KAT), 5, 1)
            CON(KAT, NP4) = 0.0
            IF (MODE .EQ. 1) THEN
              XM1 = (MOL(MM) - IR) / PAR(42)
              XM2 = IABS(IATP(I))
              CALL PLA081 (17, XM1, XM2, XM3)
              IF (IPR(2) .NE. 0) GOTO 280
              IATP(KAT) = INT(XM3)
            ENDIF
            GOTO 130
          ENDIF
  150   CONTINUE
      ENDIF
      DO 160 I = 1, NRES
        IRCONT(I) = (NP1 * 100 + I) * 1000 + MLTI(I) + 1
  160 CONTINUE
      NAT = IPR(39)
      DO 210 I = 1, NAT
        CALL GEN048 (-6, IFG(I), 9, IRESI)
        IRCONT(IRESI) = IRCONT(IRESI) - 100000
        IF (I .GT. 1) THEN
          N2  = I - 1
          CALL GEN048 (-4, IFG(I), 15, NO1)
          IENI     = IEN(NO1 + 1)
          DMX      = RADR(NO1 + 1, 2) + PAR(1)
          IATPRI   = IATPR(IENI)
          IPR(191) = ISIGN(1, IATPRI)
          NUMO = 0
          NUMS = 0
          IF (IENI .GE. 4 .AND. IENI .LE. 8) THEN
            DO 170 J = 1, NAT
              IF (I .NE. J) THEN
                CALL PLA050 (I, J, 0, 0, DIST)
                IF (DIST .LT. 2.1) THEN
                  CALL GEN048 (-4, IFG(J), 15, IVAL)
                  IVAL = IEN(IVAL + 1)
                  IF (DIST .LT. 1.7) THEN
                    IF (IVAL .EQ. 3) NUMO = NUMO + 1
                  ENDIF
                  IF (IVAL .EQ. 6) NUMS = NUMS + 1
                ENDIF
              ENDIF
  170       CONTINUE
            IF (IENI .EQ. 4 .AND. NUMO .EQ. 3) NUMO = -1
            IF (IENI .EQ. 5 .AND. NUMO .EQ. 4) NUMO = -1
            IF (IENI .EQ. 6 .AND. NUMO .EQ. 4) NUMO = -1
            IF (IENI .EQ. 8 .AND. (NUMO + NUMS) .EQ. 4) NUMO = -1
            IF (NUMO .LT. 0) CALL GEN048 (1, IFG(I), 31, 1)
          ENDIF
          IF (IENI .EQ. 10 .OR. IENI .EQ. 11 .OR.
     1        IENI .EQ. 30 .OR. IENI .EQ. 59 .OR.
     2        IENI .EQ. 94) THEN
            IPR(157) = IENI
          ELSE IF (IATPRI .EQ. 5 .OR. IATPRI .EQ. 6) THEN
            IPR(157) = 1
          ELSE IF (IPR(325) .EQ. 0 .AND. IATPRI .LT. 0) THEN
            IF (IENI .GE. 3 .AND. IENI .LE. 5) THEN
              IPR(157) = - IENI
            ELSE
              IPR(157) = -1
            ENDIF
          ELSE IF (IPR(325) .EQ. -1 .AND. IATPRI .EQ. -1) THEN
            IF (IENI .EQ. 3 .OR. IENI .EQ. 4) THEN
              IPR(157) = - IENI
            ELSE
              IPR(157) = -1
            ENDIF
          ELSE
            IPR(157) = 0
          ENDIF
          CALL GEN048 (-7, JFG(I), 1, IDS1)
          IDS1 = IPPR(IDS1 + 1, 1)
          DO 200 J = 1, N2
            CALL GEN048 (-6, IFG(J), 9, IRESJ)
            IF (IRESI .EQ. IRESJ) THEN
              CALL GEN048 (-4, IFG(J), 15, NO2)
              IENJ   = IEN(NO2 + 1)
              IATPRJ = IATPR(IENJ)
              IF (IATPRJ .LE. 0 .OR. NUMO .GE. 0) THEN
                IF (IENJ .EQ. 10 .OR. IENJ .EQ. 11 .OR.
     1              IENJ .EQ. 30 .OR. IENJ .EQ. 59 .OR.
     2              IENJ .EQ. 94) THEN
                  IPR(158) = IENJ
                ELSE IF (IATPRJ .EQ. 5 .OR. IATPRJ .EQ. 6) THEN
                  IPR(158) = 1
                ELSE IF (IPR(325) .EQ.  0 .AND. IATPRJ .LT.  0) THEN
                  IF (IENJ .GE. 3 .AND. IENJ .LE. 5) THEN
                    IPR(158) = - IENJ
                  ELSE
                    IPR(158) = -1
                  ENDIF
                ELSE IF (IPR(325) .EQ. -1 .AND. IATPRJ .EQ. -1) THEN
                  IF (IENJ .EQ. 3 .OR. IENJ .EQ. 4) THEN
                    IPR(158) = - IENJ
                  ELSE
                    IPR(158) = -1
                  ENDIF
                ELSE
                  IPR(158) = 0
                ENDIF
                IPR(192) = ISIGN(1, IATPRJ)
                TOLEA    = 0
                IF (IPR(156) .EQ. 0) THEN
                  ITST = IPR(157) * IPR(158)
                  IF (ITST .EQ. -30 .OR. ITST .EQ.  -40 .OR.
     1                ITST .EQ. -50 .OR. ITST .EQ. -120) THEN
                    TOLEA = PAR(5)
                  ELSE IF (ITST .EQ. -177 .OR. ITST .EQ. -236) THEN
                    TOLEA = PAR(6)
                  ELSE IF (ITST .EQ. -1 .OR. ITST .EQ. -3 .OR.
     1                     ITST .EQ. -4) THEN
                    TOLEA = IGBL(97) * PAR(26)
                  ENDIF
                  IF (IPR(191) + IPR(192) .EQ. 2) TOLEA = PAR(27)
                ENDIF
                PAR(23) = DMX + RADR(NO2 + 1, 2) + TOLEA
                IF (IENI .EQ. 1 .OR. IENJ .EQ. 1)
     1              PAR(23) = MIN (PAR(23), 2.0)
                IF (PLA260 (IENI, IENJ) .LT. 0.0) PAR(23) = 2.0
                CALL GEN048 (-7, JFG(J), 1, IDS2)
                IDS2 = IPPR(IDS2 + 1, 1)
                IF (IDS1 .LT. 1000 .AND. IDS2 .LT. 1000) THEN
                  IF (IDS1 .NE. IDS2) THEN
                    IF (IABS(2 * IDS1 - IDS2) .GT. 1 .AND.
     1                  IABS(2 * IDS2 - IDS1) .GT. 1) GOTO 200
                  ENDIF
                  IF (IPR(154) .EQ. 0) THEN
                    MNI = NINT(MOD(XLAB(I), FLOAT(IPR(463))))
                    MNJ = NINT(MOD(XLAB(J), FLOAT(IPR(463))))
                    IF (IDS1 .EQ. 500 .AND. MNI .NE. MNJ) GOTO 200
                  ENDIF
                ENDIF
                CALL PLA050 (I, J, 0, 0, DSQ)
                IF (DSQ .LE. PAR(23) .AND. DSQ .GT. 0.1) THEN
                  IF (IATPRJ .GT. 0) THEN
                    IF (IENI .EQ. 4 .OR. IENI .EQ. 8 .OR.
     1                  IENI .EQ. 20) THEN
                      NUMB = 0
                      DO 180 K = 1, NAT
                        IF (K .NE. I .AND. K .NE. J) THEN
                          CALL PLA050 (K, I, 0, 0, DIST)
                          IF (IENI .EQ. 8) THEN
                            IF (DIST .LT. 1.9) NUMB = NUMB + 1
                          ENDIF
                          IF (DIST .LT. 1.7) THEN
                            CALL PLA050 (J, I, K, 0, ANGLE)
                            IF (ANGLE .LT. 45.0) GOTO 200
                          ENDIF
                        ENDIF
  180                 CONTINUE
                      IF (IENI .EQ. 8 .AND. NUMB .EQ. 4) GOTO 200
                    ENDIF
                  ELSE IF (IATPRI .GT. 0) THEN
                    IF (IENJ .EQ. 4 .OR. IENJ .EQ. 8 .OR.
     1                  IENJ .EQ. 20) THEN
                      NUMB = 0
                      DO 190 K = 1, NAT
                        IF (K .NE. I .AND. K .NE. J) THEN
                          CALL PLA050 (K, J, 0, 0, DIST)
                          IF (IENI .EQ. 8) THEN
                            IF (DIST .LT. 1.9) NUMB = NUMB + 1
                          ENDIF
                          IF (DIST .LT. 1.7) THEN
                            CALL PLA050 (I, J, K, 0, ANGLE)
                            IF (ANGLE .LT. 45.0) GOTO 200
                          ENDIF
                        ENDIF
  190                 CONTINUE
                      IF (IENJ .EQ. 8 .AND. NUMB .EQ. 4) GOTO 200
                    ENDIF
                  ENDIF
                  CALL PLA041 ( 1, I, KI,   J)
                  CALL PLA041 (-1, J, IVAL, I)
                  IF (IVAL .LE. 0) CALL PLA041 (1, J, KJ, I)
                ENDIF
              ENDIF
            ENDIF
  200     CONTINUE
        ENDIF
  210 CONTINUE
      IF (NRES .GT. 1) THEN
        CALL GEN022 (IRCONT, 1, NRES)
        DO 220 I = 1, NRES
          MLTI(I)   = MOD(IRCONT(I), 1000) - 1
          IRCONT(I) = IRCONT(I) / 1000
          J         = MOD(IRCONT(I), 100)
          JRCONT(J) = I
  220   CONTINUE
        NMOL = IPR(13)
        IF (NMOL .GT. 1) THEN
          DO 230 J = 2, NMOL
            CALL GEN098 (MOL(J), PAR(42), IS1, IX1, IY1, IZ1, IR1)
            MOL(J) = (IS1 * 1000 + IX1 * 100 + IY1 * 10 + IZ1 + 555) *
     1               IARU + JRCONT(IR1)
  230     CONTINUE
        ENDIF
        IF (MXL .GT. 0) THEN
          DO 240 J = 1, MXL
            JUNK = NETH(J, 1)
            NETH(J, 1) = JRCONT(JUNK)
  240     CONTINUE
        ENDIF
      ENDIF
      I = 0
  250 I = I + 1
      IF (I .GT. NAT) GOTO 270
      NTRNS(I) = IATP(I)
      IF (NRES .GT. 1) THEN
        CALL GEN048 (-6, IFG(I), 9, IVAL)
        CALL GEN048 ( 6, IFG(I), 9, JRCONT(IVAL))
      ENDIF
      IF (IPR(72) .EQ. 1) THEN
        DO 260 J = 1, 3
          FSDV = SQRT(XSD(I, J))
          CALL GEN041 (XXO(I, J), FSDV, IDUM, IPR(183), NDEC, IPR(68))
          XSD(I, J) = FSDV**2
  260   CONTINUE
        CALL PLA059 (I, I)
      ENDIF
      GOTO 250
  270 IPR(51) = IPR(13)
  280 DO 300 IAT = 1, IPR(39)
        CALL GEN048 (-1, IFG(IAT), 23, IDAC)
        IF (IDAC .EQ. 1) THEN
          CALL GEN048 (-4, IFG(IAT), 15, NO1)
          IENI = IEN(NO1 + 1)
          IF (IENI .EQ. 4 .OR. IENI .EQ. 6) THEN
            NC = - NINT(CON(IAT, NP4))
            IF (NC .GT. 0) THEN
              NRBO = 0
              DO 290 JJ = 1, NC
                KK = NINT(CON(IAT, JJ))
                CALL GEN048 (-4, IFG(KK), 15, NO2)
                IENK = IEN(NO2 + 1)
                IF (IENK .EQ. 3) NRBO = NRBO + 1
  290         CONTINUE
              IF (NRBO .GT. 2)
     1          CALL GEN048 (1, IFG(IAT), 23, 0)
            ENDIF
          ENDIF
        ENDIF
  300 CONTINUE
      IPR(297) = NP1 * (NP4 + 15)
      IPR(298) = IPR(297) + NP1 * 21
      IPR(131) = 0
      IPR(133) = -1
  310 IPR(133) = IPR(133) + 1
      IF (IPR(133) .GT. 1) GOTO 330
      IFIN     = -2
  320 CALL PLA038 (I, J, IFIN)
      IF (IFIN .EQ. 1) GOTO 310
      CALL PLA100 (I, J, 2, 1.0)
      GOTO 320
  330 IF (IPR(324) .EQ. 1 .AND. IPR(322) .EQ. 0
     1  .AND. MODE .GE. 0) THEN
        CALL PLA030 (XXO, CON, JATC, IFG, JFG, IPPR, VOID(IPR(298) + 1))
C * GENERAL AUTO-RENUMBERING
        IF (IPR(501) .EQ. 1) CALL PLA228
      ENDIF
  340 RETURN
99999 FORMAT ('UNRESOLVABLE ARU-PROBLEM - SQUEEZE ABORTED')
      END
      SUBROUTINE PLA095 (NRING, NHEAD, MODE)
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP5=250,NP6=100,NP7=50,NP8=50,
     1 NP9=118,NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,
     2 NPVD=40000000,NP22=256,NP23=18000,NP25=99,NP29=63,NP38=125,
     3 NP39=30,NP41=200,NP47=9,NPX = 2 * NP23 - 42 * NP5 - 6)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9),
     1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10),
     2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10),
     3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770)
      COMMON // Q(NP5), SPHI(NP5), PHI(NP5), KPHI(NP5), SSQ(NP5),
     1 NPHI(NP5), ZP(NP5), TRA(NP5), DCSV(NP5), DCSB(NP5), DC2V(NP5),
     2 DC2B(NP5), KZP(NP5), KTRA(NP5), STRA(NP5), KDCSV(NP5), NQ(NP5),
     3 KDCSB(NP5), KDC2V(NP5), KDC2B(NP5), KQ(NP5), XYZR(NP5, 4),
     4 RBO(NP5), KRBO(NP5), RANG(NP5), KRANG(NP5), HDCSV(NP5),
     5 HDC2V(NP5), HDCSB(NP5), HDC2B(NP5), FCS(NP5), HFCS(NP5),
     6 KFCS(NP5), FC2(NP5), HFC2(NP5), KFC2(NP5), NRANG(NP5), NTRA(NP5),
     7 NRBO(NP5), XYZD(3), XYZDD(3), ISCR(NPX), VOID(NPVD)
      CHARACTER KDES*2, TXT1*5, TXT2*5, ACONF*1
      CHARACTER FORMA*158, FORMB*158, FORMC*158, FORMD*158, FORME*158,
     1  FORMF*158, FORMG*158, FORMH*158, FORMI*56, FORMK*73, FORML*37,
     2  FORMP*106, FORMQ*63, FORMX*54, CHYB*3
      COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0
      IF (MODE .NE. 0) THEN
        CALL GGIP (HORS, VERT, 0.0, 1)
        VRT = VERT
      ENDIF
      NRAT  = IPR(12)
      NMAX  = IPR(39)
      RBOMN = 1000.0
      RBOMX = 0.0
      D     = 0.0
      SD    = 0.0
      SANG  = 0.0
      SRANG = 0.0
      SRBO  = 0.0
      ANG   = 0.0
      NDEC  = 0
      ISANG = 0
      ISD   = 0
      ION2  = 0
      ION5  = 0
      N     = 0
      IC2   = 0
      ATERM = 0.0
      BTERM = 0.0
      SIGAK = 0.0
      SIGBK = 0.0
      FORMA(1:30)   = '( ''Dev. (Ang)'',10X,           '
      FORMA(31:46)  = 'F8.4,''('',I3,'')'','
      FORMA(47:94)  = FORMA(31:46)//FORMA(31:46)//FORMA(31:46)
      FORMA(95:158) = FORMA(47:94)//'F8.4,''('',I3,'')'')'
      FORMB(1:30)   = '( ''Cs(I)-Asym-Par (Deg)'',     '
      FORMB(31:158) = FORMA(31:158)
      FORMC(1:30)   = '( ''C2(I)-Asym-Par (Deg)'',     '
      FORMC(31:158) = FORMA(31:158)
      FORMD(1:30)   = '( ''Ring Bond Angle(Deg)'',     '
      FORMD(31:158) = FORMA(31:158)
      FORME(1:30)   = '( ''Tors(I-J) (Deg)'',10X,      '
      FORME(31:158) = FORMA(31:158)
      FORMF(1:30)   = '( ''Cs(I-J)-Asym-Par   (Deg) '','
      FORMF(31:158) = FORMA(31:158)
      FORMG(1:30)   = '( ''C2(I-J)-Asym-Par   (Deg) '','
      FORMG(31:158) = FORMA(31:158)
      FORMH(1:30)   = '( ''Ring Bond Distance (Ang) '','
      FORMH(31:158) = FORMA(31:158)
      FORMI(1:34)   = '(   A,'' - '',A,F10.4,''('',I3,'')'',5X,'
      FORMI(35:56)  = 'F10.2,''('',I3,'')'',2X,A)'
      FORMK( 1:28)  = '(''Q('',I1,'')  ='',F9.4,''('',I5,'
      FORMK(29:58)  = ''') Ang.,  Phi('',I1,'') ='',F8.2,'
      FORMK(59:73)  = '''('',I5,'') Deg'')'
      FORML( 1:37)  = FORMK(1:35)//''')'
      FORMP( 1:34)  = '(''Puckering Amplitude (Q) ='',F8.4,'
      FORMP(35:63)  = '''('',I5,'') Ang, Theta ='',F8.2,'
      FORMP(64:91)  = '''('',I5,'') Deg,  Phi ='',F8.2,'
      FORMP(92:106) = '''('',I5,'') Deg'')'
      FORMQ(1 :38)  = '(''Angle between '',3A,'' and '',3A,'' = '','
      FORMQ(39:63)  = 'F10.0,''('',I3,'')'','' deg.'')'
      FORMX(1:38)   = '(''Total Puckering Amplitude Q ='',F8.4,'
      FORMX(39:54)   ='''('',I5,'') Ang.'')'
      CALL PLA055
      KRC = NMAX + IPR(64) + 1
      IATP(KRC) = NRING
      DO 10 K = 1, 3
        XXO(KRC, K)     = 0.0
        XXO(KRC, K + 3) = 0.0
        XSD(KRC, K)     = 0.0
        XSD(KRC, K + 3) = 0.0
        XYZD(K)         = 0.0
        XYZDD(K)        = 0.0
   10 CONTINUE
      ISUGR  = 0
      IF (NRAT .EQ. 5) THEN
        DO 30 J = 1, NRAT
          CALL GEN048 (-4, IFG(JR(J)), 15, JDUM)
          JDUM = IEN(JDUM + 1)
          IF (JDUM .EQ. 2) THEN
            ISUGR = ISUGR + 1
          ELSE IF (JDUM .EQ. 3) THEN
            ISUGR = ISUGR + 100
          ENDIF
   30   CONTINUE
        IF (ISUGR .EQ. 104) THEN
          ISUGL = 2
   40     ISUGL = ISUGL - 1
          IF (ISUGL .LT. 0) THEN
            ISUGR = 0
            GOTO 70
          ENDIF
          IC2  = 0
          ION2 = 0
          J2   = JR(2)
          NC   = - NINT(CON(J2, NP4))
          IF (NC .LT. 0) NC = NP4
          IF (NC .LE. 3) THEN
            ISUGR = 0
            GOTO 70
          ENDIF
          DO 50 K = 1, NC
            M = NINT(CON(J2, K))
            IF (M .NE. JR(1) .AND. M .NE. JR(3)) THEN
              CALL GEN048 (-4, IFG(M), 15, JDUM)
              JDUM = IEN(JDUM + 1)
              IF (JDUM .EQ. 3 .OR. JDUM .EQ. 4) THEN
                ION2 = 1
              ENDIF
              IF (JDUM .EQ. 2) IC2 = 1
            ENDIF
   50     CONTINUE
          ION5 = 0
          J5   = JR(5)
          NC = - NINT(CON(J5, NP4))
          IF (NC .LT. 0) NC = NP4
          IF (NC .LE. 3) THEN
            ISUGR = 0
            GOTO 70
          ENDIF
          DO 60 K = 1, NC
            M = NINT(CON(J5, K))
            IF (M .NE. JR(1) .AND. M .NE. JR(4)) THEN
              CALL GEN048 (-4, IFG(M), 15, JDUM)
              JDUM = IEN(JDUM + 1)
              IF (JDUM .EQ. 3 .OR. JDUM .EQ. 4) ION5 = 1
              IF (JDUM .EQ. 2) THEN
                ACONF = 'L'
                CALL PLA053 (M, JR(5), JR(1), JR(2),
     1              ANG, SANG, ISANG, NDEC, IER)
                IF (IER .EQ. 0 .AND. ANG .GT. 0.0) ACONF = 'D'
              ENDIF
            ENDIF
   60     CONTINUE
          IF (ION5 .EQ. 1) THEN
            CALL GEN014 (JR(2), JR(5))
            CALL GEN014 (JR(3), JR(4))
            GOTO 40
          ENDIF
        ENDIF
      ENDIF
   70 BAV    = 0.0
      BAVK   = 0.0
      SWT    = 0.0
      TAU    = 0.0
      TAUK   = 0.0
      STWT   = 0.0
      SMSIGJ = 0.0
      NCARB  = 0
      NHAT = 0
      DO 100 J = 1, NRAT
        I    = JR(J)
        CALL GEN048 (-4, IFG(I), 15, JDUM)
        IF (IEN(JDUM + 1) .EQ. 2) THEN
          NCARB = NCARB + 1
          NC = - NINT(CON(I, NP4))
          IF (NC .LT. 0) NC = NP4
          DO 80 K = 1, NC
            M = NINT(CON(I, K))
            CALL GEN048 (-1, IFG(M), 7, IHAT)
            NHAT = NHAT + IHAT
   80     CONTINUE
        ENDIF
        NRJ = NRAT + J
        I1 = JR(MOD(NRJ - 2, NRAT) + 1)
        I2 = JR(MOD(NRJ - 1, NRAT) + 1)
        I3 = JR(MOD(NRJ,     NRAT) + 1)
        I4 = JR(MOD(NRJ + 1, NRAT) + 1)
        CALL PLA053 (I2, I3, 0, 0, RBO(J), SRBO, KRBO(J), NRBO(J),
     1               IER)
        IF (IER .NE. 0) GOTO 290
        IF (SRBO .LE. 0.0) THEN
          WBO = 1.0
        ELSE
          WBO = 1.0 / SRBO**2
        ENDIF
        RBOMX = MAX (RBOMX, RBO(J))
        RBOMN = MIN (RBOMN, RBO(J))
        BAV   = BAV  + WBO * RBO(J)
        BAVK  = BAVK + WBO * RBO(J)**2
        SWT   = SWT  + WBO
        CALL PLA053 (I1, I2, I3, 0, RANG(J), SRANG, KRANG(J),
     1               NRANG(J), IER)
        IF (IER .NE. 0) GOTO 290
        CALL PLA053 (I1, I2, I3, I4, TRA(J), STRA(J), KTRA(J),
     1               NTRA(J), IER)
        IF (IER .NE. 0) GOTO 290
        IF (STRA(J) .LE. 0) THEN
          WTAU  = 1.0
        ELSE
          WTAU  = 1.0 / STRA(J)**2
        ENDIF
        TAU  = TAU  + WTAU * ABS(TRA(J))
        TAUK = TAUK + WTAU * TRA(J)**2
        STWT = STWT + WTAU
        IP   = JR(J)
        SIGJ = 0.0
        DO 90 K = 1, 3
          XYZR(J,  K)     = XXO(IP,  K + 3)
          XXO(KRC, K)     = XXO(KRC, K)     + XXO(IP, K)
          XXO(KRC, K + 3) = XXO(KRC, K + 3) + XXO(IP, K + 3)
          XSD(KRC, K)     = XSD(KRC, K)     + XSD(IP, K)
          XSD(KRC, K + 3) = XSD(KRC, K + 3) + XSD(IP, K + 3)
          SIGJ            = SIGJ + XSD(IP, K + 3)
   90   CONTINUE
        XYZR(J, 4) = SIGJ / 3
        SMSIGJ     = SMSIGJ + SIGJ / 3
  100 CONTINUE
      IF (NHEAD .EQ. 0 .AND. IGBL(63) .GT. 3) THEN
        NHEAD = 1
        CALL PLA269 (-53)
        WRITE (LU7, 99970)
        NRNG = IPR(496)
        IF (MOD (NRNG, 100) .GT. 0) WRITE (LU7, 99969)
        NRNG = NRNG / 100
        IF (MOD (NRNG, 100) .GT. 0) WRITE (LU7, 99968)
        NRNG = NRNG / 100
        IF (MOD (NRNG, 100) .GT. 0) WRITE (LU7, 99967)
        NRNG = NRNG / 100
        IF (NRNG .GT. 0) WRITE (LU7, 99966) '<', '>', '>', '>',
     1   '>', '>'
        WRITE (LU7, 99965)
        WRITE (LU7, 99964)
        WRITE (LU7, 99982)
      ENDIF
      DO 110 K = 1, 3
        XSD(KRC, K)     = XSD(KRC, K)    / (NRAT**2)
        XSD(KRC, K + 3) = XSD(KRC, K + 3)/ (NRAT**2)
        XXO(KRC, K)     = XXO(KRC, K)    /  NRAT
        XXO(KRC, K + 3) = XXO(KRC, K + 3)/  NRAT
  110 CONTINUE
      DO 120 K = 1, 6
        VOID((KRC - 1) * (NP4 + 15) + K)     = XXO(KRC, K)
        VOID((KRC - 1) * (NP4 + 15) + K + 6) = XSD(KRC, K)
  120 CONTINUE
      BAV    = BAV / SWT
      BAVK   = BAVK / SWT
      KBAV   = MIN (999, NINT(10000.0 / SQRT(SWT)))
      KBAVE  = MIN (999, NINT(10000.0 * SQRT(ABS(BAVK
     1         - BAV**2) / (NRAT - 1))))
      TAU    = TAU / STWT
      TAUK   = TAUK / STWT
      KTAU   = MIN (999, NINT(100.0 / SQRT(STWT)))
      KTAUE  = MIN (999, NINT(100.0 * SQRT(ABS(TAUK - TAU**2) /
     1         (NRAT - 1))))
      SMSIGJ = SMSIGJ / (NRAT**2)
      DO 150 J = 1, NRAT
        DO 130 K = 1, 3
          XYZR(J, K) = XYZR(J, K) - XXO(KRC, K + 3)
  130   CONTINUE
        XYZR(J, 4) = XYZR(J, 4) + SMSIGJ
        SINF   = SIN(GL(6) * (J - 1) / NRAT)
        COSF   = COS(GL(6) * (J - 1) / NRAT)
        DO 140 L = 1, 3
          XYZD(L)  = XYZD(L)  + XYZR(J, L) * SINF
          XYZDD(L) = XYZDD(L) + XYZR(J, L) * COSF
  140   CONTINUE
  150 CONTINUE
      CALL GEN008 (XYZD, XYZDD, XPV, 1)
      IE  = 0
      BQ  = 0.0
      SBQ = 0.0
      DO 160 J = 1, NRAT
        ZP(J) = XPV(1) * XYZR(J, 1) + XPV(2) * XYZR(J, 2)
     1        + XPV(3) * XYZR(J, 3)
        BQ    = BQ  + ZP(J)**2
        SBQ   = SBQ + ZP(J)**2 * XYZR(J, 4)
  160 CONTINUE
      BQ  = SQRT(BQ)
      IF (BQ .GT. 0.0) SBQ = SQRT(SBQ) / BQ
      DO 180 J = 1, NRAT
        DCSV(J)  = 0.0
        DC2V(J)  = 0.0
        DCSB(J)  = 0.0
        DC2B(J)  = 0.0
        FCS(J)   = 0.0
        FC2(J)   = 0.0
        HDCSV(J) = 0.0
        HDC2V(J) = 0.0
        HDCSB(J) = 0.0
        HDC2B(J) = 0.0
        HFCS(J)  = 0.0
        HFC2(J)  = 0.0
        NRD2     = NRAT / 2
        NRD3     = (NRAT - 1) / 2
        NRJ      = NRAT + J
        DO 170 K = 1, NRD2
          ITRA0    = MOD(NRJ + K - 1, NRAT) + 1
          ITRA1    = MOD(NRJ + K - 2, NRAT) + 1
          ITRA2    = MOD(NRJ - K - 1, NRAT) + 1
          TRA0     = TRA(ITRA0)
          STRA0    = STRA(ITRA0)**2
          TRA1     = TRA(ITRA1)
          STRA1    = STRA(ITRA1)**2
          TRA2     = TRA(ITRA2)
          STRA2    = STRA(ITRA2)**2
          ZP0      = ZP(ITRA0)
          SZP0     = SQRT(XYZR(ITRA0, 4))
          ZP2      = ZP(ITRA2)
          SZP2     = SQRT(XYZR(ITRA2, 4))
          T1P2S    = (TRA1 + TRA2)**2
          T1M2S    = (TRA1 - TRA2)**2
          T0P2S    = (TRA0 + TRA2)**2
          T0M2S    = (TRA0 - TRA2)**2
          Z0P2S    = (ZP0  + ZP2)**2
          Z0M2S    = (ZP0  - ZP2)**2
          DCSV(J)  = DCSV(J)  + T1P2S
          HDCSV(J) = HDCSV(J) + T1P2S * (STRA1 + STRA2)
          DC2V(J)  = DC2V(J)  + T1M2S
          HDC2V(J) = HDC2V(J) + T1M2S * (STRA1 + STRA2)
          IF (K .LE. NRD3) THEN
            FC2(J)   = FC2(J)   + Z0P2S
            HFC2(J)  = HFC2(J)  + Z0P2S * (SZP0  + SZP2)
            FCS(J)   = FCS(J)   + Z0M2S
            HFCS(J)  = HFCS(J)  + Z0M2S * (SZP0  + SZP2)
            DCSB(J)  = DCSB(J)  + T0P2S
            HDCSB(J) = HDCSB(J) + T0P2S * (STRA0 + STRA2)
            DC2B(J)  = DC2B(J)  + T0M2S
            HDC2B(J) = HDC2B(J) + T0M2S * (STRA0 + STRA2)
          ENDIF
  170   CONTINUE
        IF (DCSV(J) .LT. 1E-5) THEN
          HDCSV(J) = 0
        ELSE
          HDCSV(J) = SQRT(ABS(HDCSV(J)) / (NRD2 * DCSV(J)))
        ENDIF
        DCSV(J)  = SQRT(ABS(DCSV(J)) / NRD2)
        IF (DC2V(J) .LT. 1E-5) THEN
          HDC2V(J) = 0
        ELSE
          HDC2V(J) = SQRT(ABS(HDC2V(J)) / (NRD2 * DC2V(J)))
        ENDIF
        DC2V(J)  = SQRT(ABS(DC2V(J)) / NRD2)
        IF (DCSB(J) .LT. 1E-5) THEN
          HDCSB(J) = 0
        ELSE
          HDCSB(J) = SQRT(ABS(HDCSB(J)) / (NRD3 * DCSB(J)))
        ENDIF
        DCSB(J)  = SQRT(ABS(DCSB(J)) / NRD3)
        IF (FCS(J) .LT. 1E-5) THEN
          HFCS(J) = 0.0
        ELSE
          HFCS(J) = SQRT(ABS(HFCS(J)) / (NRD3 * FCS(J)))
        ENDIF
        FCS(J)   = SQRT(ABS(FCS(J)) / NRD3)
        IF (FC2(J) .LT. 1E-5) THEN
          HFC2(J) = 0.0
        ELSE
          HFC2(J)  = SQRT(ABS(HFC2(J)) / (NRD3 * FC2(J)))
        ENDIF
        FC2(J)   = SQRT(ABS(FC2(J)) / NRD3)
        IF (DC2B(J) .LT. 1E-5) THEN
          HDC2B(J) = 0.0
        ELSE
          HDC2B(J) = SQRT(ABS(HDC2B(J)) / (NRD3 * DC2B(J)))
        ENDIF
        DC2B(J)  = SQRT(ABS(DC2B(J)) / NRD3)
  180 CONTINUE
      NSP2 = 0
      NSP3 = 0
      II1  = -7
  190 II1  = II1 + 8
      II2  = II1 + 7
      IF (II2 .GT. NRAT) II2 = NRAT
      JJ = 0
      DO 200 II = II1, II2
        JJ = JJ + 1
        IP = JR(II)
        CALL PLA047 (XLAB(IP), NQ1, IDUM, JDUM, IPR(119), IGBL(55),
     1               0, 1 - IGBL(55))
        NAMS(JJ, 1) = ' '//NQ1
        CALL GEN048 (-4, IFG(IP), 24, IHYB)
        IF (IHYB .EQ. 1) THEN
          CHYB = 'sp'
        ELSE IF (IHYB .EQ. 2) THEN
          CHYB = 'sp2'
          NSP2 = NSP2 + 1
        ELSE IF (IHYB .EQ. 3) THEN
          CHYB = 'sp3'
          NSP3 = NSP3 + 1
        ELSE
          CHYB = ' '
        ENDIF
        NAMS(JJ, 2) = CHYB
  200 CONTINUE
      IF (II1 .NE. 1) THEN
        IF (IGBL(63) .GT. 2) THEN
          CALL PLA269 (5)
          WRITE (LU7, 99996) (NAMS(II, 1)(2:7), II = 1, JJ)
          WRITE (LU7, 99971)
          WRITE (LU7, 99962) (NAMS(II, 2)(1:3), II = 1, JJ)
        ENDIF
      ELSE
        IF (IGBL(63) .GT. 2) THEN
          CALL PLA269 (-4)
          IF (ISUGR .EQ. 104) THEN
            CALL PLA269 (1)
            IF (IC2 .EQ. 1) THEN
              WRITE (LU7, 99991)
            ELSE
              WRITE (LU7, 99990)
            ENDIF
          ENDIF
          WRITE (PRBUF, 99997) NRAT, IPR(19) + NRING,
     1                       (NAMS(II, 1)(2:7), II = 1, JJ)
          WRITE (LU7, 99961) PRBUF
          IF (MODE .NE. 0) THEN
            VRT = VRT - 0.7
            CALL GGIP20 (0.0, PRBUF, 132, 0.3, 5 + IGBL(68), 2, 0.1,
     1        VRT)
          ENDIF
          WRITE (LU7, 99971)
          WRITE (PRBUF, 99962) (NAMS(II, 2)(1:3), II = 1, JJ)
          WRITE (LU7, 99961) PRBUF
          IF (MODE .NE. 0) THEN
            VRT = VRT - 0.9
            CALL GGIP20 (0.0, PRBUF, 132, 0.3, 1, 1, 0.1, VRT)
          ENDIF
        ENDIF
      ENDIF
      IF (IGBL(63) .GT. 2) THEN
        IFT = 18
        I68 = IPR(68)
        DO 210 II = II1, II2
          IFT = IFT + 16
          SX = SQRT (XYZR(II, 4))
          CALL GEN041 (ZP(II), SX, KZP(II),            4, NDEC, I68)
          FORMA(IFT:IFT) = CHAR(ICHAR('0') + NDEC)
          CALL GEN041 (DCSV(II), HDCSV(II), KDCSV(II), 2, NDEC, I68)
          FORMB(IFT:IFT) = CHAR(ICHAR('0') + NDEC)
          CALL GEN041 (DC2V(II), HDC2V(II), KDC2V(II), 2, NDEC, I68)
          FORMC(IFT:IFT) = CHAR(ICHAR('0') + NDEC)
          FORMD(IFT:IFT) = CHAR(ICHAR('0') + NRANG(II))
          FORME(IFT:IFT) = CHAR(ICHAR('0') + NTRA(II))
          CALL GEN041 (DCSB(II), HDCSB(II), KDCSB(II), 2, NDEC, I68)
          FORMF(IFT:IFT) = CHAR(ICHAR('0') + NDEC)
          CALL GEN041 (DC2B(II), HDC2B(II), KDC2B(II), 2, NDEC, I68)
          FORMG(IFT:IFT) = CHAR(ICHAR('0') + NDEC)
          FORMH(IFT:IFT) = CHAR(ICHAR('0') + NRBO(II))
  210   CONTINUE
        WRITE (PRBUF, FORMA) (ZP(II),   KZP(II),   II = II1, II2)
        CALL PLA067 (LU7, PRBUF, 132, 1, 1)
        IF (MODE .NE. 0) THEN
          VRT = VRT - 0.7
          CALL GGIP20 (0.0, PRBUF, 132, 0.3, 1, 1, 0.1, VRT)
        ENDIF
        WRITE (PRBUF, FORMB) (DCSV(II), KDCSV(II), II = II1, II2)
        CALL PLA067 (LU7, PRBUF, 132, 1, 1)
        IF (MODE .NE. 0) THEN
          VRT = VRT - 0.7
          CALL GGIP20 (0.0, PRBUF, 132, 0.3, 1, 1, 0.1, VRT)
        ENDIF
        WRITE (PRBUF, FORMC) (DC2V(II), KDC2V(II), II = II1, II2)
        CALL PLA067 (LU7, PRBUF, 132, 1, 1)
        IF (MODE .NE. 0) THEN
          VRT = VRT - 0.7
          CALL GGIP20 (0.0, PRBUF, 132, 0.3, 1, 1, 0.1, VRT)
        ENDIF
        WRITE (PRBUF, FORMD) (RANG(II), KRANG(II), II = II1, II2)
        CALL PLA067 (LU7, PRBUF, 132, 1, 1)
        IF (MODE .NE. 0) THEN
          VRT = VRT - 0.7
          CALL GGIP20 (0.0, PRBUF, 132, 0.3, 1, 1, 0.1, VRT)
        ENDIF
        WRITE (LU7, 99974)
        WRITE (PRBUF, FORME) (TRA(II),  KTRA(II),  II = II1, II2)
        CALL PLA067 (LU7, PRBUF, 132, 1, 1)
        IF (MODE .NE. 0) THEN
          VRT = VRT - 0.9
          CALL GGIP20 (0.0, PRBUF, 132, 0.3, 1, 1, 0.1, VRT)
        ENDIF
        WRITE (PRBUF, FORMF) (DCSB(II), KDCSB(II), II = II1, II2)
        CALL PLA067 (LU7, PRBUF, 132, 1, 1)
        IF (MODE .NE. 0) THEN
          VRT = VRT - 0.7
          CALL GGIP20 (0.0, PRBUF, 132, 0.3, 1, 1, 0.1, VRT)
        ENDIF
        WRITE (PRBUF, FORMG) (DC2B(II), KDC2B(II), II = II1, II2)
        CALL PLA067 (LU7, PRBUF, 132, 1, 1)
        IF (MODE .NE. 0) THEN
          VRT = VRT - 0.7
          CALL GGIP20 (0.0, PRBUF, 132, 0.3, 1, 1, 0.1, VRT)
        ENDIF
        WRITE (PRBUF, FORMH) (RBO(II),  KRBO(II),  II = II1, II2)
        CALL PLA067 (LU7, PRBUF, 132, 1, 1)
        IF (MODE .NE. 0) THEN
          VRT = VRT - 0.7
          CALL GGIP20 (0.0, PRBUF, 132, 0.3, 1, 1, 0.1, VRT)
        ENDIF
      ENDIF
      IF (II2 .LT. NRAT) GOTO 190
      M = (NRAT - 1) / 2
      IF (NRAT .EQ. 6 .AND. NCARB .EQ. 6) THEN
        IF (NSP2 .EQ. 6) THEN
          IF (NHAT .GT. 4) THEN
            NADD = 0
          ELSE
            NADD = 3
          ENDIF
          IF (TAU .LT. 5.0) THEN
            BAVDIF = BAV - 1.395
            IF (BAVDIF .GT. 0.005) THEN
              WRITE (LU20, 99963) 330 + NADD,   BAVDIF, BAV,
     1               NAMS(1, 1) (2:8), NAMS(6, 1) (2:8)
            ELSE IF (BAVDIF .LT. -0.005) THEN
              WRITE (LU20, 99963) 331 + NADD, - BAVDIF, BAV,
     1               NAMS(1, 1) (2:8), NAMS(6, 1) (2:8)
            ENDIF
          ENDIF
          IF (TAU .LT. 12.0) WRITE (LU20, 99963) 332 + NADD,
     1      RBOMX - RBOMN, RBOMX - RBOMN,
     2      NAMS(1, 1) (2:8), NAMS(6, 1) (2:8)
         ELSE IF (NSP3 .EQ. 6) THEN
           WRITE (LU20, 99963) 338, 60.0 - TAU, TAU, NAMS(1, 1)(2:8),
     1       NAMS(6, 1)(2:8)
         ENDIF
      ENDIF
      IF (IGBL(63) .GT. 2) THEN
        CALL PLA269 (5)
        WRITE (LU7, 99974)
        WRITE (PRBUF, 99960) BAV, KBAV, KBAVE
        WRITE (LU7, 99961) PRBUF
        IF (MODE .NE. 0) THEN
          VRT = VRT - 0.9
          CALL GGIP20 (0.0, PRBUF, 132, 0.3, 1, 1, 0.1, VRT)
        ENDIF
        WRITE (PRBUF, 99959) TAU, KTAU, KTAUE
        WRITE (LU7, 99961) PRBUF
        IF (MODE .NE. 0) THEN
          VRT = VRT - 0.7
          CALL GGIP20 (0.0, PRBUF, 132, 0.3, 1, 1, 0.1, VRT)
        ENDIF
        WRITE (LU7, 99974)
        IF (NRAT .EQ. 4) THEN
          CALL PLA053 (JR(1), JR(2), JR(4), JR(3), TRA(5), STRA(5),
     1        KTRA(5), NTRA(5), IER)
          IF (IER .EQ. 0) THEN
            FORMQ(43:43) = CHAR(ICHAR('0') + NTRA(5))
            WRITE (PRBUF, FORMQ)
     1      NAMS(1, 1)(2:7), NAMS(2, 1)(2:7), NAMS(4, 1)(2:7),
     2      NAMS(2, 1)(2:7), NAMS(3, 1)(2:7), NAMS(4, 1)(2:7),
     3      ABS(TRA(5)), KTRA(5)
            CALL PLA067 (LU7, PRBUF, 132, 1, 1)
          ENDIF
          CALL PLA053 (JR(2), JR(3), JR(1), JR(4), TRA(6), STRA(6),
     1                 KTRA(6), NTRA(6), IER)
          IF (IER .EQ. 0) THEN
            FORMQ(43:43) = CHAR(ICHAR('0') + NTRA(6))
            WRITE (PRBUF, FORMQ)
     1      NAMS(1, 1)(2:7), NAMS(2, 1)(2:7), NAMS(3, 1)(2:7),
     2      NAMS(1, 1)(2:7), NAMS(3, 1)(2:7), NAMS(4, 1)(2:7),
     3      ABS(TRA(6)), KTRA(6)
            CALL PLA067 (LU7, PRBUF, 132, 1, 1)
          ENDIF
          WRITE (LU7, 99974)
        ENDIF
      ENDIF
      RMXMN = 100.0 * ABS (RBOMX - RBOMN) / BAV
      IF (TAU .GT. PAR(95)) THEN
        IF (IGBL(63) .GT. 2) THEN
          CALL PLA269 (2)
          WRITE (LU7, 99992)
        ENDIF
        IF (NRAT / 2 .GT. M) IE = 1
        IF (M .GT. 1) THEN
          DO 230 N = 2, M
            QS    = 0.0
            QC    = 0.0
            SQ    = 0.0
            CQ    = 0.0
            ATERM = 0
            BTERM = 0
            SIGAK = 0
            SIGBK = 0
            DO 220 J = 1, NRAT
              COSNF = COS(GL(6) * N * (J - 1) / NRAT)
              SINNF = SIN(GL(6) * N * (J - 1) / NRAT)
              QC = QC + ZP(J) * COSNF
              QS = QS + ZP(J) * SINNF
              SQ = SQ + XYZR(J, 4) * SINNF**2
              CQ = CQ + XYZR(J, 4) * COSNF**2
              IF (NRAT .EQ. 5) THEN
                ATERM = ATERM + TRA(J) * COSNF
                BTERM = BTERM + TRA(J) * SINNF
                SIGAK = SIGAK + (STRA(J) * COSNF)**2
                SIGBK = SIGBK + (STRA(J) * SINNF)**2
              ENDIF
  220       CONTINUE
            QC      =  QC * SQRT (2.0 / NRAT)
            QS      = -QS * SQRT (2.0 / NRAT)
            CQ      =  CQ * 2.0 / NRAT
            SQ      =  SQ * 2.0 / NRAT
            Q(N)    = SQRT (QC**2 + QS**2)
            SNTH    = 0.0
            CSTH    = 0.0
            PHI(N)  = 0.0
            SPHI(N) = 0.0
            SSQ(N)  = 0.0
            KQ(N)   = 0
            NQ(N)   = 0
            KPHI(N) = 0
            NPHI(N) = 0
            IF (Q(N) .GT. 0.0001) THEN
              SNTH = QS / Q(N)
              CSTH = QC / Q(N)
              IF (CSTH .GE. 0) THEN
                PHI(N) = ASIN(SNTH) * GL(5)
                IF (PHI(N) .LT. 0) PHI(N) = PHI(N) + 360.0
              ELSE
                PHI(N) = ACOS(CSTH) * GL(5)
                IF (SNTH .LT. 0) PHI(N) = 360.0 - PHI(N)
              ENDIF
              SSQ(N) = SQRT(ABS(CQ * CSTH**2 + SQ * SNTH**2))
              SPHI(N) = SQRT(ABS(CQ * SNTH**2
     1                + SQ * CSTH**2)) * GL(5) / Q(N)
            ENDIF
            IF (IGBL(63) .GT. 2) THEN
              QQN = Q(N)
              CALL GEN041 (QQN, SSQ(N), KQ(N), 4, NQ(N), IPR(68))
              CALL GEN041 (PHI(N), SPHI(N), KPHI(N), 4, NPHI(N),
     1                  IPR(68))
              IF (N .LT. 10) THEN
                FORMK(8:8)   = '1'
                FORMK(18:18) = '9'
                FORMK(46:46) = '1'
                FORMK(55:55) = '8'
              ELSE
                FORMK(8:8)   = '2'
                FORMK(18:18) = '8'
                FORMK(46:46) = '2'
                FORMK(55:55) = '7'
              ENDIF
              FORMK(20:20) = CHAR(ICHAR('0') + NQ(N))
              FORMK(57:57) = CHAR(ICHAR('0') + NPHI(N))
              WRITE (PRBUF, FORMK) N, QQN , KQ(N), N, PHI(N), KPHI(N)
              CALL PLA067 (LU7, PRBUF, 132, 1, 1)
              IF (MODE .NE. 0) THEN
                VRT = VRT - 0.9
                CALL GGIP20 (0.0, PRBUF, 132, 0.3, 1, 1, 0.1, VRT)
              ENDIF
            ENDIF
  230     CONTINUE
        ENDIF
        IF (IE .EQ. 1) THEN
          N2    = NRAT / 2
          Q(N2) = 0.0
          QN2   = 0
          DO 240 J = 1, NRAT
            Q(N2) = (-1)**(J - 1) * ZP(J) + Q(N2)
            QN2   = QN2 + XYZR(J, 4)
  240     CONTINUE
          SSQ(N2) = SQRT(ABS(QN2 / NRAT))
          Q(N2)   = Q(N2) * SQRT(1.0 / NRAT)
          IF (IGBL(63) .GT. 2) THEN
            QQN2 = Q(N2)
            CALL GEN041 (QQN2, SSQ(N2), KQ(N2), 4, NQ(N2), IPR(68))
            IF (N2 .LT. 10) THEN
              FORML(8:8)   = '1'
              FORML(18:18) = '9'
            ELSE
              FORML(8:8)   = '2'
              FORML(18:18) = '8'
            ENDIF
            FORML(20:20) = CHAR(ICHAR('0') + NQ(N2))
            WRITE (PRBUF, FORML) N2, QQN2, KQ(N2)
            CALL PLA067 (LU7, PRBUF, 132, 1, 1)
            IF (MODE .NE. 0) THEN
              VRT = VRT - 0.7
              CALL GGIP20 (0.0, PRBUF, 132, 0.3, 1, 1, 0.1, VRT)
            ENDIF
          ENDIF
          AAZ = Q(N2)
        ELSE
          AAZ = 0
        ENDIF
        IF (NRAT .GT. 6 .AND. IGBL(63) .GT. 2) THEN
          WRITE (LU7, 99974)
          CALL GEN041 (BQ, SBQ, KBQ, 4, NBQ, IPR(68))
          FORMX(37:37) = CHAR(ICHAR('0') + NBQ)
          WRITE (PRBUF, FORMX) BQ, KBQ
          CALL PLA067 (LU7, PRBUF, 132, 1, 1)
        ENDIF
        IF (RMXMN .GT. PAR(328) .AND. IGBL(63) .GT. 2) THEN
          CALL PLA269 (4)
          WRITE (LU7, 99994) RMXMN, PAR(328)
          IF (MODE .NE. 0) THEN
            VRT = VRT - 0.7
            CALL GGIP20 (0.0, PRBUF, 132, 0.3, 1, 1, 0.1, VRT)
          ENDIF
        ENDIF
        IF (NRAT .EQ. 6) THEN
          IF (BQ .GT. PAR(12)) THEN
            CSTH = Q(N2) / BQ
          ELSE
            CSTH = 0.0
          ENDIF
          IF (CSTH .GT.  1.0) CSTH =  1.0
          IF (CSTH .LT. -1.0) CSTH = -1.0
          TH  = ACOS(CSTH) * GL(5)
          IF (BQ .GT. PAR(12)) THEN
            STH = SQRT(ABS((SSQ(2)**2 - SSQ(3)**2)
     1          * CSTH**2 + SSQ(3)**2)) * GL(5) / BQ
          ELSE
            STH = 0.0
          ENDIF
          IF (IGBL(63) .GT. 2) THEN
            CALL GEN041 (TH, STH, KTH, 2, NTH, IPR(68))
            CALL GEN041 (BQ, SBQ, KBQ, 4, NBQ, IPR(68))
            CALL PLA269 (1)
            WRITE (LU7, 99974)
            FORMP(33:33) = CHAR(ICHAR('0') + NBQ)
            FORMP(62:62) = CHAR(ICHAR('0') + NTH)
            FORMP(90:90) = CHAR(ICHAR('0') + NPHI(2))
            WRITE (PRBUF, FORMP) BQ, KBQ, TH, KTH, PHI(2), KPHI(2)
            CALL PLA067 (LU7, PRBUF, 132, 1, 1)
            IF (MODE .NE. 0) THEN
              VRT = VRT - 0.9
              CALL GGIP20 (0.0, PRBUF, 132, 0.3, 1, 1, 0.1, VRT)
            ENDIF
            IF (IGBL(63) .GT. 3) THEN
              CALL PLA269 (6)
              WRITE (LU7, 99981)
            ENDIF
          ENDIF
        ELSE IF (NRAT .EQ. 5) THEN
          ATERM = ATERM * 0.4
          BTERM = -0.4 * BTERM
          SIGAK = 0.16 * SIGAK
          SIGBK = 0.16 * SIGBK
          TAUM  = SQRT(ATERM**2 + BTERM**2)
          PPAR  = ATAN2(BTERM, ATERM)
          STAUM = SQRT(SIGAK * ATERM**2 + SIGBK * BTERM**2) / TAUM
          SPPAR = SQRT(SIGBK * ATERM**2 + SIGAK * BTERM**2) / (TAUM**2)
          PPAR  = PPAR  * GL(5)
          SPPAR = SPPAR * GL(5)
          IPPAR = MIN (999, NINT(SPPAR * 10.0))
          ITAUM = MIN (999, NINT(STAUM * 10.0))
          IP    = JR(1)
          CALL GEN048 (-4, IFG(IP), 15, NO1)
          IF (IEN(NO1 + 1) .EQ. 3) THEN
            PPAR = PPAR + 288.0
            KK = 3
          ELSE
            KK = 1
          ENDIF
          IF (IGBL(63) .GT. 3) THEN
            CALL PLA269 (6)
            WRITE (LU7, 99980)
          ENDIF
          PPAR = MOD(PPAR + 360.0, 360.0)
          IF (IGBL(63) .GT. 2) THEN
            WRITE (LU7, 99999)
            WRITE (PRBUF, 99998) PPAR, IPPAR, TAUM, ITAUM,
     1        NAMS(KK, 1)(2:7), NAMS(KK + 1, 1)(2:7)
            CALL GEN065 (LU7, PRBUF, 132, 1)
            WRITE (LU7, 99983)
            WRITE (LU7, 99989) 2.0 * PPAR
            CALL PLA269 (7)
            IF (ISUGR .EQ. 104 .AND. ION2 .EQ. 1) THEN
              CALL PLA269(5)
              WRITE (LU7, 99988)
              IBPAR = MOD(NINT(PPAR / 18.0), 20)
              IF (MOD(IBPAR, 2) .EQ. 0) THEN
                IBP = (IBPAR / 2) + 3
                IBP1 = MOD (IBP + 4, 5) + 1
                IBP2 = MOD (IBP    , 5) + 1
                TXT1 = '-exo '
                TXT2 = '-endo'
                IF (MOD (IBP, 2) .EQ. 0) THEN
                  TXT1 = '-endo'
                  TXT2 = '-exo '
                ENDIF
                WRITE (LU7, 99987) NAMS(IBP1, 1)(2:7), TXT1,
     1                             NAMS(IBP2, 1)(2:7), TXT2, ACONF
              ELSE
                IBP = (IBPAR - 1) / 2 + 3
                IBP1 = MOD (IBP, 5) + 1
                TXT1 = '-endo'
                IF (MOD (IBP, 2) .EQ. 0) TXT1 = '-exo '
                WRITE (LU7, 99986) NAMS(IBP1, 1)(2:7), TXT1, ACONF
              ENDIF
            ELSE
              IBPAR = MOD(NINT(PHI(2) / 18.0), 20)
              CALL PLA269 (3)
              IF (MOD(IBPAR, 2) .EQ. 1) THEN
                IBP = (IBPAR / 2)
                IBP1 = MOD (IBP,     5) + 1
                IBP2 = MOD (IBP + 1, 5) + 1
                WRITE (LU7, 99985) NAMS(IBP1, 1)(2:7),
     1                             NAMS(IBP2, 1)(2:7)
              ELSE
                IBPAR = IBPAR / 2
                IBP1 = MOD (IBPAR, 5) + 1
                WRITE (LU7, 99984) NAMS(IBP1, 1)(2:7)
              ENDIF
            ENDIF
            WRITE (LU7, 99974)
          ENDIF
        ENDIF
        IF (IGBL(63) .GT. 2) CALL PLA218 (Q, PHI, AAZ, NRAT, LU7)
      ELSE
        IF (TAU .LT. PAR(95) .AND.
     1      IGBL(63) .GT. 2)  THEN
          CALL PLA269 (3)
          WRITE (LU7, 99974)
          WRITE (PRBUF, 99995) TAU, PAR(95)
          WRITE (LU7, 99961) PRBUF
          WRITE (LU7, 99974)
          IF (MODE .NE. 0) THEN
            VRT = VRT - 0.9
            CALL GGIP20 (0.0, PRBUF, 132, 0.3, 2, 1, 0.1, VRT)
          ENDIF
        ENDIF
      ENDIF
      IF (TAU .LT. PAR(96)) CALL PLA031
      IF (IPR(2) .NE. 0) IPR(2) = 0
      IF (NRAT .EQ. 6 .AND. TAU .GT. PAR(97) .OR.
     1    NRAT .EQ. 5 .AND. TAU .GT. PAR(94)) THEN
        NBND = 0
        NHAT = 0
        DO 280 L = 1, 2
          DO 270 I = 1, NRAT
            J  = JR(I)
            NC = - NINT(CON(J, NP4))
            IF (NC .LT. 0) NC = NP4
            CALL PLA047 (XLAB(J), NQ1, IDUM, JDUM, IPR(119), IGBL(55),
     1                   0, 0)
            DO 260 K = 1, NC
              M = NINT(CON(J, K))
              N = I + NRAT - 2
              IF (M .EQ. JR(MOD(I, NRAT) + 1) .OR.
     1            M .EQ. JR(MOD(N, NRAT) + 1)) GOTO 260
              CALL GEN048 (-1, IFG(M), 7, IHAT)
              IF (L + IHAT .EQ. 2) GOTO 260
              NHAT = NHAT + IHAT
              CALL PLA047 (XLAB(M), NQ2, IDUM, JDUM, IPR(119), IGBL(55),
     1                     0, 0)
              CALL PLA053 (J, M, 0, 0, D, SD, ISD, NDEC, IER)
              IF (IER .EQ. 0) THEN
                FORMI(19:19) = CHAR(ICHAR('0') + NDEC)
                CALL PLA227 (J, M, VECN)
                ANG = XPV(1) * VECN(1) + XPV(2) * VECN(2)
     1              + XPV(3) * VECN(3)
                ANG = ABS(ANG)
                IF (ANG .GT. 1.0) ANG = 1.0
                IANG = 0
                ANG  = ACOS(ANG) * GL(5)
                A    = 0
                IF (D .NE. 0.0) THEN
                  DO 250 KKK = 1, 3
                    A = A + XSPV(KKK)**2 + (VECN(KKK) * SD / D)**2
  250             CONTINUE
                  A = GL(5) * SQRT(A)
                ENDIF
                CALL GEN041 (ANG, A, IANG, 2, NDEC, IPR(68))
                FORMI(39:39) = CHAR(ICHAR('0') + NDEC)
                KDES = 'Bi'
                IF (ANG .GT. 60) KDES = 'Eq'
                IF (ANG .LT. 30) KDES = 'Ax'
                NBND = NBND + 1
                IF (IGBL(63) .GT. 2) THEN
                  IF (NBND .EQ. 1) THEN
                    CALL PLA269 (4)
                    WRITE (LU7, 99972)
                  ENDIF
                  IF (NHAT .EQ. 1) THEN
                    CALL PLA269 (1)
                    WRITE (LU7, 99974)
                  ENDIF
                  WRITE (PRBUF, FORMI) NQ1, NQ2, D, ISD, ANG, IANG,
     1                                 KDES
                  CALL PLA067 (LU7, PRBUF, 132, 1, 1)
                ENDIF
              ENDIF
  260       CONTINUE
  270     CONTINUE
  280   CONTINUE
      ENDIF
  290 IF (MODE .NE. 0) THEN
        CALL GGIP (0.0, 0.0, 0.0, 3)
        CALL PLA013 (1, 1)
      ENDIF
      RETURN
99999 FORMAT (/, 'Pseudorotation Parameters P and Tau(M), (S.T.Rao, ',
     1 'E.Westhof & M.Sundaralingam, Acta Cryst (1981), A37, 421-425)',
     2 /, 132('-'))
99998 FORMAT ('P =', F6.1, '(', I3, ') Degree, Tau(M) =', F6.1,
     1 '(', I3, ') Deg. for Reference Bond ', A, '--> ', A,
     2 ' [add 144 Deg. to P for each shift to next Bond]')
99997 FORMAT (I3, '-Membered Ring (', I2, ')',
     1         8(3X, A, ' -->'))
99996 FORMAT (132('-'), /, 5X, '(Continued)', 6X, 8(3X, A, ' -->'))
99995 FORMAT ('No C & P - Puckering Analysis since <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, ' Deg.')
99988 FORMAT (/, 'Nearest Furanose Pucker Descriptor - (see W. Saenger',
     1        ', Principles of Nucleic Acid Structure, 1983, pp19',
     2        /, 132('-'))
99987 FORMAT ('Descriptor: T(wisted)  ', 2A, ', ', 2A, 5X,
     1        'Absolute Configuration: ', A)
99986 FORMAT ('Descriptor: E(nvelope) ', 2A, 5X,
     1        'Absolute Configuration: ', A)
99985 FORMAT (/, 'Closest Pucker Descriptor: Twisted on ',
     1        A, '-- ', A)
99984 FORMAT (/, 'Closest Pucker Descriptor: Envelope on ', A)
99983 FORMAT (84X, '[Ring-Sequence Change of Sense : P ---->>> - P]')
99982 FORMAT (//, '*** NOTE *** ',
     1 '- For Ring Puckering Comparisons: Make Sure that the',
     2 ' Absolute Configuration, Pivot Atom and Cyclic Sense Agree.',
     3 /, 13X, '- The "RING AT1 AT2 AT3 ... ATn" Instruction Gives',
     4 ' the User Explicit Choice of Pivot Atom (AT1) and Sense',
     5 ' (AT2).', /, 13X, '- Use TRNS Instructions to Obtain the',
     6 ' Required Absolute Configuration.',/, 13X, '- The Values of',
     7 ' Theta and Phi [ = Phi(2)] Depend on the Abs. Conf. and the',
     8 ' Choice of the First and Second Ring Atom.', /, 13X,
     9 '- Alternatively, Appropriate Phase Shifts may be Applied',
     * ' to the Same Effect (see Below)', //, 13X, 'For Correct Usage',
     1 ' of C&P Puckering Parameters see also: D. Cremer, ',
     2 'Acta Cryst. (1984). B40, 498-500.', /)
99981 FORMAT (//, '*** NOTE *** ',
     1 '- A Change of the Absolute Configuration Transforms Theta',
     2 ' into 180 - Theta and Phi into 180 + Phi.', /, 13X,
     3 '- A Cyclic Forward Shift of the Pivot Atom from At1 to At2',
     4 ' Transforms Theta into 180 - Theta and Phi into Phi + 120.',
     5 /, 13X,
     6 '- A Change of the Sense Transforms Theta into 180 - Theta',
     7 ' and Phi into 180 - Phi, and Vice Versa.'/)
99980 FORMAT (/, '*** NOTE *** ',
     1 '- A Change of the Absolute Configuration Transforms Phi(2)',
     2 ' into 180 + Phi(2).', /, 13X,
     3 '- A Cyclic Forward Shift of the Pivot Atom From At1 to At2',
     4 ' Transforms Phi(2) into Phi(2) + 144.', /, 13X,
     5 '- A Change of the Sense Transforms Phi(2) into 180 - Phi(2).'/)
99974 FORMAT (1X)
99972 FORMAT (31X, 'Analysis of Ring Substituents', /, 31X,
     1 29('='), /, 6X, 'Bond', 13X, 'Distance', 5X,
     2 'Angle with C&P Plane Normal', /, 63('-'))
99971 FORMAT (132('-'))
99970 FORMAT ('Ring Puckering Analysis (Cremer & Pople) - (e.s.d.',
     1 ' following Norrestam, Acta Cryst. (1981), A37, 764-765)', /,
     2 132('-'), //, 19X, 'Symmetrical Forms', 70X, 'References', /,
     3 19X, 17('-'), 70X, 10('-'))
99969 FORMAT ('5-Membered Rings : E : Envelope  - Phi = k X 36',  24X,
     1 'D. Cremer & J.A. Pople, J.Amer.Chem.Soc., 97,(1975),1354-1358',
     2 /, 19X, 'T : Half Chair- Phi = k X 36 + 18 ', /)
99968 FORMAT ('6-Membered Rings : C : Chair     - Th = 0.0', 37X,
     1 'J.C.A. Boeyens, J.Cryst.Mol.Struct. 8,(1978),317-320', /, 19X,
     2 'H : Half-Chair- Th = 50.8; Phi = k X 60 + 30', /, 19X,
     3 'E : Envelope  - Th = 54.7; Phi = k X 60', /, 19X,
     4 'S : Screw-Boat- Th = 67.5; Phi = k X 60 + 30', /, 19X,
     5 'B : Boat      - Th = 90.0; Phi = k X 60', /, 19X,
     6 'T : Twist-Boat- Th = 90.0; Phi = k X 60 + 30', /)
99967 FORMAT ('7-Membered Rings : C : Chair', 43X,
     1 'I.K. Boessenkool et al., J.Cryst.Mol.Struct., 10,(1980),11-18',
     2 /, 18X, 'TC : Twist-Chair', /, 19X, 'B : Boat', /, 18X,
     3 'TB : Twist-Boat', /)
99966 FORMAT ('8-Membered Rings :CR : Crown     - Q(2)=Q(3)=0,    Q',
     1 '(4)', 2A, '0', 28X, 'Palyulin et al., J.Mol.Struct.,70,(1981',
     2 '),65-75'/19X,'B : Boat      - Q(3)=Q(4)=0,    Q(2)',A,' 0 Ph',
     3 'i(2) = k X 90 + 45'/18X, 'BB : Boat-Boat - Q(3)=Q(4)=0,  ',
     4 '  Q(2)', A, ' 0 Phi(2) = k X 90 '/19X, 'C : Chair     - ',
     5 'Q(2)=Q(4)=0,    Q(3)', A, ' 0 Phi(3) = k X 45 '/18X, 'LC : L',
     6 'ong-Chair- Q(2)=Q(4)=0,    Q(3)', A, ' 0 Phi(3) = k X 45',
     7 ' + 22.5'/)
99965 FORMAT (/, 'Definitions (All Values Rounded on Esd)', /,
     1  40('-'), /, 'Dev', 12X, '- Deviation of Atom I from ',
     2 'Cremer&Pople Plane (Defined Differently from Least-Squares ',
     3 'Plane)', /, 'Cs(I),C2(I)    - Mirror Plane and 2-Axis Asym. ',
     4 'Par. for Atom I (See Duax et al., Topics in Stereochemistry,',
     5 'V-9, (1976) pp.271-383)', /, 'Cs(I-J),C2(I-J)- Asymmetry ',
     6 'Parameters for Bond I-J', /, 'Tors(I-J)      - Torsion Angle',
     7 ' for Bond I-J', /)
99964 FORMAT (//,
     1 'Descriptors for Torsion Angles', 40X, 'Descriptors for Ring ',
     2 'Substituents (J.Appl.Cryst.,1983,16,431)', /, 30('-'), 40X,
     3 62('-'), //, 'Torsion Angle Range', 5X, 'Full Descriptor', 5X,
     4 'Short Descriptor', 10X, 'Angle Range of Subst.   Full ',
     5 'Descriptor', 5X, 'Short Descriptor', /, 60('-'), 10X, 60('-'),
     5 /, 4X, '0   TO   30 Deg', 5X, '+  Syn-Periplanar', 7X, '+sp',
     6 23X, '0    TO  30 Deg.', 12X, 'Axial', 12X, 'ax', /, 3X,
     7 '30   to   90', 9X, '+  Syn-Clinal', 11X, '+sc', 22X,
     8 '30    to  60', 11X, 'Bisectional', 12X, 'bi', /, 3X,
     9 '90   to  150', 9X, '+ Anti-Clinal',11X, '+ac', 22X,
     * '60    to  90', 12X, 'Equatorial', 12X, 'eq', /, 2X,
     1 '150   to  180', 9X, '+ Anti-Periplanar', 7X, '+ap', /, 4X,
     2 '0   to  -30', 9X, '-  Syn-Periplanar', 7X, '-sp', /, 2X,
     3 '-30   to  -90', 9X, '-  Syn-Clinal', 11X, '-sc', /, 2X,
     4 '-90   to -150', 9X, '- Anti-Clinal', 11X, '-ac', /, 1X,
     5 '-150   to -180', 9X, '- Anti-Periplanar', 7X, '-ap')
99963 FORMAT ('_', I3, 2F10.2, 2A)
99962 FORMAT (20X, 8(10X, A))
99961 FORMAT (A)
99960 FORMAT ('Weighted Average Ring Bond Distance = ', F6.4, '(',
     1 I3,',',I3,') Ang. - NOTE: 1st esd. Internal, 2nd esd External.')
99959 FORMAT ('Weighted Average Abs. Torsion Angl. = ', F6.2, '(', I3,
     1 ',',I3,') Deg.',3X,'see: e.g. Domenicano et al., Acta Cryst.',
     2 '(1975), B31, 221-234.')
      END
      SUBROUTINE PLA096 (MODE, NQ, D, CRIT)
      PARAMETER (NP50=100,NP51=100)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /BONDVAL/ VALENCE(1625)
      CHARACTER VALENCE*18
      COMMON /PLC96/ NQ1, NQ2(NP50), NQ3, NQ4, VL(9), NQ5(NP51)
      COMMON /PL096/ DIST(NP50), NVAL(NP51), SUM, MAT, NVL, NAT
      CHARACTER NQ*7, NQ1*7, NQ2*7, NQ3*2, NQ4*2, NQ5*7, VL*2
      IF (MODE .EQ. 0) THEN
        IF (D .LT. 0.0) THEN
          NAT = 0
          SUM = 0.0
          NB  = 0
          NE  = 0
        ELSE
          IF (NAT .LT. NP51) THEN
            NAT      = NAT + 1
            NQ1      = NQ
            NQ5(NAT) = NQ
            MAT      = 0
            CALL GEN105 (2, NQ(2:2), N)
            IF (N .LT. 0) THEN
              NQ3 = NQ(1:1)
            ELSE
              NQ3 = NQ(1:2)
            ENDIF
            NVL = 0
            DO 20 J = 1, 1625
              IF (VALENCE(J)(1:2) .EQ. NQ3) THEN
                IF (NVL .EQ. 0) THEN
                  NVL   = 1
                  VL(1) = ' '//VALENCE(J)(3:3)
                ELSE
                  IF (VALENCE(J)(3:3) .NE. VL(NVL)(2:2)) THEN
                    NVL     = NVL + 1
                    VL(NVL) = ' '//VALENCE(J)(3:3)
                  ENDIF
                ENDIF
              ELSE IF (VALENCE(J)(4:5) .EQ. NQ3) THEN
                IF (NVL .EQ. 0) THEN
                  NVL   = 1
                  VL(1) = VALENCE(J)(6:7)
                ELSE
                  DO 10 I = 1, NVL
                    IF (VALENCE(J)(6:7) .EQ. VL(I)) GOTO 20
   10             CONTINUE
                  NVL     = NVL + 1
                  VL(NVL) = VALENCE(J)(6:7)
                ENDIF
              ENDIF
   20       CONTINUE
          ENDIF
        ENDIF
      ELSE IF (MODE .EQ. 1) THEN
        IF (MAT .LT. NP50) THEN
          MAT       = MAT + 1
          NQ2(MAT)  = NQ
          DIST(MAT) = D
        ENDIF
      ELSE IF (MODE .EQ. -1) THEN
        NP = 0
        DIFM = 10.0
        DO 60 K = 1, NVL
          READ (VL(K), 99995) IVL
          SUM = 0.0
          DMX = 0.0
          L   = 0
          IF (MAT .GT. 0) THEN
            DO 50 I = 1, MAT
              NTV = 0
              IF (NAT .GT. 0) THEN
                DO 30 NT = 1, NAT
                CALL GEN039 (1, NQ5(NT), 1, 7, NB, NE)
                IF (NQ2(I)(1:NE) .EQ. NQ5(NT)(1:NE)) NTV = NVAL(NT)
   30           CONTINUE
              ENDIF
              CALL GEN105 (2, NQ2(I)(2:2), N)
              IF (N .LT. 0) THEN
                NQ4 = NQ2(I)(1:1)
              ELSE
                NQ4 = NQ2(I)(1:2)
              ENDIF
              IF (NQ3 .EQ. NQ4) THEN
                IF (NQ3 .EQ. 'O ' .OR.
     1              NQ3 .EQ. 'N ') GOTO 50
              ENDIF
              IF (NQ3 .EQ. 'N ' .AND. NQ4 .EQ. 'C ') GOTO 50
              DO 40 J = 1, 1625
                IF (VL(K)(1:1) .NE. '-') THEN
                  IF (VL(K)(2:2) .EQ. VALENCE(J)(3:3)) THEN
                    IF (NQ3 .EQ. VALENCE(J)(1:2) .AND.
     1                  NQ4 .EQ. VALENCE(J)(4:5)) THEN
                      READ (VALENCE(J), 99997) R, B
                      BV  = EXP ((R - DIST(I)) / B)
                      IF (BV .GT. IVL * CRIT) THEN
                        SUM = SUM + BV
                        DIF = ABS(IVL - SUM)
                        L = L + 1
                        IF (L .EQ. 1) THEN
                          NP = NP + 1
                          IF (NP .EQ. 1) THEN
                            CALL PLA269 (0)
                            WRITE (LU7, 99998)
                          ENDIF
                          WRITE (LU7, 99996) VL(K)
                        ENDIF
                        DMX = MAX (DMX, DIST(I))
                        WRITE (LU7, 99999) L, NQ1, NQ2(I), DIST(I),
     1                                     R, B, BV, SUM, DIF
                      ENDIF
                      GOTO 50
                    ENDIF
                  ENDIF
                ELSE
                  IF (VL(K) .EQ. VALENCE(J)(6:7)) THEN
                    IF (NQ3 .EQ. VALENCE(J)(4:5) .AND.
     1                  NQ4 .EQ. VALENCE(J)(1:2)) THEN
                      IF (NTV .GT. 0) THEN
                      READ (VALENCE(J)(3:3), 99994) M
                        IF (M .NE. NTV) GOTO 40
                      ENDIF
                      READ (VALENCE(J), 99997) R, B
                      BV  = EXP ((R - DIST(I)) / B)
                      IF (BV .GT. IABS(NTV) * CRIT) THEN
                        SUM = SUM + BV
                        DIF = ABS(IABS(IVL) - SUM)
                        L = L + 1
                        IF (L .EQ. 1) THEN
                          NP = NP + 1
                          IF (NP .EQ. 1) THEN
                            CALL PLA269 (0)
                            WRITE (LU7, 99998)
                          ENDIF
                          WRITE (LU7, 99996) VL(K), CRIT
                        ENDIF
                        DMX = MAX (DMX, DIST(I))
                        WRITE (LU7, 99999) L, NQ1, NQ2(I), DIST(I),
     1                                     R, B, BV, SUM, DIF
                      ENDIF
                      GOTO 50
                    ENDIF
                  ENDIF
                ENDIF
   40         CONTINUE
   50       CONTINUE
            IF (DIF .LT. DIFM) THEN
              NVAL(NAT) = IVL
              DIFM      = DIF
              VSUM      = SUM
              NSUM      = L
              DMAX      = DMX
            ENDIF
          ENDIF
   60   CONTINUE
        IF (VSUM .GT. 0.0) THEN
          WRITE (LU6, 99993) NAT, NQ5(NAT), VSUM, DMAX, NSUM,
     1                       NVAL(NAT)
          CALL PLA269 (0)
        ENDIF
      ENDIF
      RETURN
99999 FORMAT (I2, 2X, 2A, F10.4, F7.4, F5.2, 3F6.3)
99998 FORMAT ('Bond Valence Analysis', /, 21('='), /,
     1        'N.E. Brese & M. O''Keeffe',
     2        ' (1991) Acta Cryst. B47, 192-197.', /,
     3        'I.D. Brown (2002). The Chemical Bond in Inorganic',
     4        ' Chemistry: The Bond Valence Model. ',
     5        'Oxford University Press.')
99997 FORMAT (7X, F6.0, F4.0)
99996 FORMAT (/, 'Nr', 6X, 'Bond', 12X, 'Dist', 6X, 'R',
     1         4X, 'B  BVal   Sum  Diff', ' - Assume Valence = ', A,
     2        ' -- Min. BondVal Contribution = ',
     3        F5.2, ' * Cation Val.')
99995 FORMAT (I2)
99994 FORMAT (I1)
99993 FORMAT ('::', I5, 1X, A, F10.2, F10.4, I5, ' Valence = ', I3)
      END
      SUBROUTINE PLA098 (N1, N2, KB, DIS, SDIS, DIFF, IDS12, MODE)
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118,
     1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP22=256,
     2 NP25=99,NP29=63,NP38=125,NP39=30,NP41=200,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9),
     1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10),
     2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10),
     3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770)
      DIMENSION KSM(71)
      CHARACTER NOTE*1, HYB1*1, HYB2*1, BNDPR*8
      COMMON /BONDTYPE/ BNDTP(11)
      CHARACTER BNDTP*5
      TDIS  = 0.0
      BNDPX = 0.0
      IF (MODE .GT. 0) THEN
        CALL GEN048 (-4, IFG(N1), 24, IHYB1)
        CALL GEN048 (-4, IFG(N2), 24, IHYB2)
        CALL GEN048 (-4, IFG(N1), 15, NO1)
        CALL GEN048 (-4, IFG(N2), 15, NO2)
        IF (IHYB1 .EQ. 0) IHYB2 = 0
        IF (IHYB2 .EQ. 0) IHYB1 = 0
        NOA  = NO1 * 10 + IHYB1
        NOB  = NO2 * 10 + IHYB2
        IEN1 = IEN(NO1 + 1)
        IEN2 = IEN(NO2 + 1)
        IAT1 = IATNR(IEN1)
        IAT2 = IATNR(IEN2)
        IF (IAT1 .LT. IAT2) THEN
          CALL GEN014 (NOA,   NOB)
          CALL GEN014 (IEN1, IEN2)
          CALL GEN014 (IAT1, IAT2)
        ENDIF
        IF (IAT2 .GT. 1) IPR(315) = IPR(315) + 1
        IF (IDS12 .NE. 2000) GOTO 5000
        IEN12 = IEN1 * 1000 + IEN2
        IF (IHYB1 .LT. IHYB2) CALL GEN014 (IHYB1, IHYB2)
        INR = 0
        IF (IEN12 .EQ. 2001) THEN
          TDIS = 0.96
          INR  = 350
        ELSE IF (IEN12 .EQ. 4001) THEN
          TDIS = 0.87
          INR  = 352
        ELSE IF (IEN12 .EQ. 3001) THEN
          NC =  - NINT(CON (N2, NP4))
          IF (NC .EQ. 1) THEN
            TDIS = 0.82
            INR  = 354
          ENDIF
        ELSE IF (IEN12 .EQ. 2002) THEN
          IF (SDIS .GT. 0.0001) THEN
            IPR(317) = IPR(317) + 1
            PAR(318) = PAR(318) + SDIS
          ENDIF
          IF (IPR(483) .GT. 0 .AND. IPR(484) .GT. 0) THEN
            IF (IHYB1 .EQ. 3) THEN
              IF (IHYB2 .EQ. 3) THEN
                TDIS = 1.54
                INR  = 360
              ELSE IF (IHYB2 .EQ. 2) THEN
                TDIS = 1.52
                INR  = 362
              ELSE IF (IHYB2 .EQ. 1) THEN
                TDIS = 1.46
                INR  = 364
              ELSE
                TDIS = 1.50
                INR  = 366
              ENDIF
            ELSE IF (IHYB1 .EQ. 2) THEN
              IF (IHYB2 .EQ. 2) THEN
                TDIS = 1.34
                INR  = 368
              ELSE IF (IHYB2 .EQ. 1) THEN
                TDIS = 1.31
                INR  = 370
              ELSE
                TDIS = 1.50
                INR  = 366
              ENDIF
            ELSE IF (IHYB1 .EQ. 1) THEN
              IF (IHYB2 .EQ. 1) THEN
                TDIS = 1.25
                INR  = 372
              ELSE
                TDIS = 1.50
                INR  = 366
              ENDIF
            ELSE
              TDIS = 1.50
              INR  = 366
            ENDIF
          ENDIF
        ELSE IF (IEN12 .EQ. 4004) THEN
          IF (DIS .GT. 1.45) THEN
            WRITE (LU20, 99993)
     1        374, DIS - 1.45,  DIS, NAMS(KB, 1)(1:7), NAMS(KB, 2)(1:7)
          ENDIF
          GOTO 145
        ENDIF
        IF (INR .NE. 0) THEN
          DIFF = ABS(DIS - TDIS)
          IF (DIFF .GT. 0.001) THEN
            IF (DIS .GT. TDIS) INR = INR + 1
            WRITE (LU20, 99993)
     1        INR, DIFF, DIS, NAMS(KB, 1)(1:7), NAMS(KB, 2)(1:7)
          ENDIF
        ENDIF
  145   NO12  = NOA  * 1000 + NOB
        IM    = IPR(47)
        IF (IM .GT. 0) THEN
          DO 150 I = 1, IM
            IF (NO12 .EQ. KBO(I, 1)) THEN
              IF (KBO(I, 2) .EQ. 0) BOK(I, 1) = 9999.0
              KBO(I, 2) = KBO(I, 2) + 1
              BOK(I, 3) = BOK(I, 3) + DIS
              IF (SDIS .GT. 0.0) THEN
                KBO(I, 5) = KBO(I, 5) + 1
                BOK(I, 6) = BOK(I, 6) + SDIS
              ENDIF
              IF (DIS .LT. BOK(I, 1)) BOK(I, 1) = DIS
              IF (DIS .GT. BOK(I, 2)) BOK(I, 2) = DIS
              RETURN
            ENDIF
  150     CONTINUE
        ENDIF
        IF (IPR(47) .LT. NP8) THEN
          IPR(47)   = IPR(47) + 1
          I         = IPR(47)
          KBO(I, 1) = NO12
          BOK(I, 1) = DIS
          BOK(I, 2) = DIS
          BOK(I, 3) = DIS
          KBO(I, 2) = 1
          IF (SDIS .GT. 0.0) THEN
            KBO(I, 5) = 1
            BOK(I, 6) = SDIS
          ENDIF
        ENDIF
      ELSE IF (MODE .LT. 0) THEN
        IF (IPR(6) .NE. 0) THEN
          IF (IPR(317) .GT. 0) THEN
            PAR(318) = PAR(318) / IPR(317)
            I318 = NINT(PAR(318) * 1000)
            IF (IPR(22) .LT. 20) THEN
              IBPR = 340
            ELSE IF (IPR(22) .GE. 40) THEN
              IBPR = 342
            ELSE
              IBPR = 341
            ENDIF
            WRITE (LU20, 99994) IBPR, I318, I318
          ENDIF
          IM = IPR(47)
          IF (IGBL(63) .GT. 2) THEN
            CALL PLA269 (-6)
            WRITE (LU7, 99999)
          ENDIF
          DO 110 I = 1, IM
            DO 20 J = 1, 71
              KSM(J) = 0
   20       CONTINUE
            IPR(133) = -1
   30       IPR(133) = IPR(133) + 1
            IF (IPR(133) .GT. 1) GOTO 60
            IFIN = -1
   40       CALL PLA038 (I0, J0, IFIN)
            IF (IFIN .EQ. 1) GOTO 30
            CALL GEN048 (-4, IFG(I0), 24, IHYB1)
            CALL GEN048 (-4, IFG(J0), 24, IHYB2)
            CALL GEN048 (-4, IFG(I0), 15, NO1)
            CALL GEN048 (-4, IFG(J0), 15, NO2)
            IF (IHYB1 .EQ. 0) IHYB2 = 0
            IF (IHYB2 .EQ. 0) IHYB1 = 0
            NOA = NO1 * 10 + IHYB1
            NOB = NO2 * 10 + IHYB2
            IF (IATNR(IEN(NO1 + 1)) .LT. IATNR(IEN(NO2 + 1))) THEN
              CALL GEN014 (NOA, NOB)
            ENDIF
            NO12 = NOA * 1000 + NOB
            IF (KBO(I, 1) .NE. NO12) GOTO 40
            CALL PLA050 (I0, J0, 0, 0, DIST)
            NDIS      = MIN (71, NINT(DIST * 20 + 1))
            KSM(NDIS) = KSM(NDIS) + 1
            GOTO 40
   60       DO 100 J = 1, 71
              IDMJ = KSM(J)
              IF (IDMJ .LE. 0) THEN
                IDM(J:J) = '.'
              ELSE IF (IDMJ .LE. 9) THEN
                IDM(J:J) = CHAR(ICHAR('0') + IDMJ)
              ELSE IF (IDMJ .LE. 35) THEN
                IDM(J:J) = CHAR(ICHAR('Z') - 35 + IDMJ)
              ELSE
                IDM(J:J) = '*'
              ENDIF
  100       CONTINUE
            HYB1 = ' '
            HYB2 = ' '
            K = KBO(I, 1) / 1000
            L = KBO(I, 1) - K * 1000
            IHYB1 = MOD (K, 10)
            IHYB2 = MOD (L, 10)
            K = K / 10 + 1
            L = L / 10 + 1
            IF (IHYB1 .NE. 0) THEN
              IF (IEN(K) .EQ. 2 .OR. IEN(K) .EQ. 4)
     1            HYB1 = CHAR(IHYB1 + 49)
              IF (IEN(L) .EQ. 2 .OR. IEN(K) .EQ. 4)
     1            HYB2 = CHAR(IHYB2 + 49)
            ENDIF
            SUMR = RADR(K, 2) + RADR(L, 2)
            IF (KBO(I, 2) .GT. 0) BOK(I, 3) = BOK(I, 3) / KBO(I, 2)
            IF (KBO(I, 5) .GT. 0) THEN
              BOK(I, 6) = BOK(I, 6) / KBO(I, 5)
              WRITE (BNDPR, '(F8.4)') BOK(I, 6)
            ELSE
              CALL GEN038 (BNDPR, 1, 8)
            ENDIF
            IF (BOK(I, 1) + 0.4 .LT. SUMR .AND. KBO(I, 2) .GT. 0)
     1        THEN
              NOTE = 'S'
            ELSE
              NOTE = ' '
            ENDIF
            IF (KBO(I, 5) .GT. 0) THEN
              IF (LMT(L, 1) .NE. ' H' .AND. LMT(L, 1) .NE. ' D' .AND.
     1            LMT(L, 1) .NE. 'Hw') THEN
                BNDTP(1) = LMT(K, 1)//'-'//LMT(L, 1)
                BNDPX    = BOK(I, 6)
              ENDIF
            ENDIF
            IF (IGBL(63) .GT. 2) THEN
              CALL PLA269 (2)
              WRITE (LU7, 99998) LMT(K, 1), HYB1, LMT(L, 1), HYB2,
     1         KBO(I, 2), BNDPR, (BOK(I, J), J = 1, 3), SUMR, NOTE,
     2         IDM(1:71)
            ENDIF
  110     CONTINUE
          IF (PAR(318) .GT. 0) THEN
            BNDTP(1) = '  C-C'
          ELSE
            PAR(318) = BNDPX
          ENDIF
          IF (IGBL(63) .GT. 3) THEN
            CALL PLA269 (22)
            WRITE (LU7, 99997)
            WRITE (LU7, 99996)
          ENDIF
        ENDIF
        IF (IPR(315) .NE. 0) THEN
          RATIO = FLOAT(IPR(316)) / FLOAT(IPR(315))
          IF (RATIO .LT. 1.0 .AND. IGBL(8) .EQ. 3)
     1        WRITE (LU20, 99995) '_763', 1.0 - RATIO, RATIO
          IF (RATIO .GT. 1.0)
     1        WRITE (LU20, 99995) '_764', RATIO - 1.0, RATIO
        ENDIF
      ELSE
        IPR(47)  = 0
        IPR(317) = 0
        PAR(318) = 0
        DO 140 I = 1, NP8
          DO 120 J = 1, 5
            KBO(I, J) = 0
  120     CONTINUE
          DO 130 J = 1, 6
            BOK(I, J) = 0.0
  130     CONTINUE
  140   CONTINUE
      ENDIF
 5000 RETURN
99999 FORMAT ('Statistics of Bond Length per Bond Type (NOTE: ',
     1 'A Indicates 10 Occurrences, B Indicates 11, Etc. and',
     2 ' * more than 35)', /, 132('='), //, 'Bond Type   Nr', 4X,
     3 'B.P.', 2X, 'd(min)', 2X, 'd(max)', 3X, 'd(av) Sumrad Note',
     4 2X, '0.0', 7X, '0.5', 7X, '1.0', 7X, '1.5', 7X, '2.0', 7X,
     5 '2.5', 7X, '3.0 Angstrom', /, 58('-'), 3X, 35('I-'), 'I')
99998 FORMAT (2A, ' -- ', 2A, I4, A, 3F8.4, F7.2, 4X, A, 3X, A, /)
99997 FORMAT (//, 'Selected Bond Lengths (Angstrom) - ',
     1 'see M.F.C. Ladd & R.A. Palmer, ',
     2 'Structure Determination by X-Ray Crystallography (1985)', /,
     3 132('='), //, 49X, 'Formal single bonds', /, 49X, 19('-'), /,
     4 'C4-C4 1.54   C4-C3 1.52   C4-C2 1.46   C4-N3 1.47   C4-N2 ',
     5 '1.47   C4-O2 1.43   C3-C3 1.46   C3-C2 1.45   C3-N3 1.40   ',
     6 'C3-N2 1.40', /, 'C3-O2 1.36   C2-C2 1.38   C2-N3 1.33   C2-N2',
     7 ' 1.33   C2-O2 1.36   N3-N3 1.45   N3-N2 1.45   N3-O2 1.36   ',
     8 'N2-N2 1.45   N2-O2 1.41', //, 49X, 'Formal double bonds', /,
     9 49X, 19('-'), /, 'C3-C3 1.34   C3-C2 1.31   C3-N2 1.32   C3-O1',
     * ' 1.22   C2-C2 1.28   C2-N2 1.32   C2-O1 1.16   N3-O1 1.24   ',
     1 'N2-N2 1.25   N2-O1 1.21', /)
99996 FORMAT ('Formal triple bonds', 17X,
     1 'Aromatic bonds', /, 19('-'), 17X, 14('-'), /, 'C2-C2 1.20',
     2 '   C2-N1 1.16   C3-C3 1.40   C2-N2 1.34   N2-N2 1.35', //,
     3 'The notation in the table indicates the connectivity of the',
     4 ' atoms', //,
     5 'For more detailed standard bond distance tabulations see: ',
     6 'J. Chem. Soc. Perkin II, (1987), S1-S19;', /,
     7 'J. Chem. Soc. Dalton Trans. (1989), S1 - S83 or ',
     8 'International Tables C, (1992), 707-791.')
99995 FORMAT (A, 2F10.2)
99994 FORMAT ('_', I3, 2I10)
99993 FORMAT ('_', I3, 2F10.2, 2A)
      END
      SUBROUTINE PLA099 (MODE, IAT, NANG, ANG1, ANG2, ANG3, NCEFF,
     1                     IMET, IHYB, CHYB, NATH, NOTE1)
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118,
     1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP25=99,
     2 NP29=63,NP38=125,NP39=30,NP41=200,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9),
     1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10),
     2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10),
     3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770)
      CHARACTER CHYB*3, NOTE1*1
      NMET = 0
      NATX = IPR(37)
      NAT  = IPR(39)
      CALL GEN048 (-4, IFG(IAT), 15, NO1)
      NO1 = NO1 + 1
      CALL GEN048 (-7, JFG(IAT), 1, IPPI0)
      IPPI0 = IPPR(IPPI0 + 1, 1)
      NC    = - NINT(CON(IAT, NP4))
      IF (NC .LT. 0) THEN
        NC = NP4
        CALL GEN048 (-1, IFG(IAT), 8, IVAL)
        IF (IVAL .GT. 0) NC = NC + IPR(76)
      ENDIF
      MSKP = 0
   10 NANG = 0
      ANG3 = 0.0
      ANG2 = 0.0
      EFNC = 0.0
      ENCH = 0.0
      DISM = 99.0
      IF (NC .GT. 0) THEN
        ANG1 = 9999.0
        NMET = 0
        DO 30 J = 1, NC
          IF (J .LE. NP4) THEN
            J0 = NINT(CON(IAT, J))
          ELSE
            IF (IBON(J - NP4, 1) .NE. IAT) GOTO 30
            J0 = IBON(J - NP4, 2)
          ENDIF
          CALL GEN048 (-1, IFG(J0), 7, IHAT)
          IF (IHAT .EQ. 0) THEN
            CALL PLA050 (J0, IAT, 0, 0, DIS0)
            DISM = MIN (DISM, DIS0)
          ENDIF
          CALL GEN048 (-1, IFG(J0), 19, IVL1)
          IF (MSKP * IVL1 .EQ. 1) GOTO 30
          NMET = NMET + IVL1
          CALL GEN048 (-7, JFG(J0), 1, IPPJ0)
          IPPJ0 = IPPR(IPPJ0 + 1, 1)
          EFNC = EFNC + FLOAT(IPPJ0) / FLOAT(IPPI0)
          CALL GEN048 (-1, IFG(J0), 7, IHAT)
          IF (IHAT .EQ. 1) ENCH = ENCH + FLOAT(IPPJ0) / FLOAT(IPPI0)
          IF (J .LT. NC) THEN
            K1 = J + 1
            DO 20 K = K1, NC
              IF (K .LE. NP4) THEN
                K0 = NINT(CON(IAT, K))
              ELSE
                IF (IBON(K - NP4, 1) .NE. K) GOTO 20
                K0 = IBON(K - NP4, 2)
              ENDIF
              CALL GEN048 (-7, JFG(K0), 1, IPPK0)
              IPPK0 = IPPR(IPPK0 + 1, 1)
              IF (IPPJ0 .GT. 0 .AND. IPPK0 .GT. 0) THEN
                IF (IPPJ0 .EQ. IPPK0) THEN
                  CALL PLA050 (J0, IAT, K0, 0, ANG)
                  IF (IEN(NO1) .EQ. 2 .AND. IVL1 .EQ. 1 .AND.
     1              ANG .LE. 85) THEN
                    MSKP = 1
                    GOTO 10
                  ENDIF
                  NANG = NANG + 1
                  ANG2 = MAX (ANG2, ANG)
                  ANG1 = MIN (ANG1, ANG)
                  ANG3 = ANG3 + ANG
                ENDIF
              ENDIF
   20       CONTINUE
          ENDIF
   30   CONTINUE
        IF (NANG .GT. 0) THEN
          ANG3 = ANG3 / NANG
        ELSE
          ANG1 = 0.0
        ENDIF
      ELSE
        ANG1 = 0.0
      ENDIF
      IHYB = 0
      CHYB = '   '
      IF (MODE .EQ. 0) THEN
        NCEFF = NC
      ELSE
        NCEFF = NINT(EFNC)
      ENDIF
      IF (IAT .LE. NAT) THEN
        IF (IEN(NO1) .EQ. 2 .OR. IEN(NO1) .EQ. 85) THEN
          IF (ANG1 .LT. 35.0) NOTE1 = 'A'
          IF (NCEFF .EQ. 4) THEN
            IF (ABS(ANG3 - 108.0) .LT. 2.5) THEN
              IF (NMET .EQ. 2) THEN
                IHYB = 2
              ELSE
                IHYB = 3
              ENDIF
            ENDIF
            IF (ANG2 .GT. 125.0 .AND. ANG1 .GT. 61
     1                          .AND. IMET .EQ. 0) THEN
              NOTE1    = 'A'
            ENDIF
          ELSE IF (NCEFF .EQ. 3) THEN
            IF (ABS(ANG3 - 120.0) .LT. 2.0) THEN
              IHYB = 2
            ENDIF
          ELSE IF (NCEFF .EQ. 2) THEN
            IF (ABS(ANG3 - 180.0) .LT. 10.0) THEN
              IHYB = 1
            ENDIF
          ELSE IF (NCEFF .EQ. 1) THEN
            IF (MODE .EQ. 1 .AND. IAT .LE. NATX)
     1          IPR(401) = IPR(401) + 1
            NOTE1    = '?'
          ENDIF
          IF (IHYB .EQ. 0 .AND. IMET .EQ. 0) THEN
            IF (IEN(NO1) .EQ. 2) THEN
              IF (MODE .EQ. 1 .AND. IAT .LE. NATX) THEN
                  IF (ABS(NCEFF - EFNC) .LT. 0.002)
     1                IPR(402) = IPR(402) + 1
              ENDIF
              NOTE1 = '?'
            ENDIF
          ENDIF
        ELSE IF (IEN(NO1) .EQ. 3) THEN
          IF (NC .EQ. 2) THEN
            IHYB = 3
          ELSE IF (NC .EQ. 1) THEN
            CALL PLA050 (NINT(CON(IAT, 1)), IAT, 0, 0, DIST)
            IHYB = 2
          ENDIF
        ELSE IF (IEN(NO1) .EQ. 4) THEN
          IF (NC .EQ. 1) THEN
            CALL PLA050 (NINT(CON(IAT, 1)), IAT, 0, 0, DIST)
            IF (DIST .LT. 1.2) IHYB = 1
          ENDIF
          IF (NC .EQ. 3 .AND. ABS(ANG3 - 120.0) .LT. 1.5
     1                             .AND. DISM .LT. 1.335) IHYB = 2
          IF (NC .EQ. 4 .AND. ABS(ANG3 - 109.5) .LT. 1.0) IHYB = 3
          IF (NC .EQ. 3 .AND. ANG3 .LT. 112)              IHYB = 3
        ELSE IF (IEN(NO1) .EQ. 8) THEN
          IF (NC .EQ. 4 .AND. ABS(ANG3 - 109.5) .LT. 1.0) IHYB = 3
        ENDIF
        IF (IAT .LE. NATX .OR. IPR(322) .EQ. 0) THEN
          IF (IHYB .EQ. 1) THEN
            CHYB = 'sp '
          ELSE IF (IHYB .EQ. 2) THEN
            CHYB = 'sp2'
          ELSE IF (IHYB .EQ. 3) THEN
            CHYB = 'sp3'
          ENDIF
        ENDIF
      ENDIF
      IF (IAT .LE. NATX .AND. IHYB .EQ. 0) THEN
        IF (ANG1 .LT. 90.0 .AND. ANG1 .GT. 0.1) THEN
          IF (NO1 .EQ. 3 .AND. NC .EQ. 2) THEN
            NOTE1 = ' '
          ELSE IF (IMET .EQ. 0 .AND. NC .LT. 6 .AND.
     1             IEN(NO1) .NE. 92) THEN
            NOTE1 = 'A'
          ENDIF
        ENDIF
      ENDIF
      NATH = MIN (NINT(ENCH), 7)
      RETURN
      END
      SUBROUTINE PLA100 (IAT, JAT, MODE, DASH)
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16,
     1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NPVD=40000000,
     2 NP23=18000,NP25=99,NP29=63,NP38=125,NP39=30,NP41=200,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON // JNSC(2, NP23), VOID(NPVD)
      DASH0 = DASH
      NB = IPR(131)
      I = IAT
      J = JAT
      IF (I .GT. J) CALL GEN014 (I, J)
      IF (NB .GT. 0) THEN
        DO 10 K = 1, NB
          IA = NINT(VOID(IPR(298) + K * 3 - 2))
          JA = NINT(VOID(IPR(298) + K * 3 - 1))
          IF (I .EQ. IA .AND. J .EQ. JA) THEN
            IF (MODE .EQ. -2) THEN
              VOID(IPR(298) + K * 3 - 2) = VOID(IPR(298) + NB * 3 - 2)
              VOID(IPR(298) + K * 3 - 1) = VOID(IPR(298) + NB * 3 - 1)
              VOID(IPR(298) + K * 3)     = VOID(IPR(298) + NB * 3)
              IPR(131)                   = IPR(131) - 1
              GOTO 30
            ELSE
              N = K
              GOTO 20
            ENDIF
          ENDIF
   10   CONTINUE
      ENDIF
      IF (MODE .EQ. -2) GOTO 30
      IPR(131) = IPR(131) + 1
      N        = IPR(131)
      IPR(299) = IPR(298) + N * 3
   20 XBND     = 1.0
      CALL GEN048 (-1, IFG(I), 19, METI)
      CALL GEN048 (-1, IFG(J), 19, METJ)
      IF (METI .EQ. 1 .OR. METJ .EQ. 1) XBND = 5.0
      CALL GEN048 (-1, IFG(I), 7, IHAT)
      CALL GEN048 (-1, IFG(J), 7, JHAT)
      IF (IHAT .EQ. 1 .OR. JHAT .EQ. 1) XBND = 3.0
      VOID(IPR(298) + N * 3 - 2) = I
      VOID(IPR(298) + N * 3 - 1) = J
      IF (DASH0 .LT. 2.0) THEN
        CALL GEN048 (-7, JFG(I), 1, IPP)
        CALL GEN048 (-7, JFG(J), 1, JPP)
        IPP = IPPR(IPP + 1, 1) / 500
        JPP = IPPR(JPP + 1, 1) / 500
        IF (IPP .LT. 2 .OR. JPP .LT. 2) THEN
          XBND = 7.0
          IF (IPP * JPP .EQ. 0) DASH0 = -1.0
        ENDIF
      ELSE
        DASH0 = 1.0
      ENDIF
      IF (DASH0 .LT. -1.0) THEN
        DASH0 = -1.0
        XBND  = 7.0
      ENDIF
      VOID(IPR(298) + N * 3) = SIGN(XBND, DASH0)
   30 RETURN
      END
      SUBROUTINE PLA101
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16,
     1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP22=256,NP25=99,
     2 NP29=63,NP38=125,NP39=30,NP41=200,NP45=2048,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /Q/ ICL, IFL(NP17)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0
      COMMON /CGGT/ IGGT
      CHARACTER IGGT*80, TYPE*4
      J1    = 0
      J2    = 0
      XOS   = 0.0
      YOS   = 0.0
      IENR  = 0
      NRING = 0
      NHEAD = 0
      IGBL(23) = 13
   10 IOPEN    = 0
      NR       = 0
      NAT      = IPR(39)
   20 READ (LU8) MARK, IPR(12), JR, RMAT
      IF (MARK .EQ. -100) THEN
        CALL PLA015 (0, 18)
        CALL GEN108 (LU8, 0)
        IPR(169) = 0
        GOTO 190
      ENDIF
      NL4 = NAT
      IF (MARK .EQ. -1) NL4 = 240
      READ (LU8) (IATP(L4), L4 = 1, NL4)
      IF (MARK .NE. IPR(55)) THEN
        IF (IPR(55) .EQ. 1) THEN
          IF (MARK .LT. 1 .OR. MARK .GT. 4) GOTO 20
        ELSE
          GOTO 20
        ENDIF
      ENDIF
   30 IF (IOPEN .EQ. 0) THEN
        HORS = 25.0
        VERT = 25.0
        CALL GGIP (HORS, VERT, 0.0, 1)
        CALL PLA117 (HORS, VERT, -1)
        IOPEN = 1
        IF (IPR(55) .NE. -1)
     1    CALL GGIP20 (0.0, JID(75:80), 6, 0.45, 1, 2, 10.5, 24.25)
      ENDIF
C * PLAN, RING, RESD, LSPL
      IF (IPR(55) .GT. 0) THEN
        CALL PLA102 (PMAX, SX, SY, SZ)
        IF (MARK .EQ. 1) THEN
          TYPE = 'Plan'
        ELSE IF (MARK .EQ. 2) THEN
          TYPE  = 'Ring'
          NRING = NRING + 1
        ELSE IF (MARK .EQ. 3) THEN
          TYPE = 'Resd'
        ELSE IF (MARK .EQ. 4) THEN
          TYPE = 'Lspl'
        ENDIF
        CALL GGIP20 (0.0, TYPE, 4, 0.45, 1, 2, 23.0, 24.0)
        NR  = NR + 1
        SXY = VERT / 2.0
        SC  = SXY  * 0.8 / PMAX
        CALL GEN096 (RMAT, IROTX, IROTY, IROTZ, IDET, V6, YANK, QM)
        GL(28)   = IROTX
        GL(29)   = IROTY
        GL(30)   = IROTZ
        IGBL(87) = IDET
        IGBL(67) = 1
        CALL GEN040 (IROTX, NQ1, IP)
        CALL GEN040 (IROTY, NQ2, IP)
        CALL GEN040 (IROTZ, NQ3, IP)
        CALL GGIP20 (0.0, NQ1, 4, 0.4, 1, 2, 23.6, 0.15)
        CALL GGIP20 (0.0, NQ2, 4, 0.4, 1, 2, 0.15, 24.5)
        CALL GGIP20 (0.0, NQ3, 4, 0.4, 1, 2, 0.15, 0.15)
        CALL GEN040 (IPR(140), NQ1, IP)
        CALL GGIP20 (0.0, NQ1, 2, 0.4, 1, 2, 22.5, 0.15)
        YRR   = 0.4
        IPR12 = IPR(12)
        IF (IPR12 .LE. 20) THEN
          DO 40 I = 1, IPR12
            CALL PLA047 (XLAB(IATP(I)), NQ1, IDUM, JDUM, IPR(119),
     1                   IGBL(55), 0, 0)
            YRR = YRR + 0.5
            YR  = YRR
            XR  = 1.0
            CALL GGIP20 (0.0, NQ1, 5, 0.35, 1 + IPR(346), 2, XR, YR)
   40     CONTINUE
        ENDIF
        IF (IPR(56) .NE. 0) THEN
          CALL PLA044 (RMAT, -NR, XR, YR, ZR, SX, SY, SZ, SC, SXY)
          YR    = YR + 0.05
          CALL GGIP (2.0,  YR, 0.0, 3)
          CALL GGIP (23.0, YR, 0.0, 2)
          YR    = YR - 0.1
          CALL GGIP (23.0, YR, 0.0, 3)
          CALL GGIP (2.0,  YR, 0.0, 2)
          CALL GEN040 (NR, NQ1, IP)
          CALL GGIP20 (0.0, NQ1, IP, 0.5, 1, 2, 23.0, 24.3)
        ENDIF
        I = 0
   50   I = I + 1
        IF (I .LE. NAT) THEN
          IF (IATC(I) .EQ. 0) GOTO 50
          CALL GEN048 (-1, IFG(I), 7, IVAL)
          IF (IVAL .GT. 0) GOTO 50
          CALL PLA044 (RMAT, I, XR, YR, ZR, SX, SY, SZ, SC, SXY)
          XR0    = XR
          YR0    = YR
          NQ1(1:1) = '.'
          DO 60 II = 1, IPR12
            IF (I .EQ. IATP(II)) THEN
              NK0 = 1 + IPR(346)
              GOTO 70
            ENDIF
   60     CONTINUE
          CALL GGIP (0.0, 1.0, 0.0, 0)
          NK0 = 1
   70     CALL GGIP20 (0.0, NQ1, 1, 0.5, NK0, 2, XR0, YR0)
          CALL PLA047 (XLAB(I), NQ1, IDUM, JDUM, IPR(119), IGBL(55),
     1                 0, 0)
          XR0 = XR + 0.5
          YR0 = YR + 0.5
          CALL GGIP20 (0.0, NQ1, 6, 0.4, NK0, 2, XR0, YR0)
          GOTO 50
        ENDIF
        I = 0
   80   I = I + 1
        IF (I .GT. NAT) GOTO 180
        IF (IATC(I) .EQ. 0) GOTO 80
        JM = - NINT(CON(I, NP4))
        IF (JM .LT. 0) JM = NP4
        IF (JM .LE. 0) GOTO 80
        CALL GEN048 (-1, IFG(I), 7, IHAT)
        CALL PLA044 (RMAT, I, XR1, YR1, ZR1, SX, SY, SZ, SC, SXY)
        DO 110 J = 1, JM
          K = NINT(CON(I, J))
          IF (I .GE. K) GOTO 110
          IF (IATC(K) .EQ. 0) GOTO 110
          CALL GEN048 (-1, IFG(K), 7, KHAT)
          IF (IHAT + KHAT .GT. 0) THEN
            IF (IPR(346) .GT. 0) CALL GGIP (0.0, 4.0, 0.0, 0)
          ELSE
            DO 90 II = 1, IPR12
              IF (I .EQ. IATP(II) .OR. K .EQ. IATP(II)) THEN
                IF (IPR(346) .GT. 0) CALL GGIP (0.0, 2.0, 0.0, 0)
                GOTO 100
              ENDIF
   90       CONTINUE
            IF (IPR(346) .GT. 0) CALL GGIP (0.0, 3.0, 0.0, 0)
  100       CONTINUE
          ENDIF
          CALL PLA044 (RMAT, K, XR2, YR2, ZR2, SX, SY, SZ, SC, SXY)
          XR3 = XR2 - XR1
          YR3 = YR2 - YR1
          XYR3 = SQRT(XR3**2 + YR3**2 + PAR(12))
          XR3 = 0.4 * XR3 / XYR3
          YR3 = 0.4 * YR3 / XYR3
          XR1 = XR1 + XR3
          YR1 = YR1 + YR3
          ZGGIP = 0.0
          CALL GGIP (XR1, YR1, ZGGIP, 3)
          XR1 = XR1 - XR3
          YR1 = YR1 - YR3
          XR2 = XR2 - XR3
          YR2 = YR2 - YR3
          CALL GGIP (XR2, YR2, ZGGIP, 2)
  110   CONTINUE
        GOTO 80
C * NEWMAN PLOT
      ELSE IF (IPR(55) .EQ. -1) THEN
        IPR(169) = IPR(169) + 1
        IF (IPR(162) .GT. 0) THEN
          J1 = IPR(162) / (NP1 + 1)
          J2 = MOD(IPR(162), NP1 + 1)
        ENDIF
        IF (IOPEN .EQ. 1) THEN
          CALL GGIP (0.0,   VERT, 0.0, 3)
          CALL GGIP (HORS,  VERT, 0.0, 2)
          CALL GGIP (0.0,   0.0,  0.0, 3)
          CALL GGIP (HORS,  0.0,  0.0, 2)
          XGGIP = IGBL(103)
          YGGIP = VERT / 2.0
          CALL GGIP (XGGIP, YGGIP, 0.0, 3)
          CALL GGIP (HORS,  YGGIP, 0.0, 2)
          YGGIP = VERT - 1.0
          CALL GGIP (XGGIP, YGGIP, 0.0, 3)
          CALL GGIP (HORS,  YGGIP, 0.0, 2)
          YGGIP = VERT / 2.0 - 1.0
          CALL GGIP (XGGIP, YGGIP, 0.0, 3)
          CALL GGIP (HORS,  YGGIP, 0.0, 2)
          YGGIP = IGBL(103)
          CALL GGIP (XGGIP, YGGIP, 0.0, 3)
          CALL GGIP (HORS,  YGGIP, 0.0, 2)
          XGGIP = HORS / 2.0
          YGGIP = IGBL(103)
          CALL GGIP (XGGIP, YGGIP,  0.0, 3)
          CALL GGIP (XGGIP, VERT,   0.0, 2)
          XGGIP = IGBL(103)
          CALL GGIP (XGGIP, YGGIP,  0.0, 3)
          CALL GGIP (XGGIP, VERT,   0.0, 2)
          XGGIP = HORS / 2.0 + IGBL(103)
          CALL GGIP (XGGIP, YGGIP,  0.0, 3)
          CALL GGIP (XGGIP, VERT,   0.0, 2)
          CALL GGIP (HORS,  YGGIP,  0.0, 3)
          CALL GGIP (HORS,  VERT,   0.0, 2)
          IOPEN = 2
        ENDIF
  120   IVWP = 0
  130   IVWP = IVWP + 1
        IF (IVWP .GT. IPR(12)) THEN
          IF (IPR(162) .GT. 0) THEN
            GOTO 20
          ELSE
            GOTO 180
          ENDIF
        ENDIF
        ISH = (IVWP - 1) * 60
        J   = IATP(2 + ISH)
        K   = IATP(3 + ISH)
        IF (IPR(162) .GT. 0) THEN
          IF ((J1 .NE. J .OR. J2 .NE. K) .AND.
     1        (J1 .NE. K .OR. J2 .NE. J)) THEN
            GOTO 130
          ELSE
            IPR(162) = 0
            GOTO 120
          ENDIF
        ENDIF
        CALL PLA047 (XLAB(J), NQ1, IDUM, JDUM, 0, IGBL(55), 0, 0)
        CALL PLA047 (XLAB(K), NQ2, IDUM, JDUM, 0, IGBL(55), 0, 0)
        IF (IVWP .EQ. 1) THEN
          XOR = HORS / 4.0
          YOR = 3.0 * VERT / 4.0
          XOS =  XOR
          YOS =  YOR
        ELSE IF (IVWP .EQ. 2) THEN
          XOR = HORS / 2.0
          YOR = 0.0
          XOS = XOS + XOR
        ELSE IF (IVWP .EQ. 3) THEN
          XOR = - HORS / 2.0
          YOR = - VERT / 2.0
          XOS = XOS + XOR
          YOS = YOS + YOR
        ELSE IF (IVWP .EQ. 4) THEN
          XOR = HORS / 2.0
          YOR = 0.0
          XOS = XOS + XOR
        ENDIF
        CALL GGIP (XOR, YOR, 0.0, -3)
        XR = -2.5
        YR =  5.5
        NK0 = 1
        IF (IPR(346) .EQ. 1) NK0 = 5
        CALL GGIP20 (0.0, NQ1//'-'//NQ2, 11, 0.5, NK0, 2, XR, YR)
        NWMNR = (IPR(169) - 1) * 4 + IVWP
        CALL GEN040 (NWMNR, NQ1, IP)
        XR = 5.9 - (IP * 0.4 * 6.0) / 7.0
        CALL GGIP20 (0.0, NQ1, IP, 0.4, 1, 2, XR, YR)
        CALL PLA289 (0.0, 0.0, 1.0, 24)
        NWM   = IATP(1 + ISH)
        IPHIP = 90
        DO 170 I = 1, NWM
          PHI   = IATP(20 + ISH + I) / (GL(5) * 100.0)
          PHIL  = IATP(38 + ISH + I) / (GL(5) * 100.0)
          IPHI  = NINT((IATP(21 + ISH + I) - IATP(20 + ISH + I))
     1          / 100.0)
          CALL GEN040 (IPHI, NQ1, IP)
          PHIB  = PHI + IPHI / (GL(5) * 2)
          RADCP = PAR(24) * COS(PHI)
          RADSP = PAR(24) * SIN(PHI)
          XPL   = RADCP * 3
          YPL   = RADSP * 3
          XLB   = PAR(24) * COS(PHIL) * 4
          YLB   = PAR(24) * SIN(PHIL) * 4
          XAG   = PAR(24) * COS(PHIB) * 2
          YAG   = PAR(24) * SIN(PHIB) * 2
          IF (IP .LE. 1) THEN
            XAG   = XAG * 1.75
            YAG   = YAG * 1.75
          ELSE
            IF (IPHI .LE. 40) THEN
              XAG  = XAG * 1.4
              YAG  = YAG * 1.4
            ENDIF
          ENDIF
          XAG   = XAG - IP * PAR(25) / 2
          YAG   = YAG - PAR(25) / 2
          IF (IATP(I + 3 + ISH) .LE. NP1) THEN
            XST = RADCP
            YST = RADSP
          ELSE
            XST = 0.0
            YST = 0.0
          ENDIF
          L = MOD(IATP(I + 3 + ISH), NP1)
          CALL PLA047 (XLAB(L), NQ3, IDUM, IENR, 0, IGBL(55), 0, 0)
          DO 150 L0 = 1, 5
            IF (NQ3(6-L0:6-L0) .NE. ' ') GOTO 160
  150     CONTINUE
  160     L0 = 6 - L0
          IF (COS(PHIL) .LT. 0) THEN
            XLB = XLB + L0 * PAR(25) * COS(PHIL) * 5.0 / 6.0
            IF (IGBL(103) .EQ. 1) XLB = MAX (XLB, -5.0)
            IF (IPHIP .LT. 25) THEN
              YLB = YLB - PAR(25) -0.05
            ENDIF
          ELSE
            IF (IPHIP .LT. 25) THEN
              YLB = YLB + PAR(25) + 0.05
            ENDIF
          ENDIF
          CALL GGIP (XST, YST, 0.0, 3)
          CALL GGIP (XPL, YPL, 0.0, 2)
          NK0 = 1
          IF (IPR(346) .EQ. 1 .AND. IENR .NE. 1) NK0 = 2
          CALL GGIP20 (0.0, NQ3, L0, PAR(25), NK0, 2, XLB, YLB)
          IF (IPR(346) .EQ. 1) NK0 = 3
          CALL GGIP20 (0.0, NQ1, IP, 0.5, NK0, 2, XAG, YAG)
          IPHIP = IPHI
  170   CONTINUE
        GOTO 130
      ENDIF
  180 CALL GGIP (0.0, 1.0, 0.0, 0)
      CALL GGIP (0.0, 0.0, 0.0, 3)
  190 CALL GGIP (-XOS, - YOS, 0.0, -3)
      CALL PLA013 (1, 1)
      IF (IGBL(5) .EQ. LU5) THEN
        CALL GEN020 (1, IGGT, 1, 80)
        IF (IGGT(1:1) .EQ. ' ') WRITE (LU6, 99999)
        IF (IGGT(1:1) .EQ. '!' .OR. IGGT(1:1) .EQ. 'Y') GOTO 10
        IF (IGGT(1:5) .EQ. 'CANDP') THEN
          IF (IPR(55) .EQ. 2 .AND. IPR(12) .GT. 0 .AND. IPR(12) .LT. 8)
     1      CALL PLA095 (NRING, NHEAD, 1)
          GOTO 10
        ENDIF
        CALL PLA006 (0, IS)
        IF (IFL(1)(1:3) .EQ. 'REF') THEN
          IOPEN    = 0
          IPR(169) = IPR(169) - 1
          GOTO 30
        ELSE
          IPR(201) = 0
          CALL PLA280 (ICL)
          IGBL(23) = 10
        ENDIF
      ELSE
        GOTO 10
      ENDIF
      IPR(1) = 5
      RETURN
99999 FORMAT (':: Type Y(es) to continue this plot sequence, ',
     1 ' or another instruction', /)
      END
      SUBROUTINE PLA102 (PMAX, SX, SY, SZ)
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16,
     1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP25=99,NP29=63,
     2 NP38=125,NP39=30,NP41=200,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      IF (IPR(56) .NE. 0) THEN
        DO 10 I = 1, 3
          TEMP       = RMAT(1, I)
          RMAT(1, I) = RMAT(2, I)
          RMAT(2, I) = RMAT(3, I)
          RMAT(3, I) = TEMP
   10   CONTINUE
      ENDIF
      NAT = IPR(39)
      DO 20 I = 1, 3
        PAR(54 + I) = 1.0E10
        PAR(57 + I) =-1.0E10
   20 CONTINUE
      I = 0
   30 I = I + 1
      IF (I .GT. NAT) GOTO 60
      IATC(I) = 1
      IF (IPR(140) .GT. 0) THEN
        CALL GEN048 (-6, IFG(I), 9, IRESI)
        IF (IRESI .NE. IPR(140)) THEN
          IATC(I) = 0
          GOTO 30
        ENDIF
      ENDIF
      DO 40 K = 1, 3
        V5(K) = XXO(I, K + 3)
   40 CONTINUE
      CALL GEN002 (1, RMAT, V5, V6, XLNG)
      DO 50 K = 1, 3
        PAR(57 + K) = MAX (PAR(57 + K), V6(K))
        PAR(54 + K) = MIN (PAR(54 + K), V6(K))
   50 CONTINUE
      GOTO 30
   60 SX   = (PAR(55) + PAR(58)) * 0.5
      SY   = (PAR(56) + PAR(59)) * 0.5
      SZ   = (PAR(57) + PAR(60)) * 0.5
      PMAX = MAX (PAR(58) - SX, PAR(59) - SY)
      IF (ABS(PMAX) .LT. 0.0001) PMAX = 1.0
      RETURN
      END
      SUBROUTINE PLA103
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118,
     1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NPVD=40000000,
     2 NP22=256,NP23=18000,NP25=99,NP26=6000,NP27=1000,NP28=3024,
     3 NP29=63,NP38=125,NP39=30,NP41=200,NP45=2048,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9),
     1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10),
     2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10),
     3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770)
      COMMON // JNSC(2, NP23),
     1 VOID(NPVD - 5 * NP26 - 9 * NP27 - NP28 - 1560), B(24),
     1 A(NP26, 5), IP(NP27, 9), IO(NP28), CY(36), D(300, 5)
      COMMON /PL103/ NATP, NRCRC, NPOLY
      COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0
      COMMON /CGGT/ IGGT
      CHARACTER IGGT*80
      COMMON /Q/ ICL, IFL(NP17)
      CHARACTER ICL*(NP45), IFL*7
      LOGICAL LOG
    5 IER   = 0
      NAT   = IPR(37)
      NSYM  = IPR(48)
      NRCRC = 0
      NPOLY = 0
      NATP  = 8
      NATPS = 0
      PAR(224) = 1.0
      DO 20 I = 1, 8
        A(I, 1) = I * 10
        DO 10 J = 2, 4
          A(I, J) = 0.0
   10   CONTINUE
   20 CONTINUE
      A(2, 2) = 1.0
      A(3, 3) = 1.0
      A(4, 4) = 1.0
      A(5, 2) = 1.0
      A(5, 3) = 1.0
      A(6, 2) = 1.0
      A(6, 4) = 1.0
      A(7, 3) = 1.0
      A(7, 4) = 1.0
      A(8, 2) = 1.0
      A(8, 3) = 1.0
      A(8, 4) = 1.0
      C73      = MAX (PAR(216) + PAR(217), PAR(220) + PAR(221))
      V2(1)    = ABS (C73 / OR(1, 1))
      V2(2)    = ABS (C73 / (V2(1) * OR(1, 2) - OR(2, 2)))
      V2(3)    = ABS (C73 / (V2(2) * OR(1, 3) + OR(3, 3)))
      IF (IPR(354) .EQ. -1) THEN
        IPR(354) = 0
      ENDIF
      DO 25 I = 1, 5, 2
        J = (I + 1) / 2
        PAR(200 + I) = (1 - (IPR(354) + 1)) * 0.5 - V2(J)
        PAR(201 + I) = (1 + (IPR(354) + 1)) * 0.5 + V2(J)
   25 CONTINUE
C * DEFAULT OMIT OUTSIDE RANGE
      IF (IPR(356) .LT. 0) THEN
        DO 30 I = 1, 5, 2
          PAR(206 + I) = -0.01
          PAR(207 + I) =  1.01
   30   CONTINUE
        IPR(356) = 0
      ENDIF
      DO 40 I = 1, 6
        IO(I) = IFIX(PAR(200 + I) - SIGN(1E-4, PAR(200 + I)) + 10.0)
   40 CONTINUE
      WRITE (LU6, 99998) (PAR(J), J = 201, 202), (IO(J) -10, J = 1, 2),
     1                   (PAR(J), J = 203, 204), (IO(J) -10, J = 3, 4),
     2                   (PAR(J), J = 205, 206), (IO(J) -10, J = 5, 6)
      DO 110 INAT = 1, NAT
        CALL PLA047 (XLAB(INAT), NQ1, IDUM, IENR, 0, IGBL(55), 0, 0)
        N2 = NATP
        DO 100 J = 1, NSYM
          NATP       = NATP + 1
          A(NATP, 1) = (IENR * 10000 + INAT) * 10
          A(NATP, 5) = REL(IENR) * PAR(213)
          DO 50 L = 1, 3
            XJX(L)     = XXO(INAT, L)
            XJX(L + 3) = 0.0
   50     CONTINUE
          CALL SGSM (LINE, J, XJX, LU7, 3, IERR)
          DO 60 L = 2, 4
            A(NATP, L) = MOD(XJX(L + 5) + 10.0, 1.0)
   60     CONTINUE
          IF (J .GT. 1) THEN
            DO 70 L = N2, NATP - 1
              IF (ABS(A(L, 2) - A(NATP, 2)) .LT. 0.001) THEN
                IF (ABS(A(L, 3) - A(NATP, 3)) .LT. 0.001) THEN
                  IF (ABS(A(L, 4) - A(NATP, 4)) .LT. 0.001) THEN
                    NATP = NATP - 1
                    GOTO 100
                  ENDIF
                ENDIF
              ENDIF
   70       CONTINUE
          ENDIF
          DO 80 L = 2, 4
            K = (L - 1) * 2
            IF (A(NATP, L) .LT. PAR(199 + K) .OR.
     1          A(NATP, L) .GT. PAR(200 + K)) THEN
              A(NATP, 1) = SIGN(A(NATP, 1), -1.0)
              GOTO 100
            ENDIF
   80     CONTINUE
          IF (IPR(356) .EQ. 1) THEN
            DO 90 L = 2, 4
              K = (L + 102) * 2
              IF (A(NATP, L) .LT. PAR(K - 1) .OR.
     1          A(NATP, L) .GT. PAR(K)) THEN
                A(NATP, 1) = FLOAT(IFIX(A(NATP, 1) * 0.1) * 10 + 5)
                GOTO 100
              ENDIF
   90       CONTINUE
          ENDIF
  100   CONTINUE
  110 CONTINUE
      NATPS = NATP
      DO 170 I = 9, NATPS
        CY(1) = ABS(IFIX(A(I, 1) * 0.1) * 10)
        CY(2) = A(I, 2)
        CY(3) = A(I, 3)
        CY(4) = A(I, 4)
        CY(5) = A(I, 5)
        DO 160 J = IO(1), IO(2)
          DO 150 K = IO(3), IO(4)
            DO 140  L = IO(5), IO(6)
              IF (J .NE. 10 .OR. K .NE. 10 .OR. L .NE. 10) THEN
                NATP = NATP + 1
                A(NATP, 1) = CY(1)
                A(NATP, 2) = CY(2) + FLOAT(J) - 10.0
                A(NATP, 3) = CY(3) + FLOAT(K) - 10.0
                A(NATP, 4) = CY(4) + FLOAT(L) - 10.0
                A(NATP, 5) = CY(5)
                DO 120 M = 2, 4
                  M2 = (M - 1) * 2
                  IF (A(NATP, M) .LT. PAR(199 + M2) .OR.
     1                A(NATP, M) .GT. PAR(200 + M2)) THEN
                    NATP = NATP - 1
                    GOTO 140
                  ENDIF
  120           CONTINUE
                IF (IPR(356) .EQ. 1) THEN
                  DO 130 M = 2, 4
                    M2 = (M + 102) * 2
                    IF (A(NATP, M) .LT. PAR(M - 1) .OR.
     1                  A(NATP, M) .GT. PAR(M)) THEN
                      A(NATP, 1) = FLOAT(IFIX(A(NATP, 1) * 0.1)
     1                           * 10 + 5)
                      GOTO 140
                    ENDIF
  130             CONTINUE
                ENDIF
              ENDIF
  140       CONTINUE
  150     CONTINUE
  160   CONTINUE
  170 CONTINUE
      CALL GEN021 (RMAT, 1)
      DO 180 I = 1, 3
        X =  - GL(27 + I) / GL(5)
        CALL GEN051 (0, RMAT, X, I)
  180 CONTINUE
      DO 190 I = 1, NATP
        V3(1) = A(I, 2)
        V3(2) = A(I, 3)
        V3(3) = A(I, 4)
        CALL GEN002 (1, OR, V3, V2, DUM)
        CALL GEN002 (-1, RMAT, V2, V3, DUM)
        A(I, 2) = V3(1)
        A(I, 3) = V3(2)
        A(I, 4) = V3(3)
  190 CONTINUE
      DO 200 I = 9, NATP
        IF (A(I, 1) .GT. 0) THEN
          IF (MOD(IFIX(A(I, 1)), 10) .EQ. 0) THEN
            II = INT(A(I, 1) / 100000)
            IF (IATPR(II) .EQ. 5 .OR. IATPR(II) .EQ. 6) THEN
              NRCRC     = NRCRC + 1
              IO(NRCRC) = I
            ENDIF
          ENDIF
        ENDIF
  200 CONTINUE
      IF (IABS(NRCRC) .GT. 0) THEN
        DO 220 I = 1, NRCRC - 1
          K   = 0
          CY1 = A(IO(I), 4)
          DO 210 J = I + 1, NRCRC
            IF (CY1 .LE. A(IO(J), 4)) THEN
              CY1 = A(IO(J), 4)
              K   = J
            ENDIF
  210     CONTINUE
          IF (K .GT. 0) THEN
            CALL GEN014 (IO(I), IO(K))
          ENDIF
  220   CONTINUE
      ENDIF
      PAR(222) = MAX (PAR(216) + PAR(217), PAR(220) + PAR(221))
      DO 390 I0 = 9, NATP
        IF (A(I0, 1) .GT. 0.0) THEN
          LOG  = I0 .GT. NATPS
          IF (LOG .AND. IPR(354) .EQ. 0) GOTO 400
          LOG = IFIX(A(I0, 1) * 0.1) .EQ.
     1          IFIX(A(I0 - 1, 1) * 0.1) .OR. LOG
          L   = 0
          DO 240 J = 9, NATP
            IF (A(J, 1) .GT. 0.0) THEN
              IF (J .NE. I0) THEN
                D(L + 1, 1) = FLOAT(J)
                DEL         = 0
                DO 230 K = 2, 4
                  D(L + 1, K) = A(I0, K) - A(J, K)
                  DEL = DEL + D(L + 1, K)**2
  230           CONTINUE
                D(L + 1, 5) = SQRT(DEL)
                IF (D(L + 1, 5) .LE. PAR(222)) L = L + 1
              ENDIF
            ENDIF
  240     CONTINUE
          DO 270 I1 = 1, L - 1
            K1  = 0
            B24 = D(I1, 5)
            DO 250 J1 = I1 + 1, L
              IF (B24 .GE. D(J1, 5)) THEN
                B24 = D(J1, 5)
                K1  = J1
              ENDIF
  250       CONTINUE
            IF (K1 .GT. 0) THEN
              DO 260 J1 = 1, 5
                CALL GEN018 (D(I1, J1), D(K1, J1))
  260         CONTINUE
            ENDIF
  270     CONTINUE
          II = L
          DO 290 J = 1, L - 1
            IF (D(J, 5) .LE. PAR(222)) THEN
              DO 280 K = J + 1, L
                IF (D(K, 5) .GT. PAR(222)) GOTO 290
                II       = II + 1
                IF (II .GT. 300) STOP 'II'
                D(II, 1) = D(J, 1)
                D(II, 2) = D(K, 1)
                IF (ABS(D(J, 5) * D(K, 5)) .GE. 1E-8) THEN
                  ARCO = (D(J, 2) * D(K, 2) + D(J, 3) * D(K, 3)
     1                 + D(J, 4) * D(K, 4)) / (D(J, 5) * D(K, 5))
                ELSE
                  ARCO = 1.0
                ENDIF
                IF (ABS(ARCO) .GT. 1.0) ARCO = SIGN(1.0, ARCO)
                D(II, 3) = ACOS(ARCO) * GL(5)
                D(II, 4) = D(J, 5)
                D(II, 5) = D(K, 5)
  280         CONTINUE
            ENDIF
  290     CONTINUE
          DO 380 IG0 = 1, 2
            IG1 = 9 - IG0 * 2
            DO 300 J = 1, 4
              IF (IG0 .EQ. 1) THEN
                CY(J) = PAR(217 + J)
              ELSE
                CY(J) = PAR(213 + J)
              ENDIF
  300       CONTINUE
            CY(5)  = 1.414 * (PAR(220) + PAR(221))
            IF (NPOLY .GE. NP27) THEN
              WRITE (LU7, 99996) NP27
              IER = 1
              GOTO 410
            ENDIF
            IG4              = 1
            IP(NPOLY + 1, 1) = I0
            IP(NPOLY + 1, 6) = 0
            IP(NPOLY + 1, 7) = 0
            X1               = 0.0
            X2               = A(I0, 2)
            X3               = A(I0, 3)
            DO 330 II0 = L + 1, II
              IF (ABS(D(II0, 3) - CY(1)) .LE. CY(2)) THEN
                IF (ABS(D(II0, 4) - CY(3)) .LE. CY(4)) THEN
                  IF (ABS(D(II0, 5) - CY(3)) .LE. CY(4)) THEN
                    DO 320 M = 1, 2
                      IF (IG4 .GT. 1) THEN
                        DO 310 K = 2, IG4
                          IF (NINT(D(II0, M)) .EQ. IP(NPOLY + 1, K))
     1                      GOTO 320
  310                   CONTINUE
                      ENDIF
                      IG4 = IG4 + 1
                      IP(NPOLY + 1, IG4) = NINT(D(II0, M))
                      X4 = A(IP(NPOLY + 1, IG4), 2)
                      X5 = A(IP(NPOLY + 1, IG4), 3)
                      X1 = MAX (X1, SQRT((X2 - X4)**2
     1                   + (X3 - X5)**2))
  320               CONTINUE
                  ENDIF
                ENDIF
              ENDIF
  330       CONTINUE
            IP(NPOLY + 1, 8) = IFIX(X1 * 1000)
            IP(NPOLY + 1, 9) = IG1
            IF (IG4 .EQ. IG1) THEN
              NPOLY = NPOLY + 1
              IF (IG1 .EQ. 7) THEN
                DO 370 I = 2, 3
                  DO 340 JJ = 1, 3
                    XPV(JJ) = A(IP(NPOLY, I), JJ + 1)
  340             CONTINUE
                  CY(6) = 0.0
                  DO 360 J = I + 1, 9 - I
                    DO 350 JJ = 1, 3
                      XPV(JJ + 3)  = A(IP(NPOLY, J), JJ + 1)
  350               CONTINUE
                    CY(5) = SQRT((XPV(4) - XPV(1))**2
     1                    + (XPV(5) - XPV(2))**2 + (XPV(6) - XPV(3))**2)
                    IF (CY(5) .GT. CY(6)) THEN
                      CY(6) = CY(5)
                      IG4   = J
                    ENDIF
  360             CONTINUE
                  CALL GEN014 (IP(NPOLY, IG4), IP(NPOLY, 9 - I))
  370           CONTINUE
              ENDIF
              GOTO 390
            ENDIF
  380     CONTINUE
        ENDIF
  390 CONTINUE
  400 CALL PLA104 (IER)
  410 IF (IER .NE. 0) WRITE (LU7, 99999) IER
      CALL PLA013 (0, 1)
      CALL GEN072 (IGGT, IFL, FN, KL, KN, 0, LU6, 1, 1, 80, 7, NP17)
      IF (IFL(1)(1:4) .EQ. 'EXIT') THEN
        GOTO 420
      ELSE IF (IFL(1)(1:3) .EQ. 'END') THEN
        IGGT     = ' '
        IGBL(23) = 10
        GOTO 420
      ELSE IF (IFL(1)(1:2) .EQ. 'XR') THEN
        CALL PLA226 (-1, - FN(1) / GL(5))
        GOTO 5
      ELSE IF (IFL(1)(1:2) .EQ. 'YR') THEN
        CALL PLA226 (-2, - FN(1) / GL(5))
        GOTO 5
      ELSE IF (IFL(1)(1:2) .EQ. 'ZR') THEN
        CALL PLA226 (-3, - FN(1) / GL(5))
        GOTO 5
      ENDIF
      IF (LRET .EQ. 1) THEN
        GOTO 420
      ELSE IF (LRET .EQ. 3) THEN
        GOTO 5
      ENDIF
  420 CALL GGIP (0.0, 0.0, 0.0, -1)
      RETURN
99999 FORMAT (':: Error Nr.', I3, ' in POLY')
99998 FORMAT (///, 'Range for Generating Atoms is X:',
     1 F8.4, ' TO', F7.4, ' (', I3, ' -', I3, ')',/, 30X, 'Y:',
     2 F8.4, ' TO', F7.4, ' (', I3, ' -', I3, ')' /, 30X, 'Z:',
     3 F8.4, ' TO', F7.4, ' (', I3, ' -', I3, ')')
99996 FORMAT ('Maximum Number of Polyhedra', I5, ' has been Exceeded')
      END
      SUBROUTINE PLA104 (IER)
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16,
     1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NPVD=40000000,
     2 NP23=18000,NP25=99,NP26=6000,NP27=1000,NP28=3024,NP29=63,
     3 NP38=125, NP39=30,NP41=200,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON // JNSC(2, NP23),
     1 VOID(NPVD - 5 * NP26 - 9 * NP27 - NP28 - 1560), B(24),
     2 A(NP26, 5), IP(NP27, 9), IO(NP28), IG1(100), IG2(100),
     3 R(400, 3), IF1(6), NF(68), D(62)
      COMMON /ALL/ NN(12, 3), LO(12, 2), IE(12, 2)
      COMMON /PL103/ NATP, NRCRC, NPOLY
      V1(1) =  1E5
      V1(2) = -1E5
      V1(3) =  1E5
      V1(4) = -1E5
      DO 10 I = 1, NATP
        IF (IPR(355) .GT. 0) THEN
          B14 = 60.0 / (60.0 - A(I, 4))
          A(I, 2) = A(I, 2) * B14
          A(I, 3) = A(I, 3) * B14
        ENDIF
        IF (A(I, 1) .GT. 0) THEN
          V1(1) = MIN (V1(1), A(I, 2))
          V1(2) = MAX (V1(2), A(I, 2))
          V1(3) = MIN (V1(3), A(I, 3))
          V1(4) = MAX (V1(4), A(I, 3))
        ENDIF
   10 CONTINUE
      B14 = ABS(V1(1) - V1(2))
      B15 = ABS(V1(3) - V1(4))
      PAR(224) = MIN (PAR(38) * PAR(50) / B14, PAR(38) / B15)
      B14 = (V1(1) + V1(2)) / 2
      B15 = (V1(3) + V1(4)) / 2
      DO 20 I = 1, NATP
        A(I, 2) = A(I, 2) - B14
        A(I, 3) = A(I, 3) - B15
   20 CONTINUE
      XGGIP = PAR(38) * PAR(50)
      YGGIP = PAR(38)
      CALL GGIP (XGGIP, YGGIP, 0.0, 1)
      CALL GGIP (0.0, 1.0, 0.0, 0)
      CALL PLA117 (XGGIP, YGGIP, 0)
      XGGIP = XGGIP / 2.0
      YGGIP = YGGIP / 2.0
      CALL GGIP (XGGIP, YGGIP, 0.0, -3)
      DD = PAR(224) * 0.9
      CALL GGIP (0.0, DD, 0.0, 7)
      NF(1) = 0
      NF(2) = 0
      D(23) = 0.0
      D(24) = 0.0
      C1    = 0.012 / DD
      IF (IPR(357) .GT. 0) THEN
        NF(10) = 1
        DO 30 I = 1, 12
          V1(1) = A(LO(I, 1), 2)
          V1(2) = A(LO(I, 1), 3)
          V1(3) = A(LO(I, 2), 2)
          V1(4) = A(LO(I, 2), 3)
          CALL GGIP (V1(1), V1(2), 0.0, 3)
          CALL GGIP (V1(3), V1(4), 0.0, 2)
          D(23) = V1(3)
          D(24) = V1(4)
   30   CONTINUE
      ENDIF
   40 IF (NF(1) .LT. NPOLY) THEN
        IF (NF(2) .GE. NRCRC .OR. (NF(2) .LT. NRCRC .AND.
     1     A(IP(NF(1) + 1, 1), 4) .GT. A(IO(NF(2) + 1), 4))) THEN
          NF(1) = NF(1) + 1
          IF (IPR(353) .EQ. 0) GOTO 40
          DO 50 I = 1, 11
            IE(I, 1) = -1
            IE(I, 2) = -1
   50     CONTINUE
          CALL GEN097 (IF1, 1, 6, -1)
          IF (IP(NF(1), 7) .LE. 0) THEN
            NF(12) = 9
            NF(13) = 12
          ELSE
            NF(12) = 1
            NF(13) = 8
          ENDIF
          K = 0
          L = 0
          DO 60 I = 1, 3
            B(I) = A(IP(NF(1), 1), I + 1)
   60     CONTINUE
          DO 100 I = NF(12), NF(13)
            DO 65 J = 1, 3
              NF(6 + J) = IP(NF(1), NN(I, J))
   65       CONTINUE
            DO 70 J = 1, 3
              B(4  + J) = A(NF(8), 1 + J) - A(NF(7), 1 + J)
              B(7  + J) = A(NF(9), 1 + J) - A(NF(7), 1 + J)
              B(13 + J) = B(J) - A(NF(7), 1 + J)
   70       CONTINUE
            CALL GEN008 (B(5), B(8), B(11), 0)
            IF (GEN009 (B(11), B(14)) .GE. 0.0) B(13) = - B(13)
            IF (B(13) .GT. 0) THEN
              K = K + 1
              IF1(K) = I
              DO 90 J0 = 1, 3
                J1 = 1 + J0 / 3
                J2 = 2 + (J0 + 1) / 3
                IF (L .GT. J0 - 1) THEN
                  DO 80 J = 1, L
                    IF (NN(I, J1) .EQ. IE(J, 1) .AND.
     1                  NN(I, J2) .EQ. IE(J, 2)) GOTO 90
                    IF (NN(I, J2) .EQ. IE(J, 1) .AND.
     1                  NN(I, J1) .EQ. IE(J, 2)) GOTO 90
   80             CONTINUE
                ENDIF
                L = L + 1
                IE(L, 1) = NN(I, J1)
                IE(L, 2) = NN(I, J2)
   90         CONTINUE
            ENDIF
  100     CONTINUE
          DO 120 J = 1, L
            DO 110 K = 1, 2
              IE(J, K) = IP(NF(1), IE(J, K))
  110       CONTINUE
  120     CONTINUE
          NF(4) = 0
          NF(5) = 0
          IF (NF(1) .LT. 1) THEN
            GOTO 40
          ELSE IF (NF(1) .GT. 1) THEN
            B(6) = FLOAT(IP(NF(1), 8)) * 1E-3
            DO 130 I = 1, NF(1) - 1
              B(7) = FLOAT(IP(I, 8)) * 1E-3
              B(4) = A(IP(I, 1), 2)
              B(5) = A(IP(I, 1), 3)
              B(8) = SQRT((B(1) - B(4))**2 + (B(2) - B(5))**2)
              IF (B(8) - B(6) - B(7) .LT. 0.0) THEN
                NF(4)      = NF(4) + 1
                IG1(NF(4)) = I
              ENDIF
  130       CONTINUE
          ENDIF
          IF (NF(2) .GT. 0) THEN
            DO 140 I = 1, NF(2)
              B(4) = A(IO(I), 2)
              B(5) = A(IO(I), 3)
              B(7) = A(IO(I), 5)
              B(8) = SQRT((B(1) - B(4))**2 + (B(2) - B(5))**2)
              IF (B(8) - B(6) - B(7) .LT. 0) THEN
                NF(5)      = NF(5) + 1
                IG2(NF(5)) = I
              ENDIF
  140       CONTINUE
          ENDIF
          K = 17
          DO 150 I = 1, 10
            IF (IE(I + 1, 1) .LE. 0) GOTO 160
  150     CONTINUE
          I = 11
  160     NF(10) = 3
          DO 180 J = 1, I
            B(9)  = A(IE(J, 1), 2)
            B(10) = A(IE(J, 1), 3)
            B(11) = A(IE(J, 2), 2)
            B(12) = A(IE(J, 2), 3)
            D(13) = B(1)
            D(14) = B(2)
            D(15) = 0.5 * (B(9) + B(11))
            D(16) = 0.5 * (B(10) + B(12))
            D(21) = (D(13) - D(15))**2 + (D(14) - D(16))**2
            DO 170 L = 1, I
              IF (J .NE. L) THEN
                D(17) = A(IE(L, 1), 2)
                D(18) = A(IE(L, 1), 3)
                D(19) = A(IE(L, 2), 2)
                D(20) = A(IE(L, 2), 3)
                D(9)  = D(15) - D(13)
                D(10) = D(16) - D(14)
                D(11) = D(19) - D(17)
                D(12) = D(20) - D(18)
                DEN   = D(9) * D(12) - D(10) * D(11)
                IF (ABS(DEN) .LE. 1E-8) THEN
                  D(5) = 10.0
                ELSE
                  D(5) = (D(10) * (D(17) - D(13))
     1                  - D(9)  * (D(18) - D(14))) / DEN
                  D(6) = (D(12) * (D(17) - D(13))
     1                   -D(11) * (D(18) - D(14))) / DEN
                  D(1) = D(17) + D(5) * D(11)
                  D(2) = D(18) + D(5) * D(12)
                ENDIF
                IF (ABS(D(5) - 0.5) .LE. 0.5) THEN
                  IF (D(6) .GE. 0.0) THEN
                    D(22) = (D(13) - D(1))**2 + (D(14) - D(2))**2
                    IF (D(22) .GT. D(21)) GOTO 175
                  ENDIF
                ENDIF
              ENDIF
  170       CONTINUE
            K     = K + 1
            NF(K) = J
  175       CALL PLA105
  180     CONTINUE
          IF (IPR(358) .GT. 0) THEN
            NF(10) = 1
            DO 220 I = 1, 6
              IF (IF1(I) .LE. 0) GOTO 230
              NF(7) = NN(IF1(I), 1)
              NF(8) = NN(IF1(I), 2)
              NF(9) = NN(IF1(I), 3)
              DO 190 JX = 8, 9
                IF (A(IP(NF(1), NF(7)), 4)
     1            - A(IP(NF(1), NF(JX)), 4) .LE. 0) THEN
                  CALL GEN014 (NF(7), NF(JX))
                ENDIF
  190         CONTINUE
              DO 210 J = 1, 9
                DO 200 J0 = 9, 12
                  J1    = MOD(J0 + 1, 2) + 2
                  J2    = 8 + (J0 - 8) / 3
                  B(J0) = ((10 - J) * A(IP(NF(1), NF(7)),  J1)
     1                         + J  * A(IP(NF(1), NF(J2)), J1)) / 10.0
  200           CONTINUE
                IF (IPR(346) .NE. 0) THEN
                  IF (IP(NF(1), 9) .EQ. 5) THEN
                    CALL GGIP (0.0, 2.0, 0.0, 0)
                  ELSE
                    CALL GGIP (0.0, 3.0, 0.0, 0)
                  ENDIF
                ENDIF
                CALL PLA105
                CALL GGIP (0.0, 1.0, 0.0, 0)
  210         CONTINUE
  220       CONTINUE
          ENDIF
  230     L            = 3
          IP(NF(1), 2) = IE(NF(18), 1)
          IP(NF(1), 3) = IE(NF(18), 2)
  240     DO 250 I = 19, K
            IF (NF(I) .GT. 0) THEN
              IF (IE(NF(I), 1) .EQ. IP(NF(1), L)) THEN
                L = L + 1
                IP(NF(1), L) = IE(NF(I), 2)
              ELSE
                IF (IE(NF(I), 2) .NE. IP(NF(1), L)) GOTO 250
                L = L + 1
                IP(NF(1), L) = IE(NF(I), 1)
              ENDIF
              NF(I) = -1
              IF (L .GT. 7) THEN
                IER = 2
                GOTO 440
              ELSE IF (L .LT. 7) THEN
                GOTO 240
              ELSE
                IF (IP(NF(1), 2) .EQ. IP(NF(1), L)) IP(NF(1), L) = -1
                GOTO 430
              ENDIF
            ENDIF
  250     CONTINUE
          IP(NF(1), L) = -1
          GOTO 430
        ENDIF
      ENDIF
      IF (NF(2) .LT. NRCRC) THEN
        NF(2) = NF(2) + 1
        B(1)  = A(IO(NF(2)), 2)
        B(2)  = A(IO(NF(2)), 3)
        B(3)  = A(IO(NF(2)), 5)
        NF(4) = 0
        IF (IPR(353) .NE. 0 .AND. NF(1) .GT. 0) THEN
          DO 260 I = 1, NF(1)
            B(8)  = FLOAT(IP(I, 8)) * 0.001
            IF (SQRT((B(1) - A(IP(I, 1), 2))**2
     1        + (B(2) - A(IP(I, 1), 3))**2) .LT. B(3) + B(8)) THEN
              NF(4)      = NF(4) + 1
              IG1(NF(4)) = I
            ENDIF
  260     CONTINUE
        ENDIF
        NF(5) = 0
        IF (NF(2) .GT. 1) THEN
          DO 270 I = 1, NF(2) - 1
            B(8)  = A(IO(I), 5)
            B(5)  = A(IO(I), 2)
            B(6)  = A(IO(I), 3)
            D(40) = SQRT((B(1) - B(5))**2 + (B(2) - B(6))**2)
            IF (D(40) - B(3) - B(8) .LT. 0.0) THEN
              IF (D(40) .LE. 1E-3) THEN
                IF (D(40) + ABS(B(3) - B(8)) .LE. 1E-3) THEN
                  GOTO 430
                ELSE
                  GOTO 270
                ENDIF
              ENDIF
              NF(5)      = NF(5) + 1
              IG2(NF(5)) = I
            ENDIF
  270     CONTINUE
        ENDIF
        NF(15)  = 2
        R(1, 1) = B(1)
        R(1, 2) = B(2) + B(3)
        R(1, 3) = 0.0
        R(2, 1) = R(1, 1)
        R(2, 2) = R(1, 2)
        R(2, 3) = 360.0
        IF (IPR(353) .NE. 0 .AND. NF(4) .GT. 0) THEN
          B(19) = B(1)
          B(20) = B(2)
          DO 290 I = 1, NF(4)
            NF(16) = IP(IG1(I), 9) - 1
            DO 280 J = 2, NF(16) + 1
              IF (IP(IG1(I), J) .LT. 1) GOTO 290
              IF (IP(IG1(I), J + 1) .LE. 0) NF(16) = J - 1
              B(9)   = A(IP(IG1(I), J), 2)
              B(10)  = A(IP(IG1(I), J), 3)
              NF(13) = J - 1
              NF(14) = MOD(NF(13), NF(16)) + 2
              B(11)  = A(IP(IG1(I), NF(14)), 2)
              B(12)  = A(IP(IG1(I), NF(14)), 3)
              D(5)   = -1.0
              D(6)   = -1.0
              D(7)   = B(9)  - B(19)
              D(8)   = B(10) - B(20)
              D(9)   = B(11) - B(9)
              D(10)  = B(12) - B(10)
              D(11)  = D(9)**2 + D(10)**2
              D(12)  = D(7) * D(9) + D(8) * D(10)
              D(13)  = D(12)**2
     1               - D(11) * (D(7)**2 + D(8)**2 - B(3)**2)
              IF (D(13) .GE. 0) THEN
                D(14) = - D(12) / D(11)
                D(13) = SQRT(D(13)) / D(11)
                D(5)  = D(14) + D(13)
                D(1)  = B(9) + D(5) * D(9)
                D(2)  = B(10) + D(5) * D(10)
                IF (D(13) .GT. 1E-4) THEN
                  D(6) = D(14) - D(13)
                  D(3) = B(9) + D(6) * D(9)
                  D(4) = B(10) + D(6) * D(10)
                ENDIF
              ENDIF
              IF (ABS(D(5) - 0.5) .LE. 0.5) THEN
                NF(15)       = NF(15) + 1
                R(NF(15), 1) = D(1)
                R(NF(15), 2) = D(2)
                D(25)        = D(1) - B(1)
                D(26)        = D(2) - B(2)
                R(NF(15), 3) = ACOS((D(26) /
     1                         SQRT(D(25)**2 + D(26)**2))) * GL(5)
                IF (D(25) .LE. 0.0) R(NF(15), 3) = 360.0 - R(NF(15), 3)
              ENDIF
              IF (ABS(D(6) - 0.5) .LE. 0.5) THEN
                NF(15)       = NF(15) + 1
                R(NF(15), 1) = D(3)
                R(NF(15), 2) = D(4)
                D(25)        = D(3) - B(1)
                D(26)        = D(4) - B(2)
                R(NF(15), 3) = ACOS((D(26) /
     1                         SQRT(D(25)**2 + D(26)**2))) * GL(5)
                IF (D(25) .LE. 0.0) R(NF(15), 3) = 360.0 - R(NF(15), 3)
              ENDIF
  280       CONTINUE
  290     CONTINUE
        ENDIF
        IF (NF(5) .GT. 0) THEN
          DO 300 I = 1, NF(5)
            B(5) = A(IO(IG2(I)), 2)
            B(6) = A(IO(IG2(I)), 3)
            B(8) = A(IO(IG2(I)), 5)
            D(9)   = B(5) - B(1)
            D(10)  = B(6) - B(2)
            D(11)  = D(9)**2 + D(10)**2
            D(12)  = B(1) * D(9) + B(2) * D(10)
            D(13)  = (B(5)**2 + B(6)**2 - B(1)**2
     1             - B(2)**2 + B(3)**2 - B(8)**2) / 2.0
            D(14)  = (D(13) - D(12)) / D(11)
            D(15)  = SQRT(B(3)**2 * D(11) - (D(13) - D(12))**2) / D(11)
            D(1)   = B(1) + D(14) * D(9)  - D(15) * D(10)
            D(2)   = B(2) + D(14) * D(10) + D(15) * D(9)
            D(3)   = B(1) + D(14) * D(9)  + D(15) * D(10)
            D(4)   = B(2) + D(14) * D(10) - D(15) * D(9)
            NF(15) = NF(15) + 1
            R(NF(15), 1) = D(1)
            R(NF(15), 2) = D(2)
            D(25) = D(1) - B(1)
            D(26) = D(2) - B(2)
            R(NF(15), 3) = ACOS((D(26) /
     1                     SQRT(D(25)**2 + D(26)**2))) * GL(5)
            IF (D(25) .LE. 0.0) R(NF(15), 3) = 360.0 - R(NF(15), 3)
            NF(15) = NF(15) + 1
            R(NF(15), 1) = D(3)
            R(NF(15), 2) = D(4)
            D(25) = D(3) - B(1)
            D(26) = D(4) - B(2)
            R(NF(15), 3) = ACOS((D(26) /
     1                     SQRT(D(25)**2 + D(26)**2))) * GL(5)
            IF (D(25) .LE. 0.0) R(NF(15),3) = 360.0 - R(NF(15),3)
  300     CONTINUE
        ENDIF
        DO 330 I2 = 1, NF(15) - 1
          K2 = 0
          B(13) = R(I2, 3)
          DO 310 J2 = I2 + 1, NF(15)
            IF (B(13) .GE. R(J2, 3)) THEN
              B(13) = R(J2, 3)
              K2    = J2
            ENDIF
  310     CONTINUE
          IF (K2 .GT. 0) THEN
            DO 320 J2 = 1, 3
              CALL GEN018 (R(I2, J2), R(K2, J2))
  320       CONTINUE
          ENDIF
  330   CONTINUE
        IF (IPR(346) .NE. 0) CALL GGIP (0.0, 5.0, 0.0, 0)
        DO 420 I = 2, NF(15)
          B(11) = R(I, 3) - R(I - 1, 3)
          B(12) = R(I, 3) - B(11) * 0.5
          B(23) = B(3) * SIN(B(12) / GL(5)) + B(1)
          B(24) = B(3) * COS(B(12) / GL(5)) + B(2)
          IF (IPR(353) .NE. 0) THEN
            IF (NF(4) .GT. 0) THEN
              DO 390 J = 1, NF(4)
                NF(3) = IG1(J)
                DO 340 I0 = 3, 6
                  IF (IP(NF(3), I0 + 2) .LE. 0) GOTO 350
  340           CONTINUE
                I0 = 6
  350           K0 = I0 + MOD(I0, 2) - 1
                DO 370 J0 = 1, K0, 2
                  NF(12) = MOD(J0, I0) + 2
                  NF(13) = MOD(J0 + 1, I0) + 2
                  NF(14) = MOD(J0 - 1, I0) + 2
                  DO 360 J1 = 13, 16
                    J2 = MOD(J1 + 1, 2) + 2
                    J3 = 13 + (J1 - 12) / 3
                    B(J1) = A(IP(NF(3), NF(J3)), J2)
     1                    - A(IP(NF(3), NF(12)), J2)
  360             CONTINUE
                  D(11) = B(23) - A(IP(NF(3), NF(12)), 2)
                  D(12) = B(24) - A(IP(NF(3), NF(12)), 3)
                  D(5)  = (D(11) * B(14) - D(12) * B(13)) /
     1                    (B(15) * B(14) - B(16) * B(13))
                  D(6)  = (D(11) * B(16) - D(12) * B(15)) /
     1                    (B(13) * B(16) - B(14) * B(15))
                  D(10) = MIN (D(5), D(6))
                  IF (D(10) .LE. 0.0) GOTO 380
  370           CONTINUE
  380           IF (IFIX(SIGN(1.0, D(10))) .GE. 0) GOTO 420
  390         CONTINUE
            ENDIF
          ENDIF
          IF (NF(5) .GT. 0) THEN
            DO 400 J = 1, NF(5)
              IF (SQRT((B(23) - A(IO(IG2(J)), 2))**2
     1               + (B(24) - A(IO(IG2(J)), 3))**2)
     2      - A(IO(IG2(J)), 5) .LE. 0) GOTO 420
  400       CONTINUE
          ENDIF
          CALL GGIP (R(I - 1, 1), R(I - 1, 2), 0.0, 3)
          NF24 = NINT(B(11) * B(3) / (3 * C1 * GL(5)))
          IF (NF24 .LE. 1) GOTO 420
          D(30) = B(11) / FLOAT(NF24)
          D(31) = R(I - 1, 3)
          DO 410 K = 1, NF24
            D(31) = D(31) + D(30)
            D(32) = B(3) * SIN(D(31) / GL(5)) + B(1)
            D(33) = B(3) * COS(D(31) / GL(5)) + B(2)
            CALL GGIP (D(32), D(33), 0.0, 2)
  410     CONTINUE
  420   CONTINUE
      ENDIF
  430 CALL GGIP (0.0, 1.0, 0.0, 0)
      IF (NF(1) .LT. NPOLY .OR. NF(2) .LT. NRCRC) GOTO 40
  440 RETURN
      END
      SUBROUTINE PLA105
      PARAMETER (NPVD=40000000,NP23=18000,NP26 = 6000,NP27 = 1000,
     4 NP28=3024)
      COMMON // JNSC(2, NP23),
     1 VOID(NPVD - 5 * NP26 - 9 * NP27 - NP28 - 1560), B(24),
     1 A(NP26, 5), IP(NP27, 9), IO(NP28), IG1(100), IG2(100),
     2 R(400, 3), IF1(6), NF(68), D(62)
      R(1, 1) = B(9)
      R(1, 2) = B(10)
      R(1, 3) = 0.0
      R(2, 1) = B(11)
      R(2, 2) = B(12)
      R(2, 3) = SQRT((B(9) - B(11))**2 + (B(10) - B(12))**2)
      NF(15)  = 2
      IF (NF(4) .GT. 0) THEN
        DO 5 I = 9, 12
          D(I + 4) = B(I)
    5   CONTINUE
        DO 30 I = 1, NF(4)
          NF(16) = IP(IG1(I), 9) - 1
          DO 20 J = 2, NF(16) + 1
            IF (IP(IG1(I), J) .LT. 1) GOTO 30
            IF (IP(IG1(I), J + 1) .LE. 0) NF(16) = J - 1
            D(17)  = A(IP(IG1(I), J), 2)
            D(18)  = A(IP(IG1(I), J), 3)
            NF(13) = J - 1
            NF(14) = MOD(NF(13), NF(16)) + 2
            D(19)  = A(IP(IG1(I), NF(14)), 2)
            D(20)  = A(IP(IG1(I), NF(14)), 3)
            D(9)   = D(15) - D(13)
            D(10)  = D(16) - D(14)
            D(11)  = D(19) - D(17)
            D(12)  = D(20) - D(18)
            DEN    = D(9) * D(12) - D(10) * D(11)
            IF (ABS(DEN) .LE. 1E-8) THEN
              D(5) = 10.0
            ELSE
              D(5) = (D(10) * (D(17) - D(13))
     1             -  D(9)  * (D(18) - D(14))) / DEN
              D(6) = (D(12) * (D(17) - D(13))
     1             -  D(11) * (D(18) - D(14))) / DEN
              D(1) =  D(17) + D(5) * D(11)
              D(2) =  D(18) + D(5) * D(12)
            ENDIF
            IF (ABS(D(5) - 0.5) .LE. 0.5) THEN
              IF (ABS(D(6) - 0.5) .LE. 0.5) THEN
                B(8) = SQRT((B(9) - D(1))**2 + (B(10) - D(2))**2)
                IF (B(8) .GT. 1E-3) THEN
                  DO 10 K = 1, NF(15)
                    IF (ABS(B(8) - R(K, 3)) .LE. 1E-5) GOTO 20
   10             CONTINUE
                  NF(15)       = NF(15) + 1
                  R(NF(15), 1) = D(1)
                  R(NF(15), 2) = D(2)
                  R(NF(15), 3) = B(8)
                ENDIF
              ENDIF
            ENDIF
   20     CONTINUE
   30   CONTINUE
      ENDIF
      IF (NF(5) .GT. 0) THEN
        DO 40 I = 1, NF(5)
          B(3)  = A(IO(IG2(I)), 5)
          B(19) = A(IO(IG2(I)), 2)
          B(20) = A(IO(IG2(I)), 3)
          D(5)  = -1.0
          D(6)  = -1.0
          D(7)  = B(9)  - B(19)
          D(8)  = B(10) - B(20)
          D(9)  = B(11) - B(9)
          D(10) = B(12) - B(10)
          D(11) = D(9)**2 + D(10)**2
          D(12) = D(7) * D(9) + D(8) * D(10)
          D(13) = D(12)**2 - D(11) * (D(7)**2 + D(8)**2 - B(3)**2)
          IF (D(13) .GE. 0) THEN
            D(14) = - D(12) / D(11)
            D(13) = SQRT(D(13)) / D(11)
            D(5)  = D(14) + D(13)
            D(1)  = B(9)  + D(5) * D(9)
            D(2)  = B(10) + D(5) * D(10)
            IF (D(13) .GT. 1E-4) THEN
              D(6) = D(14) - D(13)
              D(3) = B(9)  + D(6) * D(9)
              D(4) = B(10) + D(6) * D(10)
            ENDIF
          ENDIF
          IF (ABS(D(5) - 0.5) .LE. 0.5) THEN
            NF(15)       = NF(15) + 1
            R(NF(15), 1) = D(1)
            R(NF(15), 2) = D(2)
            R(NF(15), 3) = SQRT((B(9) - D(1))**2 + (B(10) - D(2))**2)
          ENDIF
          IF (ABS(D(6) - 0.5) .LE. 0.5) THEN
            NF(15)       = NF(15) + 1
            R(NF(15), 1) = D(3)
            R(NF(15), 2) = D(4)
            R(NF(15), 3) = SQRT((B(9) - D(3))**2 + (B(10) - D(4))**2)
          ENDIF
   40   CONTINUE
        IF (NF(15) .LE. 0) GOTO 80
      ENDIF
      DO 70 I2 = 1, NF(15) - 1
        K2 = 0
        B(13) = R(I2, 3)
        DO 50 J2 = I2 + 1, NF(15)
          IF (B(13) .GE. R(J2, 3)) THEN
            B(13) = R(J2, 3)
            K2    = J2
          ENDIF
   50   CONTINUE
        IF (K2 .GT. 0) THEN
          DO 60 J2 = 1, 3
            CALL GEN018 (R(I2, J2), R(K2, J2))
   60     CONTINUE
        ENDIF
   70 CONTINUE
   80 DO 160 I = 1, NF(15) - 1
        B(9)  = R(I, 1)
        B(10) = R(I, 2)
        B(11) = R(I + 1, 1)
        B(12) = R(I + 1, 2)
        B(23) = (B(9)  + B(11)) * 0.5
        B(24) = (B(10) + B(12)) * 0.5
        IF (NF(1) .NE. 1 .AND. NF(4) .NE. 0) THEN
          DO 140 J = 1, NF(4)
            NF(3) = IG1(J)
            DO 90 I0 = 3, 6
              IF (IP(NF(3), I0 + 2) .LE. 0) GOTO 100
   90       CONTINUE
            I0 = 6
  100       K0 = I0 + MOD(I0, 2) - 1
            DO 120 J0 = 1, K0, 2
              NF(12) = MOD(J0, I0) + 2
              NF(13) = MOD(J0 + 1, I0) + 2
              NF(14) = MOD(J0 - 1, I0) + 2
              DO 110 J1 = 13, 16
                J2 = MOD(J1 + 1, 2) + 2
                J3 = 13 + (J1 - 12) / 3
                B(J1) = A(IP(NF(3), NF(J3)), J2)
     1                - A(IP(NF(3), NF(12)), J2)
  110         CONTINUE
              D(11)  = B(23) - A(IP(NF(3), NF(12)), 2)
              D(12)  = B(24) - A(IP(NF(3), NF(12)), 3)
              D(5)   = (D(11) * B(14) - D(12) * B(13)) /
     1                 (B(15) * B(14) - B(16) * B(13))
              D(6)   = (D(11) * B(16) - D(12) * B(15)) /
     1                 (B(13) * B(16) - B(14) * B(15))
              D(10)  = MIN (D(5), D(6))
              IF (D(10) .LE. 0.0) GOTO 130
  120       CONTINUE
  130       IF (IFIX(SIGN(1.0, D(10))) .GE. 0) GOTO 160
  140     CONTINUE
        ENDIF
        IF (NF(2) .NE. 0 .AND. NF(5) .NE. 0) THEN
          DO 150 J = 1, NF(5)
            B(8)  = A(IO(IG2(J)), 5)
            B(19) = A(IO(IG2(J)), 2)
            B(20) = A(IO(IG2(J)), 3)
            IF (SQRT((B(23) - B(19))**2 + (B(24) - B(20))**2)
     1        .LE. B(8)) GOTO 160
  150     CONTINUE
        ENDIF
        IF ((D(23) - B(9))**2 + (D(24) - B(10))**2 .GT. 1E-4) THEN
          D(23) = B(9)
          D(24) = B(10)
          CALL GGIP (D(23), D(24), 0.0, 3)
        ENDIF
        IF (NF(10) .LE. 1) THEN
          CALL GGIP (B(11), B(12), 0.0, 2)
        ELSE
          D(10) = D(23) - B(12)
          D(11) = B(11) - D(24)
          D(12) = 0.012 / SQRT(D(10)**2 + D(11)**2)
          D(10) = D(10) * D(12)
          D(11) = D(11) * D(12)
          CALL GGIP (B(11), B(12), 0.0, 2)
          CALL GGIP (B(11) + D(10), B(12) + D(11), 0.0, 2)
          CALL GGIP (D(23) + D(10), D(24) + D(11), 0.0, 2)
          CALL GGIP (D(23) - D(10), D(24) - D(11), 0.0, 2)
          CALL GGIP (B(11) - D(10), B(12) - D(11), 0.0, 2)
        ENDIF
        D(23) = B(11)
        D(24) = B(12)
  160 CONTINUE
      RETURN
      END
      SUBROUTINE PLA106
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118,
     1 NP10=16,NP11=128,NP12=600,NP13=500,NP15=20,NP17=99,NP19=31,
     2 NPVD=40000000,NP22=256,NP23=18000,NP25=99,NP29=63,NP38=125,
     3 NP39=30,NP41=200,NP45=2048,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /Q/ ICL, IFL(NP17)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0
      COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9),
     1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10),
     2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10),
     3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770)
      COMMON // JNSC(2, NP23), VOID(NPVD)
      COMMON /CGG11/ BCD, SBCD
      CHARACTER BCD*132, SBCD*132
      COMMON /CGGT/ IGGT
      CHARACTER IGGT*80
      COMMON /GGT/  MEDIUM
      DIMENSION TMAT(3, 3)
      COMMON /CTRLC/ CC
      LOGICAL CC
      DIMENSION DETER(2), QA(3, 3, 2), QC(3, 3, 2), V12(3, 2), YMIN(2),
     1 YMAX(2), QCC(3, 3), QD(3, 3), B(3, 3), S(3, 3), Y1(2), Y2(2),
     2 W(4, 2), FL(4, 4), QUA(3, 4), AAREV(3, 3)
      DIMENSION PROBA(9), LPOS(8, 2), POSL(6)
      COMMON /FNAME/ KNM(8), KXT, KNM16
      COMMON /NAMES/ NAME(8), EXTENS, PROGNM, FNLU1, FNLU16, RDTYPE
      CHARACTER NAME*80, EXTENS*9, PROGNM*28, FNLU1*80, FNLU16*80,
     1          RDTYPE*7
      DATA LPOS / 2, 2, 2, 5, 1, 1, 1, 5, 3, 6, 4, 4, 4, 6, 3, 3 /
      DATA PROBA /
     1      0.7644, 1.0026, 1.1932, 1.3672, 1.5382, 1.7164, 1.9144,
     2      2.1544, 2.5003/
C*********************************************************************C
C*********************************************************************C
      IWIN = IGBL(25) * IGBL(32)
      NCD   = 0
      NQD   = 0
      NBND  = 0
      IDASH = 0
      ID1   = 0
      DIST  = 0.0
      KKK   = 0
      NPOS  = 0
      PVER  = 0.0
      PHOR  = 0.0
      IPOS  = 0
      NB    = 0
      NP    = 0
   10 NCB      = IPR(131)
      NATOM    = IPR(39)
      NSUP     = IPR(64)
      NASUP    = NATOM + NSUP
      IPR(174) = NASUP + MAX (NASUP, NCB)
      IF (IPR(174) + NP15 .GT. NP1) THEN
        IPR(2) = 22
        GOTO 1340
      ENDIF
      IF (IGBL(23) .NE. 8 .AND.
     1    IGBL(23) .NE. 9 .AND.
     1    IGBL(23) .NE. 22) IGBL(23) = 1
   20 IPR(477) = 0
      K        = 0
      DO 40 I = 1, NASUP
        DO 30 J = 1, 3
          XXO(I, J) = VOID(K + J + 3)
   30   CONTINUE
        K       = K + NP4 + 15
        IATP(I) = I + NP1
        CALL GEN048 (-1, IFG(I), 7, IHAT)
        CALL GEN048 (-1, JFG(I), 12, INH)
        IF (IGBL(59) .NE. 0) THEN
          CALL GEN048 (-7, JFG(I), 1, IPP)
          NPOP = IPPR(IPP + 1, 1)
          IF (NPOP .LT. 1000) THEN
            IF (IGBL(88) .EQ. 0) THEN
              IF (IPPR(IPP + 1, 1) .LT. 500) GOTO 40
            ELSE
              IF (IPPR(IPP + 1, 1) .GT. 500) GOTO 40
            ENDIF
          ENDIF
        ENDIF
        IF (IHAT     .NE. 1 .OR.
     1      INH      .NE. 0 .OR.
     2      IPR(212) .NE. 0) THEN
          IF (IPR(140) .GT. 0) THEN
            CALL GEN048 (-6, IFG(I), 9, IRES)
            IF (IRES .NE. IPR(140)) GOTO 40
          ENDIF
          IPR(477) = IPR(477) + 1
          IATP(I)  = I
        ENDIF
   40 CONTINUE
      IF (IGBL(87) .EQ. 0) IGBL(87) = 1
      CALL GEN021 (RMAT, IGBL(87))
      PAR(389) = 0
      IPR(479) = 1
      IF (IGBL(67) .EQ. 0) THEN
        CALL PLA054 (0)
        DO 50 I = 1, 3
          DUMI       =  DUMV(I, 1)
          DUMV(I, 1) = -DUMV(I, 3)
          DUMV(I, 3) =  DUMI
   50   CONTINUE
        CALL GEN004 (DUMV, RMAT, RMAT)
        IGBL(67) = 1
      ELSE
        DO 60 L = 1, 3
          X = - GL(27 + L) / GL(5)
          LLL = L
          CALL GEN051 (0, RMAT, X, LLL)
   60   CONTINUE
      ENDIF
      NLOOP = 2
   70 IPR(478) = 0
   80 IPR(478) = IPR(478) + 1
      IF (CC) GOTO 1290
      PAR(46) = PROBA(IPR(45))
      IF (IPR(108) .NE. 0) THEN
        OPEN (UNIT = LU65, FILE = NAME(1)(1:KNM(1))//'.rst',
     1                          STATUS = 'UNKNOWN')
        WRITE (LU65, 99996) JID(1:50)
        CALL GEN005 (RMAT, TMAT)
      ENDIF
      IF (IPR(116) .EQ. 1) PAR(389) = PAR(389) -9.0 + 6.0 * IPR(478)
      IF (NLOOP .GE. 1) THEN
        DUMMY = - PAR(389) / GL(5)
        CALL GEN051 (0, RMAT, DUMMY, IPR(479))
      ENDIF
      IF (LRET .NE. 6) PAR(389) = 0.0
      CALL GEN003 (OR, ROR, DET, 0)
      CALL GEN004 (ROR, RMAT, RORO)
      CALL GEN004 (AA, RORO, AAREV)
      CALL GEN005 (RMAT, DUMV)
      CALL GEN096 (DUMV, IROTX, IROTY, IROTZ, IDET, V6, YANK, RORO)
      GL(28)   = IROTX
      GL(29)   = IROTY
      GL(30)   = IROTZ
      IGBL(87) = IDET
        DO 90 I = 1, 3
          VIEWV(I) = RORO(I, 3)
   90   CONTINUE
        CALL GEN007 (AA, VIEWV, VIEWV, -1)
      PAR(37) = PAR(38) * PAR(50)
      CALL GEN074 (PAR, -1.E5, 58, 60)
      CALL GEN074 (PAR,  1.E5, 55, 57)
      IPR(477) = 0
      IREF = IPR(297)
      DO 150 I = 1, NASUP
        IREF = IREF + 21
        DO 110 J = 1, 9
          CON(I, J) = VOID(IREF + J - 21)
  110   CONTINUE
        DO 120 J = 1, 3
          IF (I .GT. NATOM) THEN
            XSD(I, J) = VOID(IREF + J - 12) / 2.0
          ELSE
            XSD(I, J) = VOID(IREF + J - 12)
          ENDIF
  120   CONTINUE
        IF (IATP(I) .LE. NP1) THEN
          DO 130 J = 1, 3
            V1(J) = VOID((I - 1) * (NP4 + 15) + J)
  130     CONTINUE
          CALL GEN002 (-1, AAREV, V1, DXI, XLNG)
          IPR(477)       = IPR(477) + 1
          IATC(IPR(477)) = I
          DATC(IPR(477)) = DXI(3)
          CALL GEN048 (-1, JFG(I), 27, ISKP)
          IF (ISKP .EQ. 0) THEN
            DO 140 J = 1, 3
              PAR(57 + J) = MAX (PAR(57 + J), DXI(J))
              PAR(54 + J) = MIN (PAR(54 + J), DXI(J))
  140       CONTINUE
          ENDIF
        ENDIF
  150 CONTINUE
C * AUTOMATIC SCALE AND POSITION DETERMINATION SECTION
      PAR(45) = (PAR(37) - PAR(40) * 2.0) /
     1          (PAR(58) - PAR(55) + 2.0 * PAR(41))
      PAR(45) = MIN (PAR(45), (PAR(38) - PAR(40) * 2.0) /
     1          (PAR(59) - PAR(56) + 2.0 * PAR(41)))
      PAR(47) = PAR(45) * PAR(46)
      DO 160 J = 1, 2
        V2(J) = (PAR(36 + J) - PAR(45) *
     1          (PAR(57 + J) + PAR(54 + J))) / 2.0
  160 CONTINUE
      V2(3)   = 0.0
      CALL GEN013 (DATC, IATC, 1, IPR(477))
      DO 260 IA = 1, IPR(477)
        NIA = NASUP + IA
        IIA = IATC(IA)
        IF (IIA .NE. 0) THEN
          CALL GEN048 (-1, JFG(IIA), 27, ISKP)
          IF (ISKP .EQ. 0) THEN
            DO 170 J = 1, 3
              V1(J) = VOID((IIA - 1) * (NP4 + 15) + J)
              IF (XSD(IIA, J) .LT. 0.001) XSD(IIA,J) = 0.001
              V6(J) = 1.0 / XSD(IIA, J)**2
  170       CONTINUE
            CALL GEN002 (-1, AAREV, V1, DXI, XLNG)
            IF (IPR(108) .NE. 0) THEN
              CALL PLA047 (XLAB(IIA), NQ2, IDUM, JDUM, 0, IGBL(55),
     1                     1, 0)
                WRITE (LU65, 99998)
     1                 IIA, NQ2, 0, (DXI(J), J = 1, 3), 1.0, 0.0
                L    = 0
                IANI = 1
                CALL GEN048 (-1, IFG(IIA), 7, IHAT)
                IF (IHAT .EQ. 1) THEN
                  CALL GEN048 (-1, IFG(IIA), 4, IANI)
                ENDIF
                DO 190 J = 1, 3
                  DO 180 K = 1, 3
                    L = L + 1
                    UIJC(J, K) = VOID(IPR(297) + IIA * 21 + L - 9)
     1                         * 10000.0
                    IF ((IANI .EQ. 0 .OR. NQ2(1:2) .EQ. 'CG')
     1                .AND. J .EQ. K) UIJC(J, K) = 25
  180             CONTINUE
  190           CONTINUE
                CALL GEN001 (1, TMAT, UIJC, UIJC)
                WRITE (LU65, 99997)
     1                 IIA, NQ2, 0, (NINT(UIJC(J, J)), J = 1, 3),
     2            NINT(UIJC(1, 2)), NINT(UIJC(1, 3)), NINT(UIJC(2, 3))
            ENDIF
            DO 200 J = 1, 3
              XXO(IA, J) = DXI(J) * PAR(45) + V2(J)
  200       CONTINUE
            DO 210 I = 1, 9
              J = MOD (I - 1, 3) + 1
              K = ((I - 1) / 3)  + 1
              PAT(J, K) = CON(IIA, I)
  210       CONTINUE
            CALL GEN005 (AAREV, QD)
            CALL GEN004 (QD, PAT, PAC)
            CALL GEN099 (PAC, V6, QD)
            DO 230 J = 1, 2
              DO 220 K = 1, 2
                QD(J, K) = QD(J, K) - QD(J, 3) * QD(K, 3) / QD(3, 3)
  220         CONTINUE
  230       CONTINUE
            DO 240 J = 1, 2
              QD(J, 3) = 0.0
              QD(3, J) = 0.0
              V6(J)    = XXO(IA, J)
  240       CONTINUE
            QD(3, 3) = - PAR(47)**2
            CALL GEN003 (QD, QCC, DUMMY, 1)
            TD2 = QD(3, 3)
            NDG = 0
            DO 250 J = 1, 2
              T1 = QCC(3, J)**2 - QCC(J, J)
              IF (T1 .LE. 0.0) THEN
                NDG   = 1
                V5(J) = 0.001 + PAR(44)
              ELSE
                V5(J) = SQRT(T1) + PAR(44)
                V6(J) = V6(J) + QCC(3, J)
                TD2   = TD2 + QD(3, J) * QCC(3, J)
              ENDIF
              XXO(NIA, 2 * J - 1) = V6(J) - V5(J)
              XXO(NIA, 2 * J)     = V6(J) + V5(J)
  250       CONTINUE
            IF (NDG .EQ. 0) THEN
              IF (TD2 .LT. 0.0) THEN
                TD3 = - (1.0 - 2.0 * PAR(44) / (V5(1) + V5(2)))**2
     1              / TD2
                XSD(NIA, 1) = QD(1, 1) * TD3
                XSD(NIA, 2) = QD(1, 2) * TD3
                XSD(NIA, 3) = QD(2, 2) * TD3
                GOTO 260
              ENDIF
            ENDIF
            XSD(NIA, 1) = 4.0 / (XXO(NIA, 2) - XXO(NIA, 1))**2
            XSD(NIA, 2) = 0.0
            XSD(NIA, 3) = 4.0 / (XXO(NIA, 4) - XXO(NIA, 3))**2
          ENDIF
        ENDIF
  260 CONTINUE
      K   = NASUP + 1
      NCD = 0
      DO 270 I = 1, NCB
        XSD(K, 4) = VOID(IPR(298) + I * 3 - 2)
        XSD(K, 5) = VOID(IPR(298) + I * 3 - 1)
        XBND      = VOID(IPR(298) + I * 3)
        XB        = PAR(84 + NINT(ABS(XBND)))
        IF (XB .LT. 0) THEN
          XB   = - XB
          XBND = - ABS(XBND)
        ENDIF
        XSD(K, 6) = SIGN(128 / 2**XB, XBND)
        XXO(K, 5) = PAR(85 + NINT(ABS(XBND)))
        IF (IATP(NINT(XSD(K, 4))) .LT. NP1) THEN
          NCD = NCD + 1
          K   = K + 1
        ENDIF
  270 CONTINUE
      IF (IPR(108) .NE. 0) THEN
        CLOSE (LU65)
        IF (IPR(477) .GT. 1) CALL PLA209
        IPR(108) = 0
        GOTO 80
      ENDIF
  280 CALL GEN074 (SCIR, 0.0, 1, 390)
      CALL GEN074 (DP,   0.0, 1, 260)
C * GRAPHICS OUTPUT SECTION
      PVER    = PAR(349)
      IF (IPR(478) .LE. 1 .AND. NLOOP .GE. 1) THEN
        BCD(1:12) = 'P.L.A.T.O.N'//CHAR(0)
        CALL GGIP (PAR(37), PAR(38), 0.0, 1)
      ENDIF
      IF (IWIN .EQ. 1 .AND. LRET .EQ. 6) THEN
        BCD = 'Click on Window to STOP Rotation'//CHAR(0)
        CALL GGIP (-999.0, 2.0, 33.0, 111)
      ENDIF
      IF (IPR(116) .EQ. 0) THEN
        CALL GGIP (0.0, 1.0, 0.0, 0)
      ELSE
        CALL GGIP (0.0, FLOAT(IPR(143 + IPR(478) - 1)), 0.0, 0)
      ENDIF
      CALL PLA117 (PAR(37), PAR(38), 1)
      IF (NCD .GT. 0 .OR. IPR(201) .EQ. 0) THEN
        NQD   = 0
        V8(1) = 0.0
        V8(2) = 0.0
        V8(3) = 1.0
        IF (NCD .EQ. 0) THEN
          MILP = 3
        ELSE
          MILP = 1
        ENDIF
        IF (IGBL(75) .NE. 0 .AND.
     1      IPR(201) .EQ. 0) THEN
          MLP = 3
        ELSE
          MLP = 2
        ENDIF
        DO 870 MLOOP = MILP, MLP
          IF (MLOOP .LT. 3) THEN
            MNB = NCD
          ELSE
            MNB = IPR(477)
          ENDIF
          DO 860 NBLP = 1, MNB
            IF (CC) GOTO 1290
            NSHIFT = 1
  545       IF (MLOOP .LT. 3) THEN
              NBND = NINT(XSD(NASUP + NBLP, 6))
              IF (NBND .GT. 0) THEN
                IDASH = 0
              ELSE
                IDASH = 1
                NBND  = IABS(NBND)
              ENDIF
              KD1     = NINT(XSD(NASUP + NBLP, 4))
              KD2     = NINT(XSD(NASUP + NBLP, 5))
              W(1, 1) = KD1
              W(1, 2) = KD2
              NA1     = 0
              NA2     = 0
              DO 310 K = 1, IPR(477)
                III = IATC(K)
                IF (III .EQ. 0) GOTO 310
                I   = 0
                IF (III .EQ. KD1) THEN
                  NA1 = K
                  I   = 1
                  CALL GEN048 (-1, JFG(III), 27, ISKP)
                  IF (ISKP .EQ. 1) GOTO 860
                ELSE IF (III .EQ. KD2) THEN
                  NA2 = K
                  I   = 2
                  CALL GEN048 (-1, JFG(III), 27, ISKP)
                  IF (ISKP .EQ. 1) GOTO 860
                ENDIF
                IF (I .NE. 0) THEN
                  DO 290 J = 2, 4
                    W(J, I) = XXO(K, J - 1)
  290             CONTINUE
                  IF (NA1 .GT. 0 .AND. NA2 .GT. 0) THEN
                    IF (W(4, 1) .LT. W(4, 2)) THEN
                      DO 300 J = 1, 4
                        CALL GEN018 (W(J, 1), W(J, 2))
  300                 CONTINUE
                      CALL GEN014 (NA1, NA2)
                    ENDIF
                    ID1 = NA1 * (NP1 + 1) + NA2
                    GOTO 320
                  ENDIF
                ENDIF
  310         CONTINUE
              GOTO 860
  320         DO 330 I = 1, 3
                DAM(I, 3) = W(1 + I, 2) - W(1 + I, 1)
  330         CONTINUE
              CALL GEN007 (AA, DAM(1, 3), V3, 1)
              IF (MLOOP .EQ. 2) DIST = SQRT(DAM(1, 3)**2 + DAM(2, 3)**2
     1           + DAM(3, 3)**2) / PAR(45)
              CALL GEN002 (-1, RORO, AAREV(1, 3), V2, XLNG)
              CALL GEN007 (AA, V2, V2, 1)
              T6 = ABS(GEN009 (V3, V2))
              IF (0.9994 .LE. T6) GOTO 860
              CALL GEN019 (AA, BB, V3, V2, B, 1)
              TX = XXO(NASUP + NBLP, 5) / PAR(46)
              DO 340 J = 1, 3
                T1           = - B(J, 2) * TX
                SCIR(J, 1)   =   T1
                SCIR(J, 129) =   T1
                SCIR(J, 65)  = - T1
                T1           = - B(J, 3) * TX
                SCIR(J, 33)  =   T1
                SCIR(J, 97)  = - T1
  340         CONTINUE
              DO 370 K = 1, 3
                T1    = SQRT(1.0 /
     1              (2.0 * (1.0 + COS(GL(6) / (2**(K + 1))))))
                KDEL  = 2**(6 - K)
                KDEL1 = KDEL + 1
                KDEL2 = KDEL / 2
                DO 360 L = KDEL1, 65, KDEL
                  J = L - KDEL
                  M = L - KDEL2
                  DO 350 N = 1, 3
                    T2 = (SCIR(N, L) + SCIR(N, J)) * T1
                    SCIR(N, M)      =  T2
                    SCIR(N, M + 64) = -T2
  350             CONTINUE
  360           CONTINUE
  370         CONTINUE
              DO 520 II = 1, 2
                III = NINT(W(1, II))
                DO 380 I = 1, 9
                  J = MOD (I - 1, 3) + 1
                  K = ((I - 1) / 3)  + 1
                  PAT(J, K) = CON(III, I)
  380           CONTINUE
                CALL GEN005 (AAREV, QM)
                CALL GEN004 (QM, PAT, PAC)
                DO 390 J = 1, 3
                  IF (XSD(III, J) .NE. 0.0) THEN
                    V6(J) = 1.0 / XSD(III, J)**2
                  ELSE
                    V6(J) = 1.0
                  ENDIF
  390           CONTINUE
                CALL GEN099 (PAC, V6, QM)
                T1 = 3 - II * 2
                DO 400 J = 1, 3
                  V3(J) = V3(J) * T1
  400           CONTINUE
                IF (GEN006 (V3, QM, V8) .LT. 0.0) THEN
                  IBND = 0
                  T1 = - 1.0 / QM(3, 3)
                  DO 420 J = 1, 2
                    DO 410 K = 1, 2
                      S(K, J) = QM(K, J) + QM(K, 3) * QM(J, 3) * T1
  410               CONTINUE
                    S(3, J) = 0.0
                    S(J, 3) = 0.0
  420             CONTINUE
                  S(3, 3) = 0.0
                ELSE
                  DO 440 J = 1, 3
                    DO 430 K = 1, 3
                      S(J, K) = QM(J, K)
  430               CONTINUE
  440             CONTINUE
                  IBND = II
                ENDIF
                T5 = 1.0
                IF (II .LT. 2) THEN
                  RADIUS = 1.0 + T6 * PAR(48)
                ELSE
                  RADIUS = 1.0 - T6 * PAR(48)
                ENDIF
                CALL GEN002 (1, S, V3, V4, XLNG)
                T2 = GEN009 (V3, V4)
                KL = 5 - 2 * II
                IF (MLOOP .EQ. 2) THEN
                  KSTP = 4
                ELSE
                  KSTP = 32
                ENDIF
                DO 470 K = 1, 65, KSTP
                  DO 450 J = 1, 3
                    V6(J) = SCIR(J, K) * RADIUS
                    V5(J) = V6(J)
  450             CONTINUE
                  T3 = GEN009 (V5, V4)
                  T4 = T3 * T3 - T2 * (GEN006(V5, S, V5) - T5)
                  IF (T4 .LT. 0.0000001) GOTO 860
                  T4 = SQRT(T4)
                  T1 = ( T4 - T3) / T2
                  T3 = (-T4 - T3) / T2
                  L  = K + KL - 1
                  DO 460 J = 1, 3
                    SCIR(J, L)     = ( V6(J) + T1 * V3(J)) * PAR(47)
                    SCIR(J, L + 1) = (-V6(J) - T3 * V3(J)) * PAR(47)
  460             CONTINUE
  470           CONTINUE
                IF (IBND + MLOOP .EQ. 2) THEN
                  T4 = T2 * T5
                  IF (T4 .LT. 0.0) GOTO 860
                  T1 = SQRT(T4)  / T2
                  DO 480 J = 1, 3
                    T4 = (T1 * V3(J) * PAR(47) - 0.5 * (SCIR(J, KL)
     1                 + SCIR(J, KL + 64))) * 1.001
                    SCIR(J, KL)      = SCIR(J, KL) + T4
                    SCIR(J, KL + 64) = SCIR(J, KL + 64) + T4
  480             CONTINUE
                ENDIF
                DO 490 I = 1, 65, KSTP
                  DP(1, II - 1 + I) = SCIR(1, KL - 1 + I) + W(2, II)
                  DP(2, II - 1 + I) = SCIR(2, KL - 1 + I) + W(3, II)
  490           CONTINUE
                IF (IBND .EQ. 1) THEN
                  DO 500 I = 68, 128, KSTP
                    DP(1, II + I) = SCIR(1, KL - 63 + I) + W(2, II)
                    DP(2, II + I) = SCIR(2, KL - 63 + I) + W(3, II)
  500             CONTINUE
                  GOTO 520
                ENDIF
                DO 510 K = 4, 64, 4
                  L = K + II
                  M = L + 64
                  N = 66 - L
                  IF (N .LE. 0) GOTO 520
                  DP(1, M) = DP(1, N)
                  DP(2, M) = DP(2, N)
  510           CONTINUE
  520         CONTINUE
              DO 540 K = 1, 65, 32
                T1 = 0.0
                T2 = 0.0
                DO 530 J = 1, 2
                  T1 = T1 + (DP(J, K)     - W(J + 1, 1))**2
                  T2 = T2 + (DP(J, K + 1) - W(J + 1, 1))**2
  530           CONTINUE
                IF (T2 .LE. T1) GOTO 860
  540         CONTINUE
            ELSE
              NTOM = NASUP + NBLP
              KKK  = IATC(NBLP)
              IF (KKK .EQ. 0) GOTO 860
              IF (KKK .GT. NATOM) THEN
                IF (IPR(506) .EQ. 0) GOTO 860
              ENDIF
              CALL GEN048 (-4, IFG(KKK), 15, NO1)
              CALL GEN048 (-1, JFG(KKK), 12, INH)
              CALL GEN048 (-1, IFG(KKK), 7, IHAT)
              NO1 = NO1 + 1
              IF (IHAT .NE. 1 .OR.
     1          MAX (IPR(212), INH) * IPR(232) .EQ. 1) THEN
                NPOS = 0
                CALL PLA047 (XLAB(KKK), NQ1, IDUM, JDUM,
     1            IPR(350) * 2 - 1, IGBL(55), 0, 1 - IGBL(55))
                CALL GEN039 (1, NQ1, 1, 6, NB, NP)
                NSHIFT  = NSHIFT + 2
                PAR71   = NSHIFT * PAR(71)
                XSFT    = (XXO(NTOM, 2) - XXO(NTOM, 1)) / 7.0
                YSFT    = (XXO(NTOM, 4) - XXO(NTOM, 3)) / 7.0
                PHOR    = PVER * NP * 6.0 / 7.0
                POSL(1) = XXO(NTOM, 1) - PHOR - PAR71
                POSL(2) = XXO(NTOM, 2) + PAR71
                POSL(3) = XXO(NTOM, 3) - PVER - PAR71
                POSL(4) = XXO(NTOM, 4) + PAR71
                POSL(5) = (POSL(1) + POSL(2)) / 2.0
                POSL(6) = (POSL(3) + POSL(4)) / 2.0
                IF (POSL(5) .GT. PAR(37) / 2.0) THEN
                  IF (POSL(6) .GT. PAR(38) / 2.0) THEN
                    IPOS = 2
                  ELSE
                    IPOS = 0
                  ENDIF
                ELSE
                  IF (POSL(6) .GT. PAR(37) / 2.0) THEN
                    IPOS = 4
                  ELSE
                    IPOS = 6
                  ENDIF
                ENDIF
              ELSE
                GOTO 860
              ENDIF
            ENDIF
            IF (MLOOP .EQ. 1) THEN
              NQD = NQD + 1
              T1 = 0.0
              T2 = 0.0
              DO 570 J = 1, 2
                Y1(J) = DP(J, 1) - DP(J, 65)
                Y2(J) = DP(J, 2) - DP(J, 66)
                T1    = T1 + Y1(J)**2
                T2    = T2 + Y2(J)**2
  570         CONTINUE
              IF (T1 * T2 .LE. 0.0) THEN
                T1 = 0.0
                T2 = 0.0
              ELSE
                T1 = PAR(44) / SQRT(T1)
                T2 = PAR(44) / SQRT(T2)
              ENDIF
              NREF = NASUP + NQD
              DO 580 J = 1, 2
                Y1(J)            = Y1(J) * T1
                Y2(J)            = Y2(J) * T2
                CON(NREF, J)     = DP(J, 1)  + Y1(J)
                CON(NREF, J + 2) = DP(J, 2)  + Y2(J)
                CON(NREF, J + 4) = DP(J, 66) - Y2(J)
                CON(NREF, J + 6) = DP(J, 65) - Y1(J)
  580         CONTINUE
              CON(NREF, 9) = ID1
            ELSE
  590         IF (MLOOP .EQ. 3) THEN
  600           IPOS = MOD(IPOS, 8) + 1
                NPOS = NPOS + 1
                KKKA = KKK * (NP4 + 15)
                IF (NPOS .GT. 8) THEN
                  IF (NSHIFT .LT. 10) GOTO 545
                  WRITE (LU6, 99999) NQ1
                  IF (IGBL(105) .EQ. 0) THEN
                    VOID(KKKA - 2) = 0.0
                    VOID(KKKA - 1) = 0.0
                    VOID(KKKA    ) = 0.0
                  ELSE
                    VOID(KKKA - 2) = POSL(LPOS(8, 1))
                    VOID(KKKA - 1) = POSL(LPOS(8, 2))
                    VOID(KKKA    ) = PHOR
                  ENDIF
                  GOTO 860
                ENDIF
                LPOS1  = LPOS(IPOS, 1)
                LPOS2  = LPOS(IPOS, 2)
                XSHFT  = 0.0
                YSHFT  = 0.0
                LPOS12 = LPOS1 * 10 + LPOS2
                IF (LPOS12 .EQ. 23) THEN
                  XSHFT = - XSFT
                  YSHFT =   YSFT
                ELSE IF (LPOS12 .EQ. 24) THEN
                  XSHFT = - XSFT
                  YSHFT = - YSFT
                ELSE IF (LPOS12 .EQ. 14) THEN
                  XSHFT =   XSFT
                  YSHFT = - YSFT
                ELSE IF (LPOS12 .EQ. 13) THEN
                  XSHFT =   XSFT
                  YSHFT =   YSFT
                ENDIF
                VOID(KKKA - 2) = POSL(LPOS1) + XSHFT
                VOID(KKKA - 1) = POSL(LPOS2) + YSHFT
                VOID(KKKA    ) = PHOR
                DP(1, 1)  = VOID(KKKA - 2)
                DP(2, 1)  = VOID(KKKA - 1)
                DP(1, 2)  = DP(1, 1)
                DP(2, 2)  = DP(2, 1) + PVER
                DP(1, 65) = DP(1, 1) + PHOR
                DP(2, 65) = DP(2, 1)
                DP(1, 66) = DP(1, 65)
                DP(2, 66) = DP(2, 2)
                IF (DP(1, 1) .LT. 0.0 .OR. DP(1, 65) .GT. PAR(37) .OR.
     1              DP(2, 1) .LT. 0.0 .OR. DP(2, 65) .GT. PAR(38))
     2              GOTO 600
                ID1 = 0
                NA1 = 0
                NA2 = 0
                IF (NBLP .GT. 1) THEN
                  NBM1 = NBLP - 1
                  DO 610 J = 1, NBM1
                    JJJ = IATC(J)
                    IF (JJJ .NE. 0) THEN
                      CALL GEN048 (-1, JFG(JJJ), 27, ISKP)
                      IF (ISKP .EQ. 0) THEN
                        IF (IPR(232) .EQ. 0) THEN
                          CALL GEN048 (-1, IFG(JJJ), 7, JHAT)
                          ISKP = JHAT
                        ENDIF
                        IF (ISKP .EQ. 0) THEN
                          KKKK = KKK * (NP4 + 15)
                          JJJJ = JJJ * (NP4 + 15)
                          DSX  = ABS(VOID(KKKK - 2) - VOID(JJJJ - 2))
                          DSY  = ABS(VOID(KKKK - 1) - VOID(JJJJ - 1))
                          IF (DSY .LT. 1.1 * PAR(349)) THEN
                            IF (DSX .LT. MAX (PHOR, VOID(JJJJ)))
     1                          GOTO 600
                          ENDIF
                        ENDIF
                      ENDIF
                    ENDIF
  610             CONTINUE
                ENDIF
                IF (IGBL(74) .NE. 0) THEN
                  CALL GGIP (DP(1, 1),  DP(2, 1),  0.0, 3)
                  CALL GGIP (DP(1, 65), DP(2, 65), 0.0, 2)
                  CALL GGIP (DP(1, 66), DP(2, 66), 0.0, 2)
                  CALL GGIP (DP(1, 2),  DP(2, 2),  0.0, 2)
                  CALL GGIP (DP(1, 1),  DP(2, 1),  0.0, 2)
                  CALL GGIP20 (0.0, CHAR(48 + IPOS), 1, 0.3, 2, 1,
     1               DP(1,1),DP(2,1))
                ENDIF
              ENDIF
              IPR(151) = 0
              IPR(152) = 0
              IQ       = NQD + 1
              IQN      = IQ + NASUP
              DO 620 J = 1, 2
                YMIN(J) = MIN(DP(J, 1), DP(J, 2), DP(J, 66), DP(J, 65))
                YMAX(J) = MAX(DP(J, 1), DP(J, 2), DP(J, 66), DP(J, 65))
                CON(IQN, J)     = DP(J, 1)
                CON(IQN, J + 2) = DP(J, 2)
                CON(IQN, J + 4) = DP(J, 66)
                CON(IQN, J + 6) = DP(J, 65)
  620         CONTINUE
              CON(IQN, 9) = ID1
              CALL PLA107 (0, 0, 0, DUMP)
              NA1P1 = NA1 + 1
              DO 640 IA = NA1P1, IPR(477)
                IATCIA = IATC(IA)
                IF (IATCIA .NE. 0) THEN
                  IF (IA .NE. NA2 .AND. IATCIA .LE. NATOM) THEN
                    NIA = NASUP + IA
                    CALL GEN048 (-1, JFG(IATCIA), 27, ISKP)
                    IF (ISKP .NE. 1) THEN
                      DO 630 J = 1, 2
                        IF (YMAX(J) .LE. XXO(NIA, 2 * J - 1)) GOTO 640
                        IF (YMIN(J) .GE. XXO(NIA, 2 * J    )) GOTO 640
  630                 CONTINUE
                      CALL PLA107 (IQ, IA, 1, DUMP)
                      IF (DUMP .GT. 0.0) THEN
                        IF (IPR(151) .GE. NP15) GOTO 650
                      ELSE IF (DUMP .LT. 0.0) THEN
                        GOTO 860
                      ENDIF
                    ENDIF
                  ENDIF
                ENDIF
  640         CONTINUE
  650         IF (NQD .GT. 0) THEN
                IF (MLOOP .LT. 3) THEN
                  DO 660 III = 1, 3
                    V1(III)  = XXO(NA2, III) - XXO(NA1, III)
  660             CONTINUE
                  CALL GEN007 (AA, V1, V1, 1)
                ENDIF
                DO 810 IB = 1, NQD
                  NIB = NASUP + IB
                  ID2 = NINT(CON(NIB, 9))
                  IF (ID1 .EQ. ID2) GOTO 810
                  NB2 = MOD(ID2, NP1 + 1)
                  NB1 = ID2 / (NP1 + 1)
                  IF (NA2 .GT. NB1) GOTO 810
                  DO 670 J = 1, 2
                    IF (YMAX(J) .LE. MIN (CON(NIB, J), CON(NIB, J + 2),
     1                CON(NIB, J + 4), CON(NIB, J + 6))) GOTO 810
                    IF (YMIN(J) .GE. MAX (CON(NIB, J), CON(NIB, J + 2),
     1                CON(NIB, J + 4), CON(NIB, J + 6))) GOTO 810
  670             CONTINUE
                  DO 690 L = 1, 4
                    K         = 2 * L
                    K1        = MOD(K, 8) + 2
                    QUA(1, L) = CON(NIB, K)      - CON(NIB, K1)
                    QUA(2, L) = CON(NIB, K1 - 1) - CON(NIB, K - 1)
                    QUA(3, L) = CON(NIB, K - 1)  * CON(NIB, K1)
     1                        - CON(NIB, K)      * CON(NIB, K1 - 1)
                    T1 = SQRT(QUA(1, L)**2 + QUA(2, L)**2)
                    IF (T1 .LE. 0.0) GOTO 810
                    DO 680 J = 1, 3
                      QUA(J, L) = QUA(J, L) / T1
  680               CONTINUE
  690             CONTINUE
                  T3    = 3.0
                  NASIQ = NASUP + IQ
                  SCONX = 0.0
                  SCONY = 0.0
                  DO 710 K = 1, 4
                    T2 = 3.0
                    J  = K * 2
                    XCONK = CON(NASIQ, J - 1)
                    YCONK = CON(NASIQ, J)
                    SCONX = SCONX + XCONK
                    SCONY = SCONY + YCONK
                    DO 700 L = 1, 4
                      T1 = XCONK * QUA(1, L)
     1                   + YCONK * QUA(2, L) + QUA(3, L)
                      IF (T1 .LT. 0.0) T2 = T2 - 1.0
                      FL(L, K) = T1
  700               CONTINUE
                    IF (T2 .LT. 0.0) T3 = T3 - 1.0
  710             CONTINUE
                  IF (MLOOP .EQ. 3) THEN
                    XCONK = SCONX / 4.0
                    YCONK = SCONY / 4.0
                    T2    = 3.0
                    DO 715 L = 1, 4
                      T1 = XCONK * QUA(1, L)
     1                   + YCONK * QUA(2, L) + QUA(3, L)
                      IF (T1 .LT. 0.0) T2 = T2 - 1.0
  715               CONTINUE
                    IF (T2 .LT. 0.0) GOTO 590
                  ENDIF
                  IF (T3 .LT. 0.0) THEN
                    ITYPE = -1
                  ELSE IF (T3 .LT. 3.0) THEN
                    ITYPE = 0
                  ELSE
                    NASIQ = NASUP + IQ
                    DO 730 L = 1, 4
                      L1 = MOD(L, 4) + 1
                      Y1(1) = CON(NASIQ, L  * 2 - 1)
                      Y1(2) = CON(NASIQ, L  * 2)
                      Y2(1) = CON(NASIQ, L1 * 2 - 1)
                      Y2(2) = CON(NASIQ, L1 * 2)
                      DO 720 K = 1, 4
                        T1 = FL(K, L)
                        T2 = FL(K, L1)
                        T3 = T1 - T2
                        IF (T1 * T2 .LE. 0.0) THEN
                          IF (ABS(T3) .GT. PAR(54)) THEN
                            T4 = (T1 * Y2(1) - T2 * Y1(1)) / T3
                            T5 = (T1 * Y2(2) - T2 * Y1(2)) / T3
                            K0 = 2 * K
                            K1 = 2 * (MOD(K, 4) + 1)
                            IF ((T4 - CON(NIB, K0 - 1)) *
     1                         (CON(NIB, K1 - 1) - T4)
     2                        + (T5 - CON(NIB, K0)) *
     3                         (CON(NIB, K1) - T5)
     4                       .GT. -1.E-4) GOTO 740
                          ENDIF
                        ENDIF
  720                 CONTINUE
  730               CONTINUE
                    GOTO 810
  740               ITYPE = 1
                  ENDIF
                  IF (MLOOP .LT. 3) THEN
                    IF (NA1 .EQ. NB1 .OR.
     1                  NA1 .EQ. NB2 .OR.
     2                  NA2 .EQ. NB2 .OR.
     3                  NA2 .EQ. NB1) THEN
                      IF ((NA1 + NA2) .LT. (NB1 + NB2)) THEN
                        GOTO 780
                      ELSE
                        GOTO 810
                      ENDIF
                    ENDIF
                    DO 750 J = 1, 3
                      V2(J) = XXO(NB2, J) - XXO(NB1, J)
                      V4(J) = XXO(NB1, J) - XXO(NA1, J)
  750               CONTINUE
                    CALL GEN007 (AA, V2, V2, 1)
                    CALL GEN007 (AA, V4, V4, 1)
                    CALL GEN011 (BB, V1, V2, V3, 1)
                    IF (GEN009 (V3, V3) .LE. PAR(54)) THEN
                      CALL GEN011 (BB, V1, V4, V5, 1)
                      CALL GEN011 (BB, V5, V1, V3, 1)
                      YUNK = GEN009 (V3, V3) - PAR(54)
                      IF (YUNK .GT. 0.0) THEN
                        GOTO 770
                      ELSE
                        GOTO 780
                      ENDIF
                    ENDIF
                    IF (GEN009 (V3, V4) .LT. - PAR(54)) THEN
                      DO 760 J = 1, 3
                        V3(J) = - V3(J)
  760                 CONTINUE
                    ENDIF
  770               IF (V3(3) .LE. 0.0) GOTO 810
                  ENDIF
  780             IF (ITYPE .LT. 0) GOTO 860
                  IF (IPR(152) .GE. NP7) GOTO 820
                  IPR(152) = IPR(152) + 1
                  DO 800 K = 1, 4
                    DO 790 J = 1, 3
                      XDIR(IPR(152), J, K) = QUA(J, K)
  790               CONTINUE
  800             CONTINUE
                  IDIR(IPR(152)) = IB
  810           CONTINUE
              ENDIF
  820         IF (MLOOP .LT. 3) THEN
                CALL PLA108 (1, 4, 129, 3)
                CALL PLA108 (2, 4, 66,  3)
                BDIR = - 0.5
                DO 850 K = 1, 65, NBND
                  BDIR = - BDIR
                  DO 830 J = 1, 2
                    DP(J, 130 + NINT(1.5 - BDIR)) = DP(J, K)
                    DP(J, 130 + NINT(1.5 + BDIR)) = DP(J, K + 1)
  830             CONTINUE
                  IF (IDASH .EQ. 1) THEN
                    NSTEP = NINT(DIST / 0.4) * 2 + 1
                  ELSE
                    NSTEP = 1
                  ENDIF
                  DELX  = (DP(1, 132) - DP(1, 131)) / NSTEP
                  DELY  = (DP(2, 132) - DP(2, 131)) / NSTEP
                  DO 840 J = 1, NSTEP, 2
                    DP(1, 132) = DP(1, 131) + DELX
                    DP(2, 132) = DP(2, 131) + DELY
                    CALL PLA108 (131, 1, 132, 3)
                    DP(1, 131) = DP(1, 131) + 2 * DELX
                    DP(2, 131) = DP(2, 131) + 2 * DELY
  840             CONTINUE
  850           CONTINUE
              ELSE
                IF (IPR(151) .GT. 0 .OR. IPR(152) .GT. 0) GOTO 590
              ENDIF
            ENDIF
  860     CONTINUE
  870   CONTINUE
      ENDIF
C * LOOP THROUGH ATOM LIST TO DRAW ELLIPSOIDS
      DO 1280 ITOM = 1, IPR(477)
        IF (CC) GOTO 1290
        NTOM = NASUP + ITOM
        KKK = IATC(ITOM)
        IF (KKK .EQ. 0) GOTO 1280
        IF (KKK .GT. NATOM) THEN
          IF (IPR(506) .EQ. 0) GOTO 1280
        ENDIF
        CALL GEN048 (-1, JFG(KKK), 27, ISKP)
        IF (ISKP .EQ. 1) GOTO 1280
        DO 880 J = 1, 2
          YMIN(J) = XXO(NTOM, 2 * J - 1)
          YMAX(J) = XXO(NTOM, 2 * J    )
  880   CONTINUE
        CALL GEN048 (-4, IFG(KKK), 15, NO1)
        NO1 = NO1 + 1
        IF (IEN(NO1) .EQ. 2) THEN
          NFRST = IPR(175)
          LINES = IPR(176)
        ELSE IF (IEN(NO1) .EQ. 1 .OR. IEN(NO1) .EQ. 33 .OR.
     1           IEN(NO1) .EQ. 113) THEN
          NFRST = IPR(177)
          LINES = IPR(178)
        ELSE
          NFRST = IPR(179)
          LINES = IPR(180)
        ENDIF
        IF (IPR(211) .EQ. 1) THEN
          NFRST = 0
        ELSE IF (IPR(211) .EQ. 2) THEN
          CALL GEN048 (-1, IFG(KKK), 7, IVAL)
          IF (IVAL .EQ. 0) THEN
            NFRST = 1
          ELSE
            NFRST = IPR(177)
          ENDIF
          LINES = IPR(180)
        ENDIF
        DO 890 J = 1, 3
          V1(J)  = VOID((KKK -1) * (NP4 + 15) + J)
          DXI(J) = XXO(ITOM, J)
  890   CONTINUE
        CALL PLA047 (XLAB(KKK), NQ1, IDUM, JDUM, IPR(350) * 2 - 1,
     1               IGBL(55), 0, 1 - IGBL(55))
        IF (IGBL(75) .GT. 0) THEN
          CALL GEN048 (-1, JFG(KKK), 11, IVAL)
          CALL GEN048 (-1, JFG(KKK), 12, INH)
          CALL GEN048 (-1, IFG(KKK),  7, IHAT)
          IF (IHAT .NE. 1 .OR.
     1      MAX (IPR(212), INH) * IPR(232) .GT. 0) THEN
            IF (IPR(116) .EQ. 0) THEN
              IF (IPR(328) .EQ. 0) THEN
                COLX = FLOAT(IVAL)
              ELSE
                COLX = FLOAT (2 - IVAL)
              ENDIF
              CALL GGIP (0.0, COLX, 0.0, 0)
            ENDIF
            XLPOS = VOID(KKK * (NP4 + 15) - 2)
            YLPOS = VOID(KKK * (NP4 + 15) - 1)
            IF ((XLPOS .GT. 1.0 .OR. YLPOS .GT. 1.0)
     1          .AND. COLX .NE. 0.0) CALL GGIP20
     1         (0.0, NQ1, 6, PAR(349), -1, 1, XLPOS, YLPOS)
            IF (IPR(116) .EQ. 0) CALL GGIP (0.0, 1.0, 0.0, 0)
          ENDIF
        ENDIF
        IF (KKK .GT. NATOM) GOTO 1280
        IF (IPR(116) .EQ. 0 .AND. IPR(346) .EQ. 1) THEN
          CALL GEN048 (-4, IFG(KKK), 15, NRI)
          CALL GGIP (0.0, FLOAT(IACL(NRI + 1)) , 0.0, 0)
        ENDIF
        IPR(151) = 0
        IPR(152) = 0
        IF (IPR(477) .GT. ITOM) THEN
          L = 0
          DO 1040 IA = ITOM, IPR(477)
            IATCIA = IATC(IA)
            IF (IATCIA .EQ. 0) GOTO 1040
            IF (IATCIA .GT. NATOM) GOTO 1040
            CALL GEN048 (-1, JFG(IATCIA), 27, ISKP)
            IF (ISKP .EQ. 1) GOTO 1040
            NIA = NASUP + IA
            IF (IA .GT. ITOM) THEN
              DO 900 J = 1, 2
                IF (YMAX(J) .LE. XXO(NIA, 2 * J - 1)) GOTO 1040
                IF (YMIN(J) .GE. XXO(NIA, 2 * J    )) GOTO 1040
  900         CONTINUE
            ENDIF
            IF (L .LT. 2) L = L + 1
            IF (L .EQ. 2) THEN
              OVMR = 0.0
            ELSE
              OVMR = PAR(44)
            ENDIF
            V12(1, L)   = (XXO(NIA, 1) + XXO(NIA, 2)) * 0.5
            V12(2, L)   = (XXO(NIA, 3) + XXO(NIA, 4)) * 0.5
            V12(3, L)   = 1.0
            QA(1, 1, L) = XSD(NIA, 1)
            QA(1, 2, L) = XSD(NIA, 2)
            QA(2, 1, L) = XSD(NIA, 2)
            QA(2, 2, L) = XSD(NIA, 3)
            TX = XXO(NIA, 2) - XXO(NIA, 1) + XXO(NIA, 4) - XXO(NIA, 3)
            QA(3, 3, L) = -(1.0 - 4.0 * OVMR / TX)**2
            DO 920 K = 1, 2
              QA(K, 3, L) = 0.0
              DO 910 J = 1, 2
                QA(K, 3, L) = QA(K, 3, L) - V12(J, L) * QA(J, K, L)
  910         CONTINUE
              QA(3, K, L) = QA(K, 3, L)
              QA(3, 3, L) = QA(3, 3, L) - QA(3, K, L) * V12(K, L)
  920       CONTINUE
            CALL GEN003 (QA(1, 1, L), QC(1, 1, L), DET, -1)
            DETER(L) = DET * 3.0
            IF (L .LT. 2) GOTO 1040
            AOV3 = 0.0
            BOV3 = 0.0
            DO 940 J = 1, 3
              DO 930 K = 1, 3
                AOV3 = AOV3 + QC(J, K, 2) * QA(J, K, 1)
                BOV3 = BOV3 + QC(J, K, 1) * QA(J, K, 2)
  930         CONTINUE
  940       CONTINUE
            AOV3   = AOV3 / DETER(2)
            AOV3SQ = AOV3**2
            BOV3   = BOV3 / DETER(2)
            POV3   = BOV3 - AOV3SQ
            QOV2   = AOV3 * (AOV3SQ - BOV3 * 1.5) + DETER(1) /
     1               (DETER(2) * 2.0)
            POV3CU = POV3**3
            QOV2SQ = QOV2**2
            PQTEST = POV3CU + QOV2SQ
            IF (PQTEST .GT. 0.0) THEN
              IF (PQTEST + POV3CU * 0.00001 .GT. 0.0) THEN
                GOTO 1010
              ENDIF
            ELSE IF (PQTEST .LT. 0.0) THEN
              IF (PQTEST + QOV2SQ * 0.00001 .LT. 0.0) THEN
                IF (AOV3 .LT. 0.0) THEN
                  IF (BOV3 .LT. 0.0) GOTO 1040
                ENDIF
                IF (QOV2 .EQ. 0.0) THEN
                  PHI = GL(6) / 4.0
                ELSE
                  PHI = ATAN(- SQRT( - PQTEST) / QOV2)
                  IF (PHI .LT. 0.0) PHI = PHI + GL(6) / 2.0
                ENDIF
                ROOT = 2.0 * SQRT( - POV3) * COS(PHI / 3.0) - AOV3
                GOTO 950
              ENDIF
            ENDIF
            IF (AOV3 .LT. 0.0 .AND. BOV3 .LT. 0.0) GOTO 1040
            ROOT = SIGN(SQRT( - POV3), QOV2) - AOV3
  950       DO 970 J = 1, 3
              DO 960 K = 1, 3
                DAM(J, K) = QA(J, K, 1) + ROOT * QA(J, K, 2)
  960         CONTINUE
  970       CONTINUE
            T6 = DAM(1, 1) * DAM(2, 2)
            T7 = DAM(1, 2)**2
            IF (T6 .GT. 1.0001 * T7) THEN
              GOTO 980
            ELSE IF (T6 .LT.  0.9999 * T7) THEN
              GOTO 1010
            ELSE
              T8 = DAM(3, 3) * (DAM(1, 1) + DAM(2, 2))
              T9 = DAM(1, 3)**2 + DAM(2, 3)**2
              IF (T8 * 1.0001 .LT. T9) GOTO 1010
            ENDIF
  980       IF (QC(3, 3, 1) .LT. QC(3, 3, 2)) THEN
              KA = 2
              KB = 1
            ELSE
              KA = 1
              KB = 2
            ENDIF
            T1 = 0.0
            DO 1000 J = 1, 3
              T2 = QA(J, 3, KB)
              DO 990 K = 1, 2
                T2 = T2 + QA(J, K, KB) * V12(K, KA)
  990         CONTINUE
              T1 = T1 + V12(J, KA) * T2
 1000       CONTINUE
            IF (T1 .GT. 0.0) GOTO 1040
            IF (KA .EQ. 1) GOTO 1280
 1010       IF (IPR(151) .LT.  NP15) IPR(151) = IPR(151) + 1
            IJ = 1
            DO 1030 I = 1, 3
              DO 1020 J = I, 3
                XXO(IPR(174) + IPR(151), IJ) = QA(I, J, 2)
                IJ = IJ + 1
 1020         CONTINUE
 1030       CONTINUE
 1040     CONTINUE
          IF (NQD .GT. 0) THEN
            CALL PLA107 (0, 0, 0, DUMP)
            DO 1060 IQ = 1, NQD
              NIQ = NASUP + IQ
              ID  = NINT(CON(NIQ, 9))
              NA1 = ID / (NP1 + 1)
              NA2 = MOD(ID, NP1 + 1)
              IF (ITOM .LE. NA2) THEN
                DO 1050 J = 1, 2
                  IF (YMAX(J) .LE. MIN (CON(NIQ, J),
     1              CON(NIQ, J + 2), CON(NIQ, J + 4),
     2              CON(NIQ, J + 6))) GOTO 1060
                  IF (YMIN(J) .GE. MAX (CON(NIQ, J),
     1              CON(NIQ, J + 2), CON(NIQ, J + 4),
     2              CON(NIQ, J + 6))) GOTO 1060
 1050           CONTINUE
                CALL PLA107 (IQ, ITOM, -1, YUNK)
                IF (YUNK .LT. 0.0) GOTO 1280
                IF (IPR(152) .GE. NP7) GOTO 1070
              ENDIF
 1060       CONTINUE
          ENDIF
        ENDIF
 1070   DO 1080 I = 1, 9
          J = MOD (I - 1, 3) + 1
          K = ((I - 1) / 3)  + 1
          PAT(J, K) = CON(KKK, I)
 1080   CONTINUE
        CALL GEN005 (AAREV, QM)
        CALL GEN004 (QM, PAT, PAC)
        DO 1090 J = 1, 3
          T1     = XSD(KKK, J)
          IF (T1 .NE. 0.0) THEN
            V6(J)  = 1.0 / (T1**2)
          ELSE
            V6(J)  = 1.0
          ENDIF
          RMS(J) = T1
 1090   CONTINUE
        CALL GEN099 (PAC, V6, QM)
        CALL GEN002 (-1, AA, VIEWV, V2, XLNG)
        DO 1110 I = 1, 3
          IF (GEN009 (V2, PAT(1, I)) .LT. 0.0) THEN
            DO 1100 J = 1, 3
              PAC(J, I) = - PAC(J, I)
              PAT(J, I) = - PAT(J, I)
 1100       CONTINUE
          ENDIF
 1110   CONTINUE
        DO 1120 J = 1, 3
          PAC(J, 4) = PAC(J, 1)
          PAC(J, 5) = PAC(J, 2)
 1120   CONTINUE
        CALL GEN002 (-1, AAREV, VIEWV, V6, XLNG)
        CALL GEN007 (AA, V6, V6, 1)
        CALL GEN002 (1, QM, V6, V4, XLNG)
        CALL GEN007 (AA, V4, V4, 1)
        T3     = RMS(3) * PAR(47)
        NRESOL = 1
        NBIS   = 5
        DO 1130 J = 1, 3
          IF (T3 .LT. PAR(50 + J)) THEN
            NBIS   = NBIS - 1
            NRESOL = NRESOL * 2
          ELSE
            GOTO 1140
          ENDIF
 1130   CONTINUE
 1140   NRES1 = NRESOL + 1
        NFIRST = 4 - 3 * NFRST
        DO 1270 II = NFIRST, 4
          II0 = MOD(II + 2, 3) + 1
          II1 = MOD(II, 3) + 1
          II2 = MOD(II + 1, 3) + 1
          IF (0.99938 .LE. ABS(GEN009(V4, PAC(1, II2)))) THEN
            T1 = RMS(II0) * PAR(47)
            T2 = RMS(II1) * PAR(47)
            DO 1150 J = 1, 3
              DAM(J, 1) = PAC(J, II0) * T1
              DAM(J, 2) = PAC(J, II1) * T2
 1150       CONTINUE
          ELSE
            CALL GEN011 (BB, PAC(1, II0), PAC(1, II1), V1, 1)
            CALL GEN011 (BB, V1, V4, V2, 1)
            CALL GEN007 (AA, V2, V2, 1)
            CALL GEN002 (1, QM, V2, V3, XLNG)
            IF (II .LT. 4) THEN
              CALL GEN011 (BB, V3, V1, V5, 1)
            ELSE
              CALL GEN011 (BB, V3, V4, V5, 1)
            ENDIF
            CALL GEN007 (AA, V5, V5, 1)
            T1 = MAX (1.0E-10, GEN006 (V2, QM, V2))
            T2 = MAX (1.0E-10, GEN006 (V5, QM, V5))
            DO 1160 J = 1, 3
              DAM(J, 1) = V2(J) * PAR(47) / SQRT(T1)
              DAM(J, 2) = V5(J) * PAR(47) / SQRT(T2)
 1160       CONTINUE
          ENDIF
          DO 1170 J = 1, 3
            T1           = DAM(J, 1)
            SCIR(J, 1)   = T1
            SCIR(J, 129) = T1
            SCIR(J, 65)  = -T1
            T1           = DAM(J, 2)
            SCIR(J, 33)  = T1
            SCIR(J, 97)  = -T1
 1170     CONTINUE
          DO 1200 K = 1, NBIS
            T1    = SQRT(1.0 / (2.0 * (1.0 + COS(GL(6) / 2**(K + 1)))))
            KDEL  = 2**(6 - K)
            KDEL1 = KDEL + 1
            KDEL2 = KDEL / 2
            DO 1190 L = KDEL1, 65, KDEL
              J = L - KDEL
              M = L - KDEL2
              DO 1180 N = 1, 3
                T2 = (SCIR(N, L) + SCIR(N, J)) * T1
                SCIR(N, M)      =   T2
                SCIR(N, M + 64) = - T2
 1180         CONTINUE
 1190       CONTINUE
 1200     CONTINUE
          IF (II .LT. 4) THEN
            JEND = 65
          ELSE
            JEND = 129
          ENDIF
          DO 1210 J = 1, JEND, NRESOL
            DP(1, J) = SCIR(1, J) + DXI(1)
            DP(2, J) = SCIR(2, J) + DXI(2)
 1210     CONTINUE
          CALL PLA108 (1, 1, 1, 3)
          CALL PLA108 (NRES1, NRESOL, JEND, 2)
          IF (II .LT. 4) THEN
            DO 1220 J = 1, 3
              T1 = PAC(J, II0) * RMS(II0) * PAR(47)
              DAM(J, 1) = T1
              DAM(J, 2) = PAC(J, II1) * RMS(II1) * PAR(47)
              DAM(J, 3) = 0.0
 1220       CONTINUE
            IF (LINES .GT. 0) THEN
              DO 1230 I = 1, 3, 1
                DP(1, I) = DAM(1, I) + DXI(1)
                DP(2, I) = DAM(2, I) + DXI(2)
 1230         CONTINUE
              CALL PLA108 (1, 2, 3, 3)
              L = LINES - 1
              IF (L .GT. 0) THEN
                DO 1250 I = 1, L
                  T1 = FLOAT(I) / LINES
                  T3 = SQRT(1.0 - T1**2)
                  IF (MOD(I, 2) .NE. 0) THEN
                    M = I * 2
                    N = M - 1
                  ELSE
                    N = I * 2
                    M = N - 1
                  ENDIF
                  DO 1240 J = 1, 3
                    T4 = DAM(J, 1) * T1
                    SCIR(J, M) = T4
                    SCIR(J, N) = DAM(J, 2) * T3 + T4
 1240             CONTINUE
 1250           CONTINUE
                L = L * 2
                DO 1260 I = 1, L
                  DP(1, I) = SCIR(1, I) + DXI(1)
                  DP(2, I) = SCIR(2, I) + DXI(2)
 1260           CONTINUE
                CALL PLA108 (1, 1, L, -3)
              ENDIF
            ENDIF
          ENDIF
 1270   CONTINUE
 1280 CONTINUE
      CALL PLA115 (2, 0, 0.0, 0.0, 0)
      IF (IGBL(75) .GT. 0) IPR(201) = 1
      IF (IPR(478) .GT. 0 .AND. IPR(478) .EQ. IPR(116)) GOTO 80
      IF (LRET .EQ. 6) GOTO 1310
 1290 IF (IGBL(23) .EQ. 22) THEN
        CALL GGIP20 (0.0, 'CONTOUR-MAP', 11, 0.8, 5 + IGBL(68), 3,
     1               10.0, 0.2)
        GOTO 1340
      ENDIF
      NLOOP = 2
      CALL PLA013 (0, 1)
      IF (IGBL(3) .EQ. 28) LRET = 7
      IF (LRET .EQ. 1) THEN
        GOTO 1320
      ELSE IF (LRET .EQ. 2) THEN
        GOTO 80
      ELSE IF (LRET .EQ. 3) THEN
        GOTO 280
      ELSE IF (LRET .EQ. 4) THEN
        GOTO 20
      ELSE IF (LRET .EQ. 5) THEN
        CALL PLA115 (1, 0, 0.0, 0.0, 0)
        GOTO 1290
      ELSE IF (LRET .EQ. 6) THEN
        GOTO 1310
      ELSE IF (LRET .EQ. 7) THEN
        GOTO 1330
      ELSE IF (LRET .EQ. 8) THEN
        GOTO 10
      ENDIF
 1310 IF (LRET .EQ. 6 .AND. IWIN .EQ. 1) THEN
        XG = 0.0
        YG = 0.0
        ZG = 0.0
        IG = 9
        CALL GGIP (XG, YG, ZG, IG)
        IF (IG .EQ. 1) CC = .TRUE.
      ENDIF
      IPR(201) = 0
      IF (IPR(116) .EQ. 0) NLOOP = MOD(NLOOP + 1, 2)
      GOTO 70
 1320 CALL PLA006 (0, IS)
      IF (IS .EQ. 1) THEN
        WRITE (LU6, 99995)
        CALL PLA015 (0, 10)
        GOTO 1320
      ENDIF
      IF (IFL(1)(1:3) .EQ. 'REM') THEN
        IGBL(23) = 10
        IPR(351) = 0
        GOTO 1330
      ELSE IF (IFL(1)(1:3) .EQ. 'END' .OR.
     1         IFL(1)(1:4) .EQ. 'EXIT') THEN
        IF (IFL(1)(1:3) .EQ. 'END') REWIND LU2
        IF (IGBL(3) .EQ. 3) THEN
          IGBL(45) = -1
        ENDIF
        GOTO 1330
      ENDIF
      IF (IFL(1)(1:4) .EQ. 'DIST' .OR.
     1    IFL(1)(1:4) .EQ. 'ANGL' .OR.
     2    IFL(1)(1:4) .EQ. 'TORS') THEN
        IPR(81) = IPR(220)
        CALL PLA035 (1)
        GOTO 1290
      ENDIF
      IF (IFL(1)(1:3) .EQ. 'SET') THEN
        IF (IFL(2)(1:3) .EQ. 'REV') THEN
          IGBL(68) = MOD(IGBL(68) + 1, 2)
          CALL GGIP (-999.0, FLOAT(IGBL(68)), IGBL(62) * 0.25, 9)
          CALL GGIP (0.0, 0.0, 0.0, 6)
          IGGT = 'MENU ON'
          WRITE (LU6,*)'ENTER RETURN'
          READ (LU5, *)
          GOTO 1290
        ELSE
          ISW = 1
        ENDIF
      ELSE IF (IFL(1)(1:4) .EQ. 'LIST') THEN
        ISW = -1
        IF (IFL(2)(1:3) .EQ. 'ARU') THEN
          ISW = 0
          CALL PLA043 (0, -2, LU6, 0)
          CALL PLA013 (1, 1)
          IGBL(23) = 9
          GOTO 20
        ELSE IF (IFL(2)(1:3) .EQ. 'UIJ') THEN
          ISW = 0
          IGBL(23) = 9
        ELSE IF (IFL(2)(1:4) .EQ. 'ATOM') THEN
          ISW = 0
          IGBL(23) = 9
        ELSE IF (IFL(2)(1:4) .EQ. 'FLAG') THEN
          ISW = 0
          IGBL(23) = 9
        ELSE IF (IFL(2)(1:5) .EQ. 'RADII') THEN
          ISW = 0
          IGBL(23) = 9
        ENDIF
      ELSE IF (IFL(1)(1:4) .EQ. 'CALC') THEN
        ISW = 0
        IF (IFL(2)(1:4) .EQ. 'COOR') THEN
          IF (IFL(3)(1:6) .EQ. '******') GOTO 1320
        ENDIF
      ELSE
        ISW = 0
      ENDIF
      IF (ISW .NE. 0 .AND. IPR(220) .GT. 1) THEN
C * SET META TYPE
        IF (IFL(2)(1:3) .EQ. 'MET') THEN
          MEDIUM = 2
          IF (IPR(220) .GT. 2) CALL GGIP (-999.0, 0.0, 0.0, 6)
        ELSE
          CALL PLA206 (ISW, IFL(2)(1:3))
        ENDIF
        ISW = 0
        GOTO 1290
      ENDIF
      IF (IFL(1)(1:6) .EQ. 'PLUTON') THEN
        CALL PLA280 (IFL(1)(1:7))
      ELSE
        CALL PLA280 (ICL)
      ENDIF
 1330 CALL PLA034 (-1, NASUP)
 1340 IF (IGBL(3) .EQ. 3) IGBL(3) = 0
      RETURN
99999 FORMAT (':: Label Positioning Problem for ', A)
99998 FORMAT ('ATOM  ', I5, 1X, A, 2X, I5, 4X, 3F8.3, 2F6.2)
99997 FORMAT ('ANISOU', I5, 1X, A, 2X, I5, 2X, 6I7)
99996 FORMAT ('HEADER ', A)
99995 FORMAT ('>> UNKNOWN INSTRUCTION - IGNORED', /)
      END
      SUBROUTINE PLA107 (IQ, IA, MODE, PCQ)
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16,
     1 NP11=128,NP12=600,NP13=500,NP15=20,NP17=99,NP19=31,NP25=99,
     2 NP29=63,NP38=125,NP39=30,NP41=200,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      DIMENSION BF(4), CONX(3, 3), QF(5), QUA(3, 4)
      ITY = 0
      NATOM = IPR(39)
      NSUP  = IPR(64)
      NASUP = NATOM + NSUP
      NIA   = NASUP + IA
      NIQ   = NASUP + IQ
      ID    = NINT(CON(NIQ, 9))
      NA1   = ID / (NP1 + 1)
      NA2   = MOD(ID, NP1 + 1)
      PCQ = 0.0
      IF (MODE .NE. 0) THEN
        ITY = ITY + MODE
        IF (ITY .GT. 0) THEN
          OVMG = 0.0
        ELSE
          OVMG = PAR(44)
        ENDIF
        IF (ITY .GT. -2) THEN
          V1(1)      = (XXO(NIA, 1) + XXO(NIA, 2)) * 0.5
          V1(2)      = (XXO(NIA, 3) + XXO(NIA, 4)) * 0.5
          V1(3)      = 1.0
          CONX(1, 1) = XSD(NIA, 1)
          CONX(1, 2) = XSD(NIA, 2)
          CONX(2, 1) = XSD(NIA, 2)
          CONX(2, 2) = XSD(NIA, 3)
          TX = XXO(NIA, 2) - XXO(NIA, 1) + XXO(NIA, 4) - XXO(NIA, 3)
          CONX(3, 3) = - (1.0 - 4.0 * OVMG / TX)**2
          DO 20 K = 1, 2
            CONX(K, 3) = 0.0
            DO 10 J = 1, 2
              CONX(K, 3) = CONX(K, 3) - V1(J) * CONX(J, K)
   10       CONTINUE
            CONX(3, K) = CONX(K, 3)
            CONX(3, 3) = CONX(3, 3) - CONX(3, K) * V1(K)
   20     CONTINUE
        ENDIF
        IF (ITY .LT. 2) THEN
          DO 40 L = 1, 4
            K         = 2 * L
            K1        = MOD(K, 8) + 2
            QUA(1, L) = CON(NIQ, K)      - CON(NIQ, K1)
            QUA(2, L) = CON(NIQ, K1 - 1) - CON(NIQ, K - 1)
            QUA(3, L) = CON(NIQ, K - 1)  * CON(NIQ, K1) -
     1                  CON(NIQ, K)      * CON(NIQ, K1 - 1)
            T1 = SQRT(QUA(1, L)**2 + QUA(2, L)**2)
            IF (T1 .LE. 0.0) THEN
              ITY = 0
              GOTO 470
            ENDIF
            DO 30 J = 1, 3
              QUA(J, L) = QUA(J, L) / T1
   30       CONTINUE
   40     CONTINUE
        ENDIF
        V2(3) = 1.0
        V3(3) = 1.0
        T2    = 3.0
        DO 150 L = 1, 4
          L1    = (MOD(L, 4) + 1) * 2
          V2(1) = CON(NIQ, 2 * L - 1)
          V2(2) = CON(NIQ, 2 * L)
          V3(1) = CON(NIQ, L1 - 1)
          V3(2) = CON(NIQ, L1)
          QF(L) = 0.0
          BF(L) = 0.0
          DO 120 K = 1, 3
            T1 = CONX(3, K)
            DO 110 J = 1, 2
              T1 = T1 + V2(J) * CONX(J, K)
  110       CONTINUE
            QF(L) = QF(L) + T1 * V2(K)
            BF(L) = BF(L) + T1 * V3(K)
  120     CONTINUE
          IF (QF(L) .EQ. 0.0)  THEN
            T2 = T2 - 0.8
          ELSE IF (QF(L) .LT. 0.0) THEN
            T2 = T2 - 1.0
          ENDIF
  150   CONTINUE
        QF(5) = QF(1)
        IF (T2 .LT. 0.0) THEN
          ITYPE = -1
        ENDIF
        IF (T2 .GE. 2.2)  THEN
          DO 230 K = 1, 4
            T1 = BF(K)**2 - QF(K) * QF(K + 1)
            IF (T1 .GT. 0.0) THEN
              T1 = SQRT(T1)
              T3 = QF(K) - BF(K)
              T4 = T3 + QF(K + 1) - BF(K)
              IF (ABS(T4) .GT. PAR(54)) THEN
                T5 = (T3 - T1) / T4
                IF (T5 .GE. 0.0 .AND. T5 .LT. 1.0) THEN
                  ITYPE = 0
                  IF (NA2 .EQ. IA) THEN
                    GOTO 390
                  ELSE IF (NA2 .GT. IA) THEN
                    IF (NA1 .GE. IA) THEN
                      GOTO 390
                    ELSE
                      GOTO 300
                    ENDIF
                  ELSE
                    GOTO 300
                  ENDIF
                ENDIF
              ENDIF
            ENDIF
  230     CONTINUE
          T3 = 3.0
          DO 260 K = 1, 4
            T1 = QUA(3, K)
            DO 240 J = 1, 2
              T1 = T1 + V1(J) * QUA(J, K)
  240       CONTINUE
            IF (T1 .LT. 0.0) T3 = T3 - 1.0
  260     CONTINUE
          IF (T3 .GE. 0.0) GOTO 470
          ITYPE = 1
          IF (IA .GE. NA2 .OR. IA .LE. NA1) GOTO 390
        ELSE
          ITYPE = 0
          IF (NA2 .EQ. IA .OR. (NA2 .GT. IA .AND. NA1 .GE. IA)) GOTO 390
        ENDIF
  300   IF (ID .EQ. 0) GOTO 410
        DO 310 III = 1, 3
          V2(III) = XXO(NA2, III) - XXO(NA1, III)
          V3(III) = XXO(IA,  III) - XXO(NA1, III)
  310   CONTINUE
        CALL GEN007 (AA, V2, V2, 1)
        CALL GEN007 (AA, V3, V3, 1)
        CALL GEN011 (BB, V2, V3, V4, 1)
        IF (GEN009 (V4, V4) .LE. PAR(54)) THEN
          IF (ITY .GT. 0) THEN
            GOTO 410
          ELSE
            GOTO 470
          ENDIF
        ENDIF
        CALL GEN011 (BB, V4, V2, V5, 1)
        T1 = - V5(3)
        IF (T1 * FLOAT(ITY) .GT. 0.0) GOTO 470
  390   IF (ITYPE * ITY .LT. 0) THEN
          PCQ = -1.0
          GOTO 470
        ENDIF
  410   PCQ = 1.0
        IF (ITY .LT. 0) THEN
          IF (IPR(152) .LT. NP7) THEN
            IPR(152) = IPR(152) + 1
            DO 510 K = 1, 4
              DO 500 J = 1, 3
                XDIR(IPR(152), J, K) = QUA(J, K)
  500         CONTINUE
  510       CONTINUE
            IDIR(IPR(152)) = IQ
          ENDIF
        ELSE
          IF (IPR(151) .LT. NP15) THEN
            IPR(151) = IPR(151) + 1
            IJ = 1
            DO 460 I = 1, 3
              DO 450 J = I, 3
                XXO(IPR(174) + IPR(151), IJ) = CONX(I, J)
                IJ                           = IJ + 1
  450         CONTINUE
  460       CONTINUE
          ENDIF
        ENDIF
      ELSE
        ITY = 0
      ENDIF
  470 RETURN
      END
      SUBROUTINE PLA108 (IND1, IND2, IND3, NPEN)
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16,
     1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP25=99,NP29=63,
     2 NP38=125,NP39=30,NP41=200,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /PL108/ SEG(2), Y(3), YN(2), YO(2), Z(3)
      NASUP = IPR(39) + IPR(64)
      NCOVR = IPR(151)
      NQOVR = IPR(152)
      NCQ   = NCOVR + NQOVR
      NCO   = IPR(174)
      ZGGIP = 0.0
      LPEN  = IABS(NPEN)
      DO 760 INDX = IND1, IND3, IND2
        Y(1) = DP(1, INDX)
        Y(2) = DP(2, INDX)
        DO 40 J = 1, 2
          Y(J) = MAX (0.0, MIN (Y(J), PAR(36 + J)))
   40   CONTINUE
        IF (NCQ .EQ. 0) THEN
          CALL GGIP (Y(1), Y(2), ZGGIP, LPEN)
        ELSE
          IF (LPEN .EQ. 2) THEN
            YO(1) = YN(1)
            YO(2) = YN(2)
            DO 80 K = 1, NCQ
              XSD(NCO + K, 1) = XSD(NCO + K, 2)
   80       CONTINUE
            IF (NQOVR .GT. 0) THEN
              DO 110 K = 1, NQOVR
                DO 100 J = 1, 4
                  CON(NCO + K, J) = CON(NCO + K, J + 4)
  100           CONTINUE
  110         CONTINUE
            ENDIF
          ENDIF
          YN(1) = Y(1)
          YN(2) = Y(2)
          IF (NCOVR .GT. 0) THEN
            KBG  = NCO + 1
            KEND = NCO + NCOVR
            DO 150 K = KBG, KEND
              Z(1) = YN(1) * XXO(K, 1) + YN(2) * XXO(K, 2) + XXO(K, 3)
              Z(2) = YN(1) * XXO(K, 2) + YN(2) * XXO(K, 4) + XXO(K, 5)
              Z(3) = YN(1) * XXO(K, 3) + YN(2) * XXO(K, 5) + XXO(K, 6)
              XSD(K, 2) = Z(1) * YN(1) + Z(2) * YN(2) + Z(3)
              IF (LPEN .EQ. 2) THEN
                XSD(K, 5) = Z(1) * YO(1) + Z(2) * YO(2) + Z(3)
              ENDIF
  150       CONTINUE
          ENDIF
          IF (NQOVR .GT. 0) THEN
            KCQ = NCO + NCOVR
            DO 210 K = 1, NQOVR
              T2 = 3.0
              DO 200 J = 1, 4
                T1 = YN(1) * XDIR(K, 1, J) + YN(2) * XDIR(K, 2, J)
     1             + XDIR(K, 3, J)
                IF (T1 .LT. 0) T2 = T2 - 1.0
                CON(NCO + K, J + 4) = T1
  200         CONTINUE
              KCQ = KCQ + 1
              XSD(KCQ, 2) = T2
  210       CONTINUE
          ENDIF
          IF (LPEN .EQ. 3) GOTO 745
          DO 260 K = 1, NCQ
            IF (XSD(NCO + K, 1) .LT. 0.0 .AND.
     1          XSD(NCO + K, 2) .LT. 0.0) GOTO 745
  260     CONTINUE
          MINT = 0
          IF (NCOVR .GT. 0) THEN
            DO 320 K = 1, NCOVR
              NCOK = NCO + K
              T1 = XSD(NCOK, 5)**2 - XSD(NCOK, 1) * XSD(NCOK, 2)
              IF (T1 .GT. 0.0) THEN
                T1 = SQRT(T1)
                T2 = XSD(NCOK, 1) - XSD(NCOK, 5)
                T3 = T2 + XSD(NCOK, 2) - XSD(NCOK, 5)
                IF (ABS(T3) .GT. PAR(54)) THEN
                  T4 = (T2 - T1) / T3
                  T5 = (T2 + T1) / T3
                  IF (T4 .LT. 1.0 .AND. T5 .GT. 0.0) THEN
                    MINT               = MINT + 1
                    XSD(NCO + MINT, 3) = T4
                    XSD(NCO + MINT, 4) = T5
                  ENDIF
                ENDIF
              ENDIF
  320       CONTINUE
          ENDIF
          IF (NQOVR .GT. 0) THEN
            DO 510 K = 1, NQOVR
              I12 = 0
              KCQ = NCO + NCOVR + K
              SEG(1) = XSD(KCQ, 1)
              IF (SEG(1) .GE. 0.0) THEN
                SEG(1) = 1.0 - XSD(KCQ, 2)
                IF (SEG(1) .LE. 1.0) GOTO 370
              ENDIF
              I12 = 1
  370         DO 490 J = 1, 4
                T1 = CON(NCO + K, J)
                T2 = CON(NCO + K, J + 4)
                T3 = T1 - T2
                IF (T1 * T2 .LE. 0.0) THEN
                  IF (ABS(T3) .LE. PAR(54)) GOTO 510
                  T4 = (T1 * YN(1) - T2 * YO(1)) / T3
                  T5 = (T1 * YN(2) - T2 * YO(2)) / T3
                  J1 = 2 * (MOD(J, 4) + 1)
                  NIQ = NASUP + IDIR(K)
                  T6 = (T4 - CON(NIQ, 2 * J - 1)) *
     1               (CON(NIQ, J1 - 1) - T4) +
     2               (T5 - CON(NIQ, 2 * J)) * (CON(NIQ, J1) - T5)
                  IF (T6 .GT. -1.E-4) THEN
                    T1 = T1 / T3
                    IF (I12 .LT. 1) THEN
                      I12 = 1
                      SEG(1) = T1
                    ELSE IF (I12 .EQ. 1) THEN
                      I12 = 2
                      IF (T1 .GE. SEG(1)) THEN
                        SEG(2) = T1
                      ELSE
                        SEG(2) = SEG(1)
                        SEG(1) = T1
                      ENDIF
                    ELSE
                      IF (T1 .LT. SEG(1)) THEN
                        SEG(1) = T1
                      ELSE IF (T1 .GT. SEG(1)) THEN
                        IF (T1 .GT. SEG(2)) SEG(2) = T1
                      ENDIF
                    ENDIF
                  ENDIF
                ENDIF
  490         CONTINUE
              IF (I12 .GT. 1) THEN
                MINT               = MINT + 1
                XSD(NCO + MINT, 3) = SEG(1)
                XSD(NCO + MINT, 4) = SEG(2)
              ENDIF
  510       CONTINUE
          ENDIF
          IF (MINT .EQ. 0) THEN
            CALL GGIP (YN(1), YN(2), ZGGIP, 2)
            GOTO 750
          ELSE
            M  = MINT
  550       M  = M / 2
            IF (M .EQ. 0) GOTO 650
            K  = MINT - M
            J  = 1
  570       I  = J
  580       IM = I + M
            IF (XSD(NCO + I, 3) .LT. 0.0) THEN
              IF (XSD(NCO + IM, 3) .GT. 0.0) GOTO 640
              IF (XSD(NCO + I, 4) .LE. XSD(NCO + IM, 4)) GOTO 640
            ELSE
              IF (XSD(NCO + I, 3) .LE. XSD(NCO + IM, 3)) GOTO 640
            ENDIF
            CALL GEN018 (XSD(NCO + I, 3), XSD(NCO + IM, 3))
            CALL GEN018 (XSD(NCO + I, 4), XSD(NCO + IM, 4))
            I = I - M
            IF (I .GT. 0) GOTO 580
  640       J = J + 1
            IF (J .GT. K) THEN
              GOTO 550
            ELSE
              GOTO 570
            ENDIF
          ENDIF
  650     P0 = 0.0
          K  = 0
  660     K  = K + 1
          IF (K .GT. MINT) THEN
            P1 = 1.0
            GOTO 710
          ENDIF
          P1 = XSD(NCO + K, 3)
          IF (P1 .GE. 0.0 .AND. P1 .GT. P0)  GOTO 710
  690     P0 = MAX (P0, XSD(NCO + K, 4))
          IF (P0 .LT. 1.0) GOTO 660
          P0 = 1.0
  710     IF (P0 .GT. 0.0) THEN
            Z(1) = YO(1) * (1.0 - P0) + YN(1) * P0
            Z(2) = YO(2) * (1.0 - P0) + YN(2) * P0
            CALL GGIP (Z(1), Z(2), ZGGIP, 3)
            IF (P0 .GE. 1.0) GOTO 750
          ENDIF
          Z(1) = YO(1) * (1.0 - P1) + YN(1) * P1
          Z(2) = YO(2) * (1.0 - P1) + YN(2) * P1
          CALL GGIP (Z(1), Z(2), ZGGIP, 2)
          IF (P1 .LT. 1.0) GOTO 690
          GOTO 750
  745     CALL GGIP (YN(1), YN(2), ZGGIP, 3)
        ENDIF
  750   IF (NPEN .GT. 0) THEN
          LPEN = 2
        ELSE
          IF (LPEN .EQ. 3) THEN
            LPEN = 2
          ELSE
            LPEN = 3
          ENDIF
        ENDIF
  760 CONTINUE
      RETURN
      END
      SUBROUTINE PLA109 (MODE)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0
      COMMON /CGGT/ IGGT
      CHARACTER IGGT*80
      COMMON /MAN/ MANUAL(140), PLUMAN(116)
      CHARACTER MANUAL*65, PLUMAN*65
      DATA (MANUAL(I), I = 1, 18) /
     1 'NOMOVE                        Keep Coords as Input',
     2 'CALC (ALL)                    Exhaustive Derived Geometry',
     3 'END                           Normal End-of-Program',
     4 'STOP                          Forced End-of-Program',
     5 'QUIT                          Forced End-of-Program',
     6 'EXIT                          Forced End-of-Program',
     7 'ROUND ON/OFF (range)          Round On/Off (Def = ON, 2)',
     8 'PARENTHESES ON/OFF            Parenth. on/off Opt.(Def=ON)',
     9 'INCLUDE el1 (el2 .. )         Include Specified Element(s)',
     * 'EXCLUDE el1 (el2 .. )         Exclude Specified Element(s)',
     1 'INCLUDE METALS                Include Metal(s) Only',
     2 'EXCLUDE METALS                Exclude Metal(s) Only',
     3 'DOAC el1 (el2 ..)             Specify DO/AC Elements',
     4 'HBOND  (NORM) p1 p2 p3        Modify H-Bond Criteria',
     5 'GEOM at1                      Calc Dist and Angles for at1',
     6 'RING at1 at2 at3 (at4 ..)     Explicit ring specification',
     7 'LINE at1 at2                  Explicit Line specification',
     8 'FIT at11 at21 .. at1n at2n    FIT mol1 to Mol2'/
      DATA (MANUAL(I), I = 19, 36) /
     1 'INORG                         Force Inorganic Structure Type',
     2 'ORGA                          Force Organic Structure Type',
     3 'ORMA r11 r12 r13 .. r32 r33   CAD4-Orientation Matrix',
     4 'CALC INTRA                    Calculate Intramolecular Geom.',
     5 '     el1 p1 el2 p2 ..         Use Specified Elemental Radii',
     6 '     (A/U/E)WLSPL             Weighted Least-Squares',
     7 '     TOLA  p1                 Use Specified Tolerance Value',
     8 '     TOLEA p1                 Add Tol for EAlk/Alk-Non-M',
     9 '     TOLM  p1                 Add Tol for Metal-Metal',
     * '     NOTMA                    Do not Analyse Thermal Motion',
     1 '     NOBOND                   Do not Print Bond Data',
     2 '     NOANG                    Do not Print Angle Data',
     3 '     NOTOR                    Do not Print Torson Data',
     4 '     NOLSP                    Do not Print L.S.-planes',
     5 '     NORING                   Do not search for rings',
     6 '     MAXRING P1               Max RingSize ',
     7 '     NOSTD                    Do not Calculate s.u.',
     8 '     NOMOVE                   Do not Move Input Atom'/
      DATA (MANUAL(I), I = 37, 54) /
     1 '     NOSYMM                   Do not Apply any Symmetry',
     2 '     TOLP p1                  Max Dev. for Lspl Include',
     3 '     MAXDEV p1                Max Dev. from LSPL for Listing',
     4 '     NOSORT                   Do not SORT atoms',
     5 'CALC INTER (NOMOVE)           Calc. Inter-Mol. Geom with vdW.',
     6 '     TOLR p1                  Use Specified Tol. value  p1',
     7 '     el1 p1 (el2 p2 ..)       Use Spec. Contact Rad (p1 = 0)',
     8 'CALC HBONDS (NONA) P1 P2 P3   Calculate Hbonds [0.5,-.12,100]',
     9 'LIST RADII/CELL/SYMM          List Radii/Cell/Symm on Display',
     * 'INFO RADII/CELL/SYMM          List Radii/Cell/Symm on Display',
     1 'LIST ATOMS/BONDS (attyp)(res) List ATOMS/BONDS Data on Displ.',
     2 'INFO ATOMS/BONDS (attyp)(res) List ATOMS/BONDS Data on Displ.',
     3 'LIST UIJ                      List UIJ and U1, U2, U3',
     4 'INFO UIJ                      List UIJ and U1, U2, U3',
     5 'LIST IPR/PAR/IGBL (nr1 (nr2)) List Internal Parameters',
     6 'INFO IPR/PAR/IGBL (nr1 (nr2)) List Internal Parameters',
     7 'LIST FLAGS                    List Flag Array (Internal)',
     8 'INFO FLAGS                    List Flag Array (Internal)'/
      DATA (MANUAL(I), I = 55, 72) /
     1 'LIST GRAPHICS                 Display Graphics Status',
     2 'INFO GRAPHICS                 Display Graphics Status',
     3 'CALC GEOM (OMEGA/MOGLI/CSD/   Calc Bonds,Angles,Torsion only',
     4 '     EUCLID/SHELXL/PDB)       Opt. Generate Specified File',
     5 '     (NOMOVE) (EXPAND)        Output Expanded Molecule',
     6 '     (BOND) (ANGLE) (TORSION) Bonds Angles Torsion',
     7 'CALC TMA (CART)(HINC)         Thermal Motion Analysis only',
     8 '         (Rmax)               Maximum R-value (def. 0.25)',
     9 '         (Atmin)              Min Number of non-H atoms [6]',
     * 'SAVE                          Save instr. to be repeated',
     1 'CALC ADDSYM (el/EQUAL)(SAVE)  Test for Higher Symm. (for el)',
     2 '     (ang d1 d2)              Tolerances',
     3 'CALC NONSYM                   Test for Non-Cryst Symmetry',
     4 'CALC NEWSYM                   Test for additional symmetry',
     5 'LEPAGE                        Check for Higher Metrical Symm.',
     6 'EXPT                          Calc Expd # reflns for resoln',
     7 'CALC COORDN (p1)              Calc non-C,H Coordn with p1',
     8 '     (FIVE (tba))             Analyse for 5-coordn. (TBA)'/
      DATA (MANUAL(I), I = 73, 90) /
     1 '     (el1 p1 el2 p2 ..)       Coordn Calc for Specified Elem.',
     2 '     (NOANG)                  Suppress Angle Calculation',
     3 'CALC COORDN at1 p1 (NOANG)    Calc Coordination for Atom_name',
     4 'CALC METAL (p1)               Me-Me Scan (Def. = 10 Ang.)',
     5 'CALC DIST el (p1)             el-el Scan (Def. = 3 Ang.)',
     6 'DIST at1 at2                  Calc Specified Distance',
     7 'ANGL at1 at2 at3 (at4)        Calc Specified Angle',
     8 'TORS at1 at2 at3 at4          Calculate Spec. Torsion Angle',
     9 'LSPL at1 at2 at3 (at4 ..)     Explicit plane specification',
     * '     (DIST at3 ..)            Optional Additional Dist.',
     1 'PLOT (RING/PLAN/LSPL/RESD)    Gives L.S.-plane plot',
     2 '     (PERP/ALONG)             Perpendicular/Along',
     3 '     (DISPLAY/META)           Plot medium (Default DISPLAY)',
     4 'PLOT ADP                      Displacement Ellipsoid Plot',
     5 '     (COLOR)                  Color O, N and Halogen atoms',
     6 '     (ENVE/HETE/OCTA)         Ellipsoid Styles',
     7 '     (HATOM/NOHATOM)          Hatom/NoHatom Inclusion',
     8 '     (LABEL/NOLABEL)          Label/Nolabel Atoms'/
      DATA (MANUAL(I), I = 91, 108) /
     1 '     (PAREN/NOPAREn)          With/Without Parentheses',
     2 '     (MARGIN marg)            Overlap Margin (cm)',
     3 '     (RESIDUE resd)           Residue Number',
     4 '     (DISPLAY/META)           Plot medium (Default DISPLAY)',
     5 'PLOT NEWMAN (at1 at2)         NEWMAN-plot (Optional Bond)',
     6 '     (DISPLAY/META)(COLR)     Plot medium (Default DISPLAY)',
     7 'BOX (ON/OFF) (RATIO p1)       Outline and Text ON/OFF, ratio',
     8 'VIEW                          Default 0 0 0 setting',
     9 'VIEW (UNIT) XR p1 YR p2 ZR p3 Rot about XP,YP,ZP by p1,p2,p3',
     * 'VIEW MIN                      Minimum Overlap ADP Plot',
     1 'VIEW INVERT                   Invert Image',
     2 'SET PROB (10<-->90)           Set Probability Level (Def=50)',
     3 'SET IPR/PAR/IGBL/GL nr val    Set Parameter Values',
     4 'SET PRINTER LEVEL lev         Set Print Level (0/1/2/3/4)',
     5 'SET LABEL SIZE (size)         Set Label Size (ADP)',
     6 'SET WINDOW fraction           Set X-Window Size',
     7 'CALC SOLV                     Look for Solvent Acc Regions',
     8 '     (LIST)                   Print Sections'/
      DATA (MANUAL(I), I = 109, 126) /
     1 'CALC VOID (PROBE r) (PSTEP n) Look for holes',
     2 '     (LIST)                   Print Sections',
     3 'CALC SQUEEZE (ncyc)           Handle Solvent Area',
     4 'CALC FCF                      Generate Fo^2/Fc^2 CIF',
     5 'CALC DELABS (NOTHCOR)(NOCHECK)Empirical Absorption Correction',
     6 'ABSG mu (n1 n2 n3) (NOCHECK)  Gaussian Abs. Corr.',
     7 'ABST mu (NOCHECK)             Analytical Abs. Corr.',
     8 'TABLE (SU/CIF/AC/JA/IC)       Generate Publication Tables',
     9 '     (NOHATOM)                Exclude H-Atoms',
     * '     (NORESIDUE)              No Residue Split-up',
     1 'JOIN  at1 at2 (DASH/LDASH)    Add (DASHED) Bond to PLOT List',
     2 'DETACH at1 at2                Delete Bond from PLOT List',
     3 'DEFINE at1 TO at2 ..aTn       Add BOND to Center-of-Grav.',
     4 '    (DASH/LDASH)              (Optionally (long)dashed)',
     5 'RADII BONDS (NORMAL bt r/     Modify Normal Bond radii',
     6 '     TO METAL bt r/           Modify radii to metals',
     7 '     TO H bt r/               Modify radii involving H',
     8 '     ALL bt r/LIST)           Set ALL radii / List Radii'/
      DATA (MANUAL(I), I = 127, 135) /
     1 '                              (-6 < bt < 6, radii in Ang',
     2 'MENU (ON/OFF)                 X-Window Menu On/Off',
     3 'ELLIPSOID (C/H/Other)         Modify ellipsoid plot types',
     4 '          type (lines)        (type = 0/1)',
     5 'CONTOUR (FO/DIFF/SQUEEZE)     Contour Plot (Fo=default)',
     7 '         TNCP                 3 non-collinear points',
     8 '         abcd                 ax + by + cz = d ',
     9 '         BIS                  bisect',
     * '         PERP                 Perp. to the plane 3 points'/
      DATA (PLUMAN(I), I = 1, 18) /
     1 'ANGLE atom-name1 atom-name2 atom-name3',
     2 'ANGSTROM (scale)',
     3 'ARU (color)(aru1 (aru2) ..(resd))',
     4 'ARU NONE/UNIQUE/INTER/RESTORE',
     5 'ATOM atom-name x y z (pop sigx sigy sigz sigpop)',
     6 'BOX  (ON/OFF[ON]) (SHRINK shr)  (RATIO ratio)',
     7 'BWC TYPE atom-type bwc (atom-type bwc ..)',
     8 'BWC (on/off)',
     9 'CELL (wavelength) a b c alpha beta gamma',
     * 'COLOR BLACK/RED/GREEN/BLUE/YELLOW/ORANGE/VIOLET/BROWN',
     1 'COLOR TYPE atom-type col (atom-type col ..)',
     2 'COLOR RESD (ON/OFF)',
     3 'COLOR ARU  (ON/OFF)',
     4 'COLOR (ON/OFF)',
     5 'COORD atom-name',
     6 'CPK   (SHADE (a1 a2 (d))/',
     7 '  COLOR (a1 a2 (d))/NET (nh nv)/CONTOUR (n)/SEGMENT/',
     8 '  BLACK/BWCOL/DOTS/GLOBE/CROSS/PARAL/MERID) (STICK) (SPOT)'/
      DATA (PLUMAN(I), I = 19, 37) /
     1 'CROT(X/Y/Z)(M) (step (nstep)) (COLOR[off])',
     2 'DEFINE Me# TO atom-name1 atom-name2 atom-name3 ...',
     3 'DEFINE TO/CG atom-name1 atom-name2 atom-name3 ...',
     4 'DELETE atom-type/atom-name .../aru',
     5 'DETACH (atom-name/atom-type (TO) atom-name/atom-type)',
     6 'DIR',
     7 'DIST atom-name1 atom-name2 (aru)',
     8 'END/ENDS',
     9 'ENTRY (nr/refcode)',
     * 'EXCLUDE atom-names/atom-types/ALL/NONE/ORIG/UNIQUE/',
     1 '  INTER/ZOMBIES/aru/resd',
     2 'GEOM atom-name',
     3 'INCLUDE atom-names/atom-types/ALL/NONE/ORIG/UNIQUE/',
     4 '  INTER/ZOMBIES/aru/resd',
     5 'INORG',
     6 'JOIN RADII (UNIQUE (EXPAND) (NOMOVE)) (TOLE tole)',
     7 '  ((TOL tol)/(n1 r1 n2 r2 ...))',
     8 'JOIN RADII INTER (HBONDS/XBONDS)(EXPAND)',
     9 '  (TOL tol)/(n1 r1 n2 r2 ...)'/
      DATA (PLUMAN(I), I = 38, 55) /
     1 'JOIN atom-name TO atom-name(s) (aru)',
     2 'JOIN atom-names/atom-types',
     3 'JOIN (NONE/INTRA)',
     4 'LABEL atname1(aru) (atname2(aru)) (...) (attype3(aru)) (..)',
     5 'LABEL (ON/OFF)/ALL/NONE/(UNITCELL) (ATOMS) (ARU) ',
     6 '  ((NO)PARENTHESES) (FULL/NUM)',
     7 'LATT (P/A/B/C/I/F) (C/A)',
     8 'LIST (ATOMS)(BONDS)(GRAPHICS)(LINES)(MATR)(ARU)(STATUS)(TYPES)',
     9 'LIST ATOM (atom-name/atom-type/INTER)/(RESD nr)',
     * 'LIST BOND (atom-name1 atom-name2/INTER)/(RESD nr)',
     1 'LIST CELL/SYMM/FLAGS',
     2 'LIST PAR (nr1 (nr2))',
     3 'LIST IPR (nr1 (nr2))',
     4 'MONO (PERSP d)',
     5 'NOMOVE (OFF)',
     6 'NOSORT',
     7 'OMIT OUTSIDE (xmin xmax ymin ymax zmin zmax/atom-name rad/0)',
     8 'OMIT aru ...(resd)'/
      DATA (PLUMAN(I), I = 56, 73) /
     1 'ORGA',
     2 'OVERLAP (MARGIN mrg) (SHADOW shad)((ON/OFF)/BA/BB[ON])',
     3 'PACK PLAN h k l d1 d2 RANGE xmin .. zmax (atom-name)',
     4 'PACK (RANGE xmin xmax ymin ymax zmin zmax (atom-name))',
     5 'PLOT (DISPLAY/META) (MOGLI) (LIST) (3/2)',
     6 'PUT ARU/ATOM/atom-name/atom-type/OR/OA/OB/OC pos.',
     7 '(atom-name/atom-type/OR/OA/OB/OC position .. )',
     8 '  position: N, NE, E, SE, S, SW, W, NW, NUCL, AUTO',
     9 'QUIT/EXIT',
     * 'RADII ATOMS COVALENT/CPK/AUTO/ALL r',
     1 'RADII ATOMS atom-type1 r1 (atom-type2 r2 ... )',
     2 'RADII ATOMS atom-name1 r1 (atom-name2 r2 ... )',
     3 'RADII BONDS (DASH) ALL r n',
     4 'RADII BONDS (DASH) TO atom-name/atom-type r n',
     5 'RADII BONDS (DASH) atom-name1 atom-name2 r n',
     6 'RADII BONDS (DASH) INTER/NORMAL r n',
     7 'RADII BONDS TAPER t',
     8 'RENAME (atom-name/atom-type)/(at1 at2 (at3 at4 ..))'/
      DATA (PLUMAN(I), I = 74, 92) /
     1 'RESET',
     2 'RETRACE LABELS ((n) (d))',
     3 'ROD   (NUCL/SHADE (a1 a2 (d))/',
     4 '  COLOR (a1 a2 (d))/NET (nh nv)/CONTOUR/SEGMENT/',
     5 '  BLACK/BWCOL/DOTS/GLOBE/CROSS/PARAL/MERID) (SPOT)',
     6 'SAVE (AUTO)',
     7 'SEGMENT (plotstep (substep))',
     8 'SET (IPR/PAR) nr val',
     9 'SET WINDOW fraction',
     * 'SIZE sz (RATIO ra) (SCALE sc) (CHAR ch) (TITLE ti)',
     1 'SOLID (NUCL/SHADE (a1 a2 (d))/',
     2 '  COLOR (a1 a2 (d))/NET (nh nv)/CONTOUR (n)/SEGMENT/',
     3 '  BLACK/BWCOL/DOTS/GLOBE/CROSS/PARAL/MERID) (SPOT)',
     4 'SPGR space-group-name',
     5 'STEREO (SMALL) (RG/GR/RB/BR/CROSSED) (PERSP d)',
     6 'STICK (COLOR)',
     7 'STRAW (NUCL/SHADE (a1 a2 (d))/',
     8 '  COLOR (a1 a2 (d))/NET (nh nv)/CONTOUR (n)/SEGMENT/',
     9 'BLACK/BWCOL/DOTS/GLOBE/CROSS/PARAL/MERID) (SPOT)'/
      DATA (PLUMAN(I), I = 93, 110) /
     1 'STOP',
     2 'SYMM symmetry-operator',
     3 'TITL text',
     4 'TORSION atom-name1 atom-name2 atom-name3 atom-name4',
     5 'UNITCELL (OFF/ON) (rbo nli)',
     6 'UNLABEL (atom-names/atom-types/ALL/(UNITCELL) (ATOMS) (ARU)',
     7 'VIEW MATRIX r11,r12, .. ,r33 (rotations)',
     8 'VIEW MIN (rotations)',
     9 'VIEW UNIT (rotations)',
     * 'VIEW XO/YO/ZO (rotations)',
     1 'VIEW AFACE/BFACE/CFACE (rotations)',
     2 'VIEW ALIGN atom-name1 atom-name2 (ARU) WITH XP/YP (rotations)',
     3 'VIEW DIRECTION x y z (rotations)',
     4 'VIEW LINE atom-name1 atom-name2 (ARU/rotations)',
     5 'VIEW BISECT atom-name1 atom-name2 atom-name3 (rotations)',
     6 'VIEW PERP atom-name1 atom-name2 atom-name3 (rotations)',
     7 'VIEW CURRENT (rotations)',
     8 'VIEW INVERT (rotations)'/
      DATA (PLUMAN(I), I = 111, 116) /
     1 '  rotations:',
     2 '  (XROT xr)(YROT yr)(ZROT zr)(LROT lr x y z)(INVERT)',
     3 '  (OROT or x y z)(PROT pr x y z)(BROT br at-name1 at-name2)',
     4 'XROT xr',
     5 'YROT yr',
     6 'ZROT zr'/
      CALL GGIP (HORS, VERT, 0.0, 1)
      VRT = VERT
      HRT = HORS / 2.0
      IF (MODE .EQ. 1) THEN
        DO 10 I = 1, 127
          WRITE (LU6, 99999) MANUAL(I)
   10   CONTINUE
        DO 20 I = 1, 70
          VRT = VRT - 0.25
          CALL GGIP20 (0.0, MANUAL(I), 65, 0.2, 1, 1, 0.2, VRT)
   20   CONTINUE
        VRT = VERT
        DO 30 I = 71, 135
          VRT = VRT - 0.25
          CALL GGIP20 (0.0, MANUAL(I), 65, 0.2, 1, 1, HRT, VRT)
   30   CONTINUE
        CALL PLA013 (1, 1)
        IGGT = '!'
      ELSE
        DO 40 I = 1, 70
          VRT = VRT - 0.25
          CALL GGIP20 (0.0, PLUMAN(I), 65, 0.2, 1, 1, 0.2, VRT)
   40   CONTINUE
        VRT = VERT
        DO 50 I = 71, 116
          VRT = VRT - 0.25
          CALL GGIP20 (0.0, PLUMAN(I), 65, 0.2, 1, 1, HRT, VRT)
   50   CONTINUE
        DO 60 I = 1, 116
          WRITE (LU6, 99999) PLUMAN(I)
   60   CONTINUE
        CALL PLA013 (1, 1)
        IGGT = '!'
      ENDIF
      RETURN
99999 FORMAT (A)
      END
      SUBROUTINE PLA115 (MODE, NTYP, X, Y, LMOD)
      PARAMETER (NP4=9,NP10=16,NP12=600,NP13=500,NP17=99,NP22=256,
     1 NP38=125,NP39=30,NP45=2048)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /Q/ ICL, IFL(NP17)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /CGGT/ IGGT
      CHARACTER IGGT*80
      COMMON /CGG11/ BCD, SBCD
      CHARACTER BCD*132, SBCD*132
      COMMON /TPOS/ XTK(250, 3), NTK(25), KMX, IMIN
      COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0
      I    = 0
      IASU = 0
      XMAX = 0.0
      YMAX = 0.0
      IF (NTYP .EQ. 0) THEN
        XMAX = PAR(37)
        YMAX = PAR(38)
      ELSE IF (NTYP .EQ. 1) THEN
        XMAX = - PAR(61)
        YMAX = - PAR(62)
      ENDIF
   10 IF (MODE .EQ. 1) THEN
        IF (IWIN .EQ. 1) THEN
          I = IPR(447) + 1
          WRITE (SBCD, '(''Give Text[size ='', F5.2, '']'', A)')
     1          PAR(350), CHAR(0)
          CALL GEN038 (IGGT, 1, 80)
          CALL PLA013 (0, 0)
          TKST(I) = IGGT(1:10)
          LINE    = IGGT
          CALL GEN038 (ICL,  1, 80)
          CALL GEN038 (IGGT, 1, 80)
        ELSE
          CALL PLA285 (0, LU6, 'Give Text:')
          READ  (LU5, '(A)') LINE
        ENDIF
        IF (LINE(1:1) .EQ. '!'    .OR. LINE(1:4) .EQ. 'TEXT' .OR.
     1      LINE(1:4) .EQ. 'PLOT' .OR. LINE(1:3) .EQ. 'END'  .OR.
     2      LINE(1:3) .EQ. 'REM'  .OR. LINE(1:4) .EQ. 'EXIT') THEN
          IPR(453)  = 0
          IPR(448)  = 0
          LINE      = '!'
          IF (NTYP .EQ. 1) THEN
            IGBL(23) = 3
          ELSE
            IGBL(23) = 8
          ENDIF
          GOTO 60
        ENDIF
        IF (I .EQ. 1) THEN
          KMX = 0
        ENDIF
        IF (KMX .GT. 0) THEN
          DO 20 J = 1, KMX
            IF (NTK(J) .EQ. 0) THEN
              K = J
              GOTO 30
            ENDIF
   20     CONTINUE
        ENDIF
        KMX       = KMX + 1
        K         = KMX
   30   XTK(I, 1) = XMAX - 5.0
        XTK(I, 2) = YMAX - K
        NTK(K)    = 1
        XTK(I, 3) = PAR(350)
        IPR(447)  = I
        CALL GGIP20 (0.0, TKST(I), 10, XTK(I, 3), -1, 1,
     1               XTK(I, 1), XTK(I, 2))
        GOTO 10
      ELSE IF (MODE .EQ. 2) THEN
        IF (IPR(173) * IPR(447) .GT. 0) THEN
          DO 40 I = 1, IPR(447)
            CALL GGIP20 (0.0, TKST(I), 10, XTK(I, 3), 1, 1, XTK(I, 1),
     1                    XTK(I, 2))
   40     CONTINUE
        ENDIF
      ELSE IF (MODE .EQ. 3) THEN
        IASU = 0
        CALL PLA014 (3, NTYP, X, Y, ITEM, IASU)
        IF (ITEM .NE. 0) THEN
          CALL GGIP20 (0.0, TKST(ITEM), 10, XTK(ITEM, 3), 0, 1,
     1                  XTK(ITEM, 1), XTK(ITEM, 2))
          CALL GGIP (0.0, 1.0, 0.0, 0)
          IF (IPR(447) .GT. 1) THEN
            DO 50 I = 1, 3
              XTK(ITEM, I) = XTK(IPR(447), I)
   50       CONTINUE
            TKST(ITEM) = TKST(IPR(447))
          ENDIF
          IPR(447) = IPR(447) - 1
        ENDIF
      ELSE IF (MODE .EQ. 4) THEN
        CALL PLA014 (3, NTYP, X, Y, ITEM, IASU)
        IF (ITEM .NE. 0) THEN
          CALL GGIP20 (0.0, TKST(ITEM), 10, XTK(ITEM, 3), 0, 1,
     1                 XTK(ITEM, 1), XTK(ITEM, 2))
          XTK(ITEM, 3) = PAR(350)
          CALL GGIP20 (0.0, TKST(ITEM), 10, XTK(ITEM, 3), 1, 1,
     1                   XTK(ITEM, 1), XTK(ITEM, 2))
        ENDIF
      ELSE IF (MODE .EQ. 5) THEN
        IF (IPR(448) .NE. 0) THEN
          IF (IPR(447) .GT. 0) THEN
            IF (LMOD .EQ. 0) THEN
              CALL PLA014 (3, NTYP, X, Y, IMIN, IASU)
              XX = XTK(IMIN, 1)
              YY = XTK(IMIN, 2)
              LMOD = 1
              XN = - XTK(IMIN, 2) + YMAX
              N  =  NINT(-XTK(IMIN, 2) + YMAX)
              IF (ABS(XN - N) .LT. 0.05) THEN
                NTK(N) = 0
              ENDIF
            ELSE
              XX = - (NTYP * XMAX) + X
              YY =   YMAX - Y
              XTK(IMIN, 1) =  XX
              XTK(IMIN, 2) =  YY
              LMOD = 0
            ENDIF
            YGGIP = FLOAT(1 - LMOD)
            CALL GGIP20 (0.0, TKST(IMIN), 10, XTK(IMIN, 3),
     1                        NINT(YGGIP), 1, XX, YY)
          ENDIF
        ENDIF
      ENDIF
   60 RETURN
      END
      SUBROUTINE PLA117 (HORS, VERT, MODE)
      PARAMETER (NP4=9,NP10=16,NP12=600,NP13=500,NP17=99,NP22=256,
     1 NP38=125,NP39=30)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /NAMES/ NAME(8), EXTENS, PROGNM, FNLU1, FNLU16, RDTYPE
      CHARACTER NAME*80, EXTENS*9, PROGNM*28, FNLU1*80, FNLU16*80,
     1          RDTYPE*7
      COMMON /LITREF/ LREF
      CHARACTER LREF(25)*80
      IF (IGBL(103) .NE. 0) THEN
        CALL GGIP (0.0,  0.0,  0.0, 3)
        CALL GGIP (HORS, 0.0,  0.0, 2)
        CALL GGIP (HORS, VERT, 0.0, 2)
        CALL GGIP (0.0,  VERT, 0.0, 2)
        CALL GGIP (0.0,  0.0,  0.0, 2)
        P14 = 0.4
        IF (MODE .GE. 0) THEN
          IF (IPR(116) .EQ. 0 .AND. IABS(IGBL(23)) .NE. 25) THEN
            IF (IGBL(30) .EQ. 1) THEN
              CALL GGIP20 (0.0, 'NOMOVE FORCED', 13, P14, 3, 1,
     1                     HORS - 31 * P14, VERT - 0.15 - P14)
            ELSE
              IF (IGBL(60) .GT. 0) THEN
                CALL GGIP20 (0.0, 'INPUT ATOMS MOVED', 17, P14, 2, 1,
     1                       HORS - 35 * P14, VERT - 0.15 - P14)
              ENDIF
            ENDIF
          ENDIF
          IF (MODE .EQ. 1 .AND. IGBL(104) .EQ. 1 .AND.
     1                          IPR(116) .EQ. 0) THEN
            VRT = VERT - 1.0
            DO 10 I = 1, 2 + IPR(565)
              VRT = VRT - 0.4
              CALL GGIP20 (0.0, LREF(I), 79, 0.25, 5, 1, 1.0, VRT)
   10       CONTINUE
          ENDIF
          IROTX = NINT(GL(28))
          IROTY = NINT(GL(29))
          IROTZ = NINT(GL(30))
          IDET  = IGBL(87)
          IF (IDET .EQ. -1 .AND. IPR(116) .EQ. 0)
     1        CALL GGIP20 (0.0, 'INVERT', 6, P14, 3, 1,
     2        HORS - 16 * P14, VERT - 0.15 - P14)
          CALL GEN040 (IROTX, NQ1, IP)
          NQ1(IP + 1:IP + 2) = ' X'
          IP                 = IP + 2
          CALL GGIP20 (0.0, NQ1, IP, P14, -1, 1, HORS - IP * P14, 0.15)
          CALL GEN040 (IROTY, NQ2, IP)
          NQ2(IP + 1:IP + 2) = ' Y'
          IP                 = IP + 2
          CALL GGIP20 (90.0, NQ2, IP, P14, -1, 1, P14 + 0.15, VERT
     1                  - IP * P14)
          NQ3(1:1) = 'Z'
          CALL GGIP20 (0.0, NQ3, 1, P14, -1, 1, 0.15, 0.15)
          CALL GEN040 (IROTZ, NQ3, IP)
          CALL GGIP20 (0.0, NQ3, IP, P14, -1, 1, 0.15 + 2 * P14, 0.15)
          IF (MODE .EQ. 1) THEN
            NQ1 = 'PROBA= '
            CALL GGIP20 (0.0, NQ1, 6, P14, -1, 1, HORS - 9 * P14,
     1                  VERT - 0.15 - P14)
            IPRB = IPR(45) * 10
            CALL GEN040 (IPRB, NQ1, IP)
            CALL GGIP20 (0.0, NQ1, IP, P14, -1, 1, PAR(37) - 2 * P14,
     1                   PAR(38) - 0.15 - P14)
          ENDIF
          IF (IABS(IGBL(23)) .NE. 25) THEN
            NQ1 = 'RES=   '
            CALL GGIP20 (0.0, NQ1, 4, P14, -1, 1, HORS - 14 * P14,
     1                   0.15)
            CALL GEN040 (IPR(140), NQ1, IP)
            CALL GGIP20 (0.0, NQ1, 2, P14, -1, 1, HORS - 8 * P14,
     1                   0.15)
          ENDIF
        ENDIF
        NJID = MAX (74, NINT(HORS / 0.4) - 12)
        CALL GGIP20 (0.0,  JID, NJID, 0.4, -1, 1, 3.0, 0.15)
        CALL GEN040 (IGBL(9), NQ2, IP)
        IF (MODE .LT. 0) THEN
          VR = 0.5
        ELSE
          VR = 1.5
        ENDIF
        CALL GGIP20 (90.0, PROGNM//' - ('//NQ2(1:IP)//')',
     1               IP + 33, 0.4, -1, 1, 0.6,  VR)
      ENDIF
      RETURN
      END
      SUBROUTINE PLA118 (N, LRETN, CELL, FA)
      COMMON /PL118/ M
      DIMENSION CELL(*), FA(*)
      IF (N .NE. 0) THEN
        CELL(N)     = FA(1)
        CELL(6 + N) = FA(2)
        M = M + 1
        IF (M .EQ. 6) LRETN = 2
      ELSE
        M     = 0
        LRETN = 1
      ENDIF
      RETURN
      END
      SUBROUTINE PLA119 (MODE)
      PARAMETER (NP4=9,NP10=16,NP12=600,NP13=500,NP17=99,NPVD=40000000,
     1           NP22=256,NP23=18000,NP38=125,NP39=30,MM=10)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9,  IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0
      COMMON /CGGT/ IGGT
      CHARACTER IGGT*80
      COMMON /PAGENM/ PAGET, PAGEIND(25)
      CHARACTER PAGET*8, PAGEIND*8
      COMMON /PL120/ TWM(3, 3, 4), IHKLR(3, 4), IHKLD(3, 4), SCL, IADR,
     1 NREF, NTW(4), DRVAL(4), NADR, HMAX, KMAX, LMAX, MTWIN(8), NTWIN,
     2 BASFM(4)
      COMMON /PL138/ IHKLS(5, 48), PHIS(48), NSYM, NSYMH, MHK, MPH,
     1  ICNTR, IND1, IND2, IND3
      COMMON // JNSC(2, NP23), VOID(NPVD)
      DIMENSION STAT(20, 9)
      INTEGER HMAX
      REWIND LU16
      IWIN  = IGBL(25) * IGBL(32)
      DO 20 I = 1, 20
        DO 10 J = 1, 9
          STAT(I, J) = 0.0
   10   CONTINUE
   20 CONTINUE
      SIGK = 0.0
      CALL PLA080
      CALL PLA042 (2)
      IF (IGBL(29) .LE. 0 .OR. IPR(594) .NE. 0) CALL PLA287 (1, 1, 0)
      IF (MODE .LE. 1) THEN
        IF (MODE .EQ. -1) THEN
          PAGET = 'BIJVOET'
          CALL PLA269 (0)
          IPR(2) = -1
        ELSE IF (MODE .EQ. 1) THEN
          PAGET = 'TWINROTM'
          CALL PLA269 (0)
          WRITE (LU7, 99998)
          IGBL(23) = 25
        ELSE IF (MODE .EQ. 0) THEN
          PAGET  = 'ANALVAR'
          CALL PLA269 (0)
          IPR(2) = -1
        ENDIF
        WRITE (LU6, 99997) PAR(227), PAR(228)
        WRITE (LU7, 99996) RLWS(1)
      ENDIF
      CALL PLA293 (PAR(17), 0)
      IPR(132) = -1
      IEND     = -1
      STOT     = 0.0
      NTOT     = 0
      NADR     = 0
      FOKM     = 0.0
      IND1     = 1
      IND2     = 2
      IND3     = 3
      NSYM     = IPR(48)
      NSYMH    = IPR(255)
      ICNTR    = IPR(257)
      IF (IPR(259) .EQ. 5 .OR. IPR(259) .EQ. 6) THEN
        IHEXL = 1
      ELSE
        IHEXL = 0
      ENDIF
      HMAX   = -999
      KMAX   = -999
      LMAX   = -999
      SUMFOK = 0.0
      SUMFCK = 0.0
   30 CALL PLA132 (IH, IK, IL, FOK, SIG, CALI, FCK, ACALS, BCALS,
     1             ACOR, IEND)
      IF (IEND .NE. 1) THEN
        IF (IH .NE. 0 .OR. IK .NE. 0 .OR. IL .NE. 0) THEN
          IF (IGBL(29) .LE. 0 .OR. IPR(594) .NE. 0) THEN
            ACAL = 0.0
            BCAL = 0.0
            CALL PLA131 (IH, IK, IL, ACAL, BCAL, ACALA, BCALA, YUNK)
            FCK = (ACAL + ACALA) ** 2 + (BCAL + BCALA) ** 2
          ENDIF
          VOID(NADR + 1)  = IH
          VOID(NADR + 2)  = IK
          VOID(NADR + 3)  = IL
          VOID(NADR + 4)  = FOK
          VOID(NADR + 5)  = FCK
          VOID(NADR + 6)  = SIG
          VOID(NADR + 8)  = 0.0
          VOID(NADR + 9)  = 0.0
          VOID(NADR + 10) = 0.0
          SUMFOK          = SUMFOK + FOK
          SUMFCK          = SUMFCK + FCK
          NADR            = NADR   + MM
          HMAX = MAX (HMAX, IABS(IH))
          KMAX = MAX (KMAX, IABS(IK))
          IF (IHEXL .EQ. 1) THEN
            HMAX = MAX (KMAX, HMAX, IABS(IH + IK))
            KMAX = HMAX
          ENDIF
          LMAX = MAX (LMAX, IABS(IL))
          GOTO 30
        ENDIF
      ENDIF
      NREF = NADR / MM
      IF (NREF .EQ. 0) THEN
        WRITE (LU6, 99999)
      ELSE
        IF (IGBL(29) .LE. 0) THEN
          SCALE = SUMFCK / SUMFOK
        ELSE
          SCALE = 1.0
        ENDIF
        NADR = 0
        DO 40 I = 1, NREF
          IH  = NINT(VOID (NADR + 1))
          IK  = NINT(VOID (NADR + 2))
          IL  = NINT(VOID (NADR + 3))
          STL = SQRT(GEN095 (PAR(191), IH, IK, IL))
          ST  = STL * PAR(17)
          IF (ST .LT. 1.0) THEN
            TH = ASIN (ST) * GL(5)
          ELSE
            TH = 0.0
          ENDIF
          FOK  = VOID (NADR + 4) * SCALE
          FOKM = MAX (FOKM, FOK)
          FCK  = VOID (NADR + 5)
          SIG  = VOID (NADR + 6) * SCALE
          IF (SIG .GT. 0.0)  THEN
            SIGK = SIG**2
            IF (PAR(227) .GT. 0.0) THEN
              P    = (MAX(FOK, 0.0) + 2.0 * FCK) / 3.0
              SIGK = SIGK + (PAR(227) * P)**2 + PAR(228) * P
            ENDIF
          ENDIF
          IF (SIG .NE. 0.0) THEN
            VOID(NADR + 8) = MAX ((FOK - FCK) / SIG, 0.0)
            VOID(NADR + 9) = (FOK - FCK) / SQRT(SIGK)
          ENDIF
          VOID (NADR + 4) = FOK
          VOID (NADR + 6) = SIG
          VOID (NADR + 7) = TH
          N          = MAX (1, MIN (20, INT(STL * 20 + 0.5)))
          STAT(N, 1) = STAT(N, 1) + ABS(FOK)
          STAT(N, 2) = STAT(N, 2) + ABS(FCK)
          STAT(N, 3) = STAT(N, 3) + 1.0
          STAT(N, 4) = STAT(N, 4) + SQRT(ABS(FOK))
          STAT(N, 5) = STAT(N, 5)
     1               + ABS(SQRT(ABS(FOK)) - SQRT(ABS(FCK)))
          STAT(N, 6) = STAT(N, 6) + (FOK - FCK) ** 2 / SIGK
          STAT(N, 7) = STAT(N, 7) + FOK ** 2 / SIGK
          NADR = NADR + MM
   40   CONTINUE
        IF (IPR(259) .EQ. 4) THEN
          HMAX = MAX (HMAX, KMAX)
          KMAX = HMAX
        ELSE IF (IPR(259) .EQ. 7) THEN
          HMAX = MAX (HMAX, KMAX, LMAX)
          KMAX = HMAX
          LMAX = HMAX
        ENDIF
        SCL = 10 ** (INT(ALOG (10000000 / FOKM) / ALOG (10.0)))
        IF (MODE .NE. 2) THEN
          WRITE (LU6, 99995) HMAX, KMAX, LMAX
          CALL PLA269 (2)
          WRITE (LU7, 99995) HMAX, KMAX, LMAX
          IHEAD = 0
          IF (PAR(227) .GT. 0.0) WRITE (LU7, 99990) PAR(227), PAR(228)
          DO 50 I = 1, 20
            IF (STAT(I, 3) .NE. 0.0 .AND. STAT(I, 7) .NE. 0.0 .AND.
     1          STAT(I, 4) .NE. 0.0) THEN
              R1   = STAT(I, 5) / STAT(I, 4)
              R2   = SQRT(STAT(I, 6) / STAT(I, 7))
              S    = SQRT(STAT(I, 6) / STAT(I, 3))
              STOT = STOT + STAT(I, 6)
              NTOT = NTOT + NINT(STAT(I, 3))
              IF (IHEAD .EQ. 0) THEN
                WRITE (LU7, 99994)
                IHEAD = 1
              ENDIF
              WRITE (LU7, 99993) I / 20.0, NINT(STAT(I, 3)), R1, R2, S
            ENDIF
   50     CONTINUE
          STOT = SQRT(STOT / NTOT)
          WRITE (LU7, 99992) STOT
C * NORMAL PROBABILITY PLOT
          CALL PLA269 (0)
          DO 60 I = 1, NREF
            VOID(NADR + I) = VOID(I * MM - 1)
   60     CONTINUE
          WRITE (LU7, 99991)
          IF (PAR(227) .GT. 0.0) WRITE (LU7, 99990) PAR(227), PAR(228)
          CALL PLA282 (2, VOID(NADR + 1), VOID(NADR + NREF + 1), NREF,
     1                 LU7)
        ENDIF
        IF (MODE .NE. 0) THEN
C * ANALYSE FOR TWINNING
          IF (MODE .GT. 0) THEN
            CALL PLA120 (MODE)
C * ANALYSIS OF BIJVOET-PAIRS
          ELSE IF (MODE .EQ. -1) THEN
            CALL PLA124
          ENDIF
        ENDIF
      ENDIF
      IGGT = ' '
      RETURN
99999 FORMAT (/, ':: No Reflections found')
99998 FORMAT (/, 'TwinRotMat: Analysis of the Fo/Fc CIF for Unaccounted'
     1        ,' (Non)Merohedral Twinning', /, 80('='), /)
99997 FORMAT (':: W1, W2 =', 2F10.4)
99996 FORMAT (/, A, /)
99995 FORMAT (/, ':: Hmax =', I5, ', Kmax =', I5, ', Lmax =', I5)
99994 FORMAT (/, 4X, 'STL    #      R1     wR2       S', /,
     1        3X, 33('='))
99993 FORMAT (F7.2, I5, 3F8.3)
99992 FORMAT (/, ':: S =', F10.3)
99991 FORMAT ('NPP for (Fobs**2 - Fcalc**2) / Sigma(Fobs**2)')
99990 FORMAT (/, ':: Sigma includes SHELXL WGHT Par.', 2F10.4, /)
      END
      SUBROUTINE PLA120 (MODE)
      PARAMETER (NP4=9,NP10=16,NP12=600,NP13=500,NP17=99,NPVD=40000000,
     1           NP22=256,NP23=18000,NP38=125,NP39=30,NP45=2048,MM=10)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9,  IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /LEPAG/ AXES(15, 23), TM(3, 3), CL(3, 5), TP(3, 3),
     1 TG(3, 3), TPQ(3, 3), TPS(3, 3), G(3, 3), OR(3, 3), ROTQ(3, 3),
     2 TRMXT (3, 3), T(3), H(3), TC(6), CELL(7), OCELL(7), RCELL(7),
     3 IDET, NVEC
      COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0
      COMMON /CGG11/ BCD, SBCD
      CHARACTER BCD*132, SBCD*132
      COMMON /CGGT/ IGGT
      CHARACTER IGGT*80
      COMMON /Q/ ICL, IFL(NP17)
      CHARACTER ICL*(NP45), IFL*7
      COMMON /PL120/ TWM(3, 3, 4), IHKLR(3, 4), IHKLD(3, 4), SCL, IADR,
     1 NREF, NTW(4), DRVAL(4), NADR, HMAX, KMAX, LMAX, MTWIN(8), NTWIN,
     2 BASFM(4)
      COMMON /PL138/ IHKLS(5, 48), PHIS(48), NSYM, NSYMH, MHK, MPH,
     1  ICNTR, IND1, IND2, IND3
      COMMON /PLA22/ LGR(12), XSYST(8), IBVL(8), LAT(7)
      CHARACTER LGR*5, XSYST*12, IBVL*1, LAT*1
      COMMON // JNSC(2, NP23), VOID(NPVD)
      DIMENSION IHKL(3), ORT(3, 3), V(3), TAU(3)
      DIMENSION XX(12), ALPHA(4), NFRQ(4), SDAT(500), ISDAT(500)
      INTEGER HMAX
C * ANALYSE FOR TWINNING FROM REFLECTION OVERLAP
      CALL GEN044 (PAR(101), OR)
      CALL GEN005 (OR, ORT)
      CALL GEN003 (ORT, ROTQ, DET, 0)
      IEXT  = 0
      IASM  = 0
      NSEL  = 0
      NVCX  = 0
      NADR  = NREF * MM
      NSYMR = NSYMH * ICNTR
      IBRV  = IPR(241)
      IF (IBRV .EQ. 7) THEN
        IBLP = 2
      ELSE
        IBLP = 1
      ENDIF
      LINV = 3 - ICNTR
      MPH   = 2 * HMAX + 1
      MPK   = 2 * KMAX + 1
      MPL   = 2 * LMAX + 1
      MHK   = MPH * MPK
      MHKL  = MPL * MHK
      MHKLH = (MHKL - 1) / 2
      IADR  = NPVD - MHKLH
      IADR1 = NPVD - MHKL
      DO 10 I = 1, MHKL
        IEXT = 0
        IH   = I - 1
        IL   = IH / MHK
        IH   = IH - IL * MHK
        IL   = IL - LMAX
        IK   = IH / MPH
        IH   = IH - IK * MPH - HMAX
        IK   = IK - KMAX
        IF (IBRV .GT. 1) THEN
          IF (GEN049 (LAT(IBRV), IH, IK, IL) .LT. 0.0) IEXT = 1
        ENDIF
        IF (IEXT .EQ. 0) CALL PLA139 (IH, IK, IL, IEXT, IASM)
        VOID(IADR1 + I) = - FLOAT (IEXT)
   10 CONTINUE
      DO 40 K = 1, LINV
        DO 30 I = 1, NREF
          IMM   = (I - 1) * MM
          XX(1) = VOID(IMM + 1)
          XX(2) = VOID(IMM + 2)
          XX(3) = VOID(IMM + 3)
          DO 20 NS = 1, NSYMR
            CALL SGSM (LINE, NS, XX, LU7, 5, IER)
            IH    = NINT(XX(7))
            IK    = NINT(XX(8))
            IL    = NINT(XX(9))
            IHKLP = IL * MHK + IK * MPH + IH
            IF (K .EQ. 1) THEN
              IF (VOID(IADR + IHKLP) .EQ. 0.0) VOID (IADR + IHKLP) = I
            ELSE
              IF (VOID(IADR - IHKLP) .EQ. 0.0) VOID (IADR - IHKLP) = I
            ENDIF
   20     CONTINUE
   30   CONTINUE
   40 CONTINUE
   50 IF (IWIN .EQ. 1 .AND. MODE .EQ. 1) CALL GGIP (HORS, VERT, 0.0, 1)
      NLIST    = 0
      IF (IPR(259) .EQ. 2) THEN
        IPR(394) = 2
      ELSE
        IPR(394) = 3
      ENDIF
      CALL GEN097 (NTW, 1, 4, 0)
   60 NSEL = 0
      DO 70 I = 1, NREF
        IMM = (I - 1) * MM
        IF (VOID(IMM + 8) .GT. PAR(413) .AND.
     1      VOID(IMM + 7) .GT. 0.0) THEN
          IF (NSEL .LT. 500) THEN
            NSEL        = NSEL + 1
            SDAT(NSEL)  = 100000.0 - VOID(IMM + 8)
            ISDAT(NSEL) = I
          ELSE
            IF (PAR(413) .LT. 32.0) THEN
              PAR(413) = PAR(413) * 2.0
              GOTO 60
            ELSE
              GOTO 80
            ENDIF
          ENDIF
        ENDIF
   70 CONTINUE
   80 IF (NSEL .GT. 1) CALL GEN013 (SDAT, ISDAT, 1, NSEL)
      NSEL = MIN (NSEL, IPR(550))
      IF (NSEL .EQ. 0) THEN
        GOTO 340
      ELSE
        IF (IWIN .EQ. 1 .AND. MODE .EQ. 1) THEN
          CALL GGIP20 (0.0, 'WorkinG', 7, 3.0, 2, 10, 5.0, 8.0)
          CALL GGIP (0.0, 0.0, 0.0, 6)
        ENDIF
      ENDIF
      IF (MODE .NE. 2) THEN
        WRITE (LU6, 99979)
        WRITE (LU6, 99988)
        CALL PLA269 (0)
        IF (IPR(469) .NE. 0) THEN
          WRITE (LU7, 99984)
          CALL PLA269 (2)
        ENDIF
        WRITE (LU7, 99988)
        CALL PLA269 (3)
      ENDIF
      NVC = 0
      NX  = NP23 / 2
      DO 180 I = 1, NSEL
        IMM = (ISDAT(I) - 1) * MM
        THI = VOID(IMM + 7)
        IHI  = NINT(VOID(IMM + 1))
        IKI  = NINT(VOID(IMM + 2))
        ILI  = NINT(VOID(IMM + 3))
        FOKI = VOID(IMM + 4)
        FCKI = VOID(IMM + 5)
        SIGI = VOID(IMM + 6)
        DELS = VOID(IMM + 8)
        DELI = FOKI - FCKI
        IF (MODE .NE. 2) THEN
          WRITE (LU6, 99985) IHI, IKI, ILI, FOKI, FCKI, SIGI, DELS, THI
          CALL PLA269 (1)
          IF (IPR(469) .NE. 0) THEN
            CALL PLA269 (2)
            WRITE (LU7, 99978)
          ENDIF
          WRITE (LU7, 99985) IHI, IKI, ILI, FOKI, FCKI, SIGI, DELS, THI
          IF (IPR(469) .NE. 0) THEN
            CALL PLA269 (1)
            WRITE (LU7, 99979)
          ENDIF
        ENDIF
        DO 170 J = 1, NREF
          JMM = (J - 1) * MM
          THJ = VOID(JMM + 7)
          DTH = THI - THJ
          IF (ABS(DTH) .LT. PAR(414) .AND. THJ .GT. 0.0) THEN
            DO 90 K = 1, 3
              XX(K) = VOID(JMM + K)
   90       CONTINUE
            XX(4) = 0.0
            FOKJ  = VOID(JMM + 4)
            FCKJ  = VOID(JMM + 5)
            SIGJ  = VOID(JMM + 6)
            IF (FCKJ - FCKI .GT. SIGJ) THEN
              DELSJ = (FOKJ - FCKJ) / SIGJ
              DO 160 NS = 1, NSYMR
                CALL SGSM (LINE, NS, XX, LU7, 5, IER)
                DO 150 ILP = 1, IBLP
                  IF (ILP .EQ. 1) THEN
                    IHJ = NINT(XX(7))
                    IKJ = NINT(XX(8))
                    ILJ = NINT(XX(9))
                  ELSE
                    IHJ = - NINT(XX(8))
                    IKJ = NINT(XX(7)) + NINT(XX(8))
                    ILJ = NINT(XX(9))
                    IF (MOD(-IHJ + IKJ + ILJ, 3) .EQ. 0) GOTO 150
                  ENDIF
                  DO 140 LIV = 1, LINV
                    IF (LIV .EQ. 2) THEN
                      IHJ = - IHJ
                      IKJ = - IKJ
                      ILJ = - ILJ
                    ENDIF
                    IHKL(1) = IHI + IHJ
                    IHKL(2) = IKI + IKJ
                    IHKL(3) = ILI + ILJ
                    IF (IHKL(1) .LT. 0) THEN
                      IHKL(1) = - IHKL(1)
                      IHKL(2) = - IHKL(2)
                      IHKL(3) = - IHKL(3)
                    ELSE IF (IHKL(1) .EQ. 0) THEN
                      IF (IHKL(2) .LT. 0) THEN
                        IHKL(2) = - IHKL(2)
                        IHKL(3) = - IHKL(3)
                      ELSE IF (IHKL(2) .EQ. 0) THEN
                        IHKL(3) = IABS(IHKL(3))
                      ENDIF
                    ENDIF
                    CALL GEN107 (IHKL, 3, IYUNK)
                    IHKLP = IHKL(1)
     1                    + 200 * (IHKL(2) + 200 * IHKL(3))
                    IF (IHKLP .NE. 0) THEN
                      IF (NVC .GT. 0) THEN
                        DO 110 N = 1, NVC
                          ISN = 1
                          DO 100 K = 1, LINV
                            IF (IHKLP .EQ. ISN * JNSC(2, NX + N))
     1                        GOTO 130
                            ISN = -1
  100                     CONTINUE
  110                   CONTINUE
                      ENDIF
                      IF (NVC .LT. NX - 1) THEN
                        NVC                   = NVC + 1
                        N                     = NVC
                        JNSC(1, NVC)          = 10000
                        JNSC(2, NVC)          = NVC
                        JNSC(1, NX + NVC)     = 0
                        JNSC(2, NX + NVC)     = IHKLP
                      ENDIF
  130                 JNSC(1, N) = JNSC(1, N) - 1
                      DELJ = FCKJ - FCKI
                      ALFA = MIN (DELI / DELJ, 1.0)
                      IF (ALFA .GE. PAR(416)) THEN
                        IF (IPR(469) .NE. 0) THEN
                          CALL PLA269 (1)
                          WRITE (LU7, 99986) IHJ, IKJ, ILJ,
     1                      FOKJ, FCKJ, SIGJ, DELSJ, THJ, DTH, ALFA,
     2                      IHKL(1), IHKL(2), IHKL(3)
                        ENDIF
                        JNSC(1, NX + N) = JNSC(1, NX + N)
     1                                  + NINT (ALFA * 100.0)
                      ENDIF
                    ENDIF
  140             CONTINUE
  150           CONTINUE
  160         CONTINUE
            ENDIF
          ENDIF
  170   CONTINUE
  180 CONTINUE
      NVCX  = 0
      IF (NVC .GT. 0) THEN
        IPR(543) = 0
        CALL GEN037 (JNSC, 1, NVC)
        NMIN  = 1
        NTWIN = 0
        DO 320 I = 1, NVC
          IF (NVCX .EQ. 4) GOTO 330
          NFRQ(NVCX + 1) = 10000 - JNSC(1, I)
          IF (NFRQ(NVCX + 1) .GT. NMIN) THEN
            XHKL = JNSC(2, JNSC(2, I) + NX)
            CALL GEN046 (XHKL, H(1), H(2), H(3))
            IHKLSUM = 0
            DO 190 J = 1, 3
              IHKLR(J, NVCX + 1) = NINT(H(J))
              IHKLSUM = IHKLSUM + NINT(H(J))
  190       CONTINUE
            CALL GEN002 (2, ROTQ, H, TAU, XLNG)
            IF (ABS(TAU(1)) + ABS(TAU(2)) .LT. 0.0001) THEN
              OME = 0.0
              CHI = 90.0 / GL(5)
            ELSE
              OME = ATAN2 (TAU(2), TAU(1))
              CHI = ATAN2 (TAU(3), SQRT(TAU(1)**2 + TAU(2)**2))
            ENDIF
            CALL GEN043 (3, TP, OME)
            CALL GEN043 (2, TG, - CHI)
            CALL GEN004 (TG, TP, TM)
            PHI = 180.0 / GL(5)
            CALL GEN043 (1, G, PHI)
            CALL GEN004 (G, TM, TPS)
            CALL GEN005 (TM, TM)
            CALL GEN004 (TM, TPS, TPQ)
            CALL GEN004 (TPQ, ROTQ, TPS)
            CALL GEN004 (ORT, TPS, TWM(1, 1, NVCX + 1))
            IF (NSYMH .GT. 1 .AND. NVCX .GT. 0) THEN
              DO 210 J = 1, 3
                DO 200 K = 1, 3
                  TM(J, K) = TWM(J, K, NVCX + 1)
  200           CONTINUE
  210         CONTINUE
              DO 270 J = 2, NSYMR
                NS = J
                CALL SGSM (LINE, NS, XX, LU6, 6, IER)
                DO 220 K = 1, 9
                  N = INT ((K - 1) / 3) + 1
                  M = MOD (K - 1 , 3) + 1
                  TPS(M, N) = XX(K)
  220           CONTINUE
                CALL GEN004 (TPS, TM, TPQ)
                IS = 1
                DO 260 LL = 1, LINV
                  IF (LL .EQ. 2) IS = -1
                  DO 250 K = 1, NVCX + 1
                    DO 240 N = 1, 3
                      DO 230 M = 1, 3
                        IF (K .LE. NVCX) THEN
                          IF (ABS(TWM(N, M, K) - IS * TPQ(N, M))
     1                      .GT. 0.05) GOTO 250
                        ELSE
                          IF (ABS(TWM(N, M, K) - IS * TPS(N, M))
     1                      .GT. 0.05) GOTO 250
                        ENDIF
  230                 CONTINUE
  240               CONTINUE
                    GOTO 320
  250             CONTINUE
  260           CONTINUE
  270         CONTINUE
            ENDIF
            NVCX = NVCX + 1
            COSA = 0.0
            N1 = IPR(567)
            N2 = 2 * N1 - 1
            DO 300 K = 1, N2
              V(1) = K - N1
              DO 290 L = 1, N2
                V(2) = L - N1
                DO 280 M = 1, N2
                  V(3) = M - N1
                  CALL GEN002 (2, OR, V, T, XLNG)
                  IF (XLNG .NE. 0) THEN
                    SPRD  = GEN009 (T, TAU)
                    IF (SPRD .GT. COSA) THEN
                      COSA = SPRD
                      IHKL(1) = K - N1
                      IHKL(2) = L - N1
                      IHKL(3) = M - N1
                    ENDIF
                  ENDIF
  280           CONTINUE
  290         CONTINUE
  300       CONTINUE
            ALPHA(NVCX) = ACOS(MIN(1.0, COSA)) * GL(5)
            CALL GEN107 (IHKL, 3, IYUNK)
            DO 310 K = 1, 3
              IHKLD(K, NVCX) = IHKL(K)
  310       CONTINUE
            IF (MODE .NE. 2) THEN
              CALL PLA269 (1)
              WRITE (LU6, 99997)
              WRITE (LU7, 99997)
            ENDIF
            CALL PLA121 (NVCX)
          ENDIF
  320   CONTINUE
C * SORT TWIN LAWS
  330   CALL GEN124 (MTWIN, 1, NVCX * 2)
      ENDIF
C * SHOW RESULTS
  340 IF (MODE .EQ. 1) THEN
        IF (IWIN .EQ. 1) THEN
          CALL GGIP (HORS, VERT, 0.0, 1)
          CALL PLA117 (HORS, VERT, -1)
          BCD = 'TwinRotMat'//CHAR(0)
          CALL GGIP20 (0.0,  BCD, 10, 1.4, 4, 8, 7.0, VERT - 1.8)
          CALL GGIP20 (0.0,  BCD, 10, 1.4, 2, 8, 6.8, VERT - 1.9)
          WRITE (BCD, 99996) JID(1:6)
          VRT = VERT - 3.0
          CALL GGIP20 (0.0,  BCD, 80, 0.35, 5 + IGBL(68), 2, 1.0, VRT)
          WRITE (BCD, 99991) PAR(17), (PAR(100 + I), I = 1, 6),
     1                       SPGRNM(1)(1:11)
          VRT = VRT - 1.0
          CALL GGIP20 (0.0,  BCD, 80, 0.35, 1, 2, 1.0, VRT)
        ENDIF
      ELSE
        WRITE (LU22, 99982)
      ENDIF
      IF (MODE .EQ. 1) NLIST = NLIST + 1
      WRITE (BCD, 99990) PAR(413), PAR(414), IPR(550)
      IF (NLIST .EQ. 1) THEN
        CALL PLA269 (0)
        CALL PLA269 (9)
        WRITE (LU6, 99997)
        WRITE (LU7, 99997)
        WRITE (LU6, 99998) BCD
        WRITE (LU7, 99998) BCD
      ENDIF
      IF (IWIN .EQ. 1 .AND. MODE .EQ. 1) THEN
        VRT = VRT - 0.7
        CALL GGIP20 (0.0,  BCD, 80, 0.35, 1, 2, 1.0, VRT)
      ENDIF
      WRITE (BCD, 99983) NREF, NSEL, IPR(567), PAR(415), PAR(420)
      IF (NLIST .EQ. 1) THEN
        WRITE (LU6, 99997)
        WRITE (LU7, 99997)
        WRITE (LU7, 99987) PAR(17)
        WRITE (LU6, 99998) BCD
        WRITE (LU7, 99998) BCD
        WRITE (LU6, 99997)
        WRITE (LU7, 99997)
      ENDIF
      IF (IWIN .EQ. 1 .AND. MODE .EQ. 1) THEN
        VRT = VRT - 0.7
        CALL GGIP20 (0.0,  BCD, 80, 0.35, 1, 2, 1.0, VRT)
        CALL GGIP (0.0, 0.0, 0.0, 6)
      ENDIF
      IF (NSEL .EQ. 0) THEN
        IF (IWIN .EQ. 1 .AND. MODE .EQ. 1) THEN
          CALL GGIP20 (0.0, 'No Refl Selected', 16, 1.2, 2, 10, 4.0,
     1                 8.0)
        ENDIF
        IF (MODE .EQ. 2) WRITE (LU22, 99981)
        GOTO 360
      ENDIF
      NRTWL = 0
      IF (NVCX .GT. 0) THEN
        IF (IWIN .EQ. 1 .AND. MODE .EQ. 1) THEN
          CALL GGIP (0.0,        VRT - 0.5, 0.0, 3)
          CALL GGIP (HORS,       VRT - 0.5, 0.0, 2)
          CALL GGIP (1.8,        VRT - 0.5, 0.0, 3)
          CALL GGIP (1.8,        0.0,       0.0, 2)
          CALL GGIP (HORS - 4.1, VRT - 0.5, 0.0, 3)
          CALL GGIP (HORS - 4.1, 0.0      , 0.0, 2)
        ENDIF
        DO 350 J = 1, NVCX
          I = MTWIN(J * 2)
          IF (BASFM(I) .GT. 0.0 .AND. DRVAL(I) .LE. -0.01) THEN
            NCOL         = 3
            IPR(570 + J) = 1
          ELSE
            NCOL = 4
          ENDIF
          WRITE (BCD, 99999) (IHKLR(K, I), K = 1, 3),
     1                       (IHKLD(K, I), K = 1, 3),
     2                       ALPHA(I), NFRQ(I)
          IF (NLIST .EQ. 1) THEN
            CALL PLA269 (2)
            WRITE (LU6, 99997)
            WRITE (LU7, 99997)
            WRITE (LU6, 99998) BCD
            WRITE (LU7, 99998) BCD
          ENDIF
          IF (NCOL .EQ. 3) THEN
            IF (MODE .EQ. 2) THEN
              WRITE (LU22, 99997)
              WRITE (LU22, 99998) BCD
              WRITE (LU22, 99997)
            ENDIF
            WRITE (NQ1, 99989) (IHKLR(K, I), K = 1, 3)
            WRITE (NQ2, 99989) (IHKLD(K, I), K = 1, 3)
            WRITE (LU20, 99980) '_930', BASFM(I), BASFM(I), NQ1, NQ2
            NRTWL = NRTWL + 1
          ENDIF
          IF (IWIN .EQ. 1 .AND. MODE .EQ. 1) THEN
            VRT = VRT - 1.0
            BCD(80:80) = CHAR(0)
            CALL GGIP20 (0.0,  BCD, 80, 0.3, NCOL, 2, 2.0, VRT)
          ENDIF
          IF (NLIST .EQ. 1) THEN
            CALL PLA269 (4)
            WRITE (LU6, 99997)
            WRITE (LU7, 99997)
          ENDIF
          WRITE (BCD, 99994) (TWM(1, II, I), II = 1, 3), NTW(I)
          IF (NLIST .EQ. 1) THEN
            WRITE (LU6, 99998) BCD
            WRITE (LU7, 99998) BCD
          ENDIF
          IF (NCOL .EQ. 3 .AND. MODE .EQ. 2) WRITE (LU22, 99998) BCD
          IF (IWIN .EQ. 1 .AND. MODE .EQ. 1) THEN
            VRT = VRT - 1.0
            CALL GGIP20 (0.0,  BCD, 80, 0.3, NCOL, 2, 2.0, VRT)
          ENDIF
          WRITE (BCD, 99993) (TWM(2, II, I), II = 1, 3), BASFM(I)
          IF (NLIST .EQ. 1) THEN
            WRITE (LU6, 99998) BCD
            WRITE (LU7, 99998) BCD
          ENDIF
          IF (NCOL .EQ. 3 .AND. MODE .EQ. 2) WRITE (LU22, 99998) BCD
          IF (IWIN .EQ. 1 .AND. MODE .EQ. 1) THEN
            VRT = VRT - 0.6
            CALL GGIP20 (0.0,  BCD, 80, 0.3, NCOL, 2, 2.0, VRT)
            WRITE (NQ1, 99995) J
            CALL GGIP20 (0.0, NQ1, 1, 1.5, 1, 2 , HORS - 2.5, VRT)
          ENDIF
          WRITE (BCD, 99992) (TWM(3, II, I), II = 1, 3), DRVAL(I)
          IF (NLIST .EQ. 1) THEN
            WRITE (LU6, 99998) BCD
            WRITE (LU7, 99998) BCD
          ENDIF
          IF (NCOL .EQ. 3 .AND. MODE .EQ. 2) WRITE (LU22, 99998) BCD
          IF (IWIN .EQ. 1 .AND. MODE .EQ. 1) THEN
            VRT = VRT - 0.6
            CALL GGIP20 (0.0,  BCD, 80, 0.3, NCOL, 2, 2.0, VRT)
            CALL GGIP (1.8,  VRT - 0.4, 0.0, 3)
            CALL GGIP (HORS, VRT - 0.4, 0.0, 2)
          ENDIF
  350   CONTINUE
      ELSE
        IF (MODE .EQ. 1) THEN
          IF (IWIN .EQ. 1) THEN
            CALL GGIP20 (0.0, 'No Twin Law Detected', 20, 1.2, 2, 10,
     1                   3.0, 8.0)
          ENDIF
        ENDIF
      ENDIF
      IF (MODE .EQ. 2) THEN
        IF (NRTWL .EQ. 0 .AND. MODE .EQ. 2) WRITE (LU22, 99981)
        WRITE (LU22, 99997)
      ENDIF
  360 IF (MODE .NE. 2) THEN
        IF (IGBL(3) .NE. 37) THEN
          CALL PLA013 (0, 1)
          IF (IGGT(1:1) .EQ. '!' .OR. IGGT(1:4) .EQ. 'PLOT') GOTO 340
          CALL PLA006 (0, IS)
C * CALC TWIN LAWS
          IF (IS .EQ. 18) THEN
            GOTO 50
C * CALC HKLF (GENERATE HKLF 5 FILE)
          ELSE IF (IS .EQ. 70) THEN
            CALL PLA122
            GOTO 370
C * END (RETURN)
          ELSE IF (IS .EQ. 19) THEN
            GOTO 370
C * LIST (IPR/PAR/IGBL/GL)
          ELSE IF (IS .EQ. 29) THEN
            CALL PLA206 (-1, IFL(2)(1:3))
            GOTO 360
C * SET (IPR/PAR/IGBL/GL)
          ELSE IF (IS .EQ. 46) THEN
            CALL PLA206 (1, IFL(2)(1:3))
            GOTO 360
C * EXIT
          ELSE IF (IS .EQ. 53) THEN
            GOTO 370
C * TWIN PLOT
          ELSE IF (IS .EQ. 99) THEN
            IF (IWIN .EQ. 1) THEN
              CALL PLA123
            ENDIF
            GOTO 340
          ELSE
            GOTO 360
          ENDIF
        ELSE
C * GENERATE HKLF 5 FILE
          IF (NVCX .GT. 0) THEN
            CALL PLA122
          ENDIF
        ENDIF
      ENDIF
  370 CONTINUE
      RETURN
99999 FORMAT ('2-axis (', 3I4, ' ) [',3I4, ' ]',
     1        ', Angle () [] =', F6.2, ' Deg, Freq =', I6)
99998 FORMAT (A)
99997 FORMAT (1X)
99996 FORMAT ('Analysis of Fo/Fc Data for Unaccounted (Non)Merohedral',
     1        ' Twinning for: ', A)
99995 FORMAT (I1)
99994 FORMAT ('(', F6.3, 2F9.3, ')   (h1)   (h2)', 19X,
     1         'Nr Overlap =', I6)
99993 FORMAT ('(', F6.3, 2F9.3, ') * (k1) = (k2)', 25X,
     1         'BASF =', F6.2)
99992 FORMAT ('(', F6.3, 2F9.3, ')   (l1) = (l2)', 24X,
     1         'DEL-R =', F6.3)
99991 FORMAT ('Cell:', F8.5, 3F7.3, 3F7.2, 2X, 'Spgr: ', A)
99990 FORMAT ('Criteria: DeltaI/SigmaI .GT.', F5.1, ', DeltaTheta',
     1        F5.2, ' Deg., NselMin =', I4)
99989 FORMAT (2I2, I3)
99988 FORMAT ('  H  K  L         Iobs        Icalc     SigI',
     1        ' Delt/Sig  Theta',
     1        ' DTheta  Alpha     Rot Axis', /, 89('='))
99987 FORMAT ('Wavelength Used in this Analysis', F10.5, ' Ang.', /)
99986 FORMAT (3I3, 2F13.2, 2F9.2, 3F7.2, 3I5)
99985 FORMAT (3I3, 2F13.2, 2F9.2, F7.2)
99984 FORMAT (/, 'Alpha = (Iobs - Icalc) / (Jcalc - Icalc)', /)
99983 FORMAT ('N(refl) =', I7, ', N(selected) =', I5, ', IndMax =',
     1        I3, ', CritI =', F4.1, ', CritT =', F5.2)
99982 FORMAT (/, 80('='), /,
     1 'Check for Unaccounted Twinning with the TwinRotMat Algorithm.',
     2  /, 80('='))
99981 FORMAT (/,
     1  'No Applicable Twin Law(s) Detected from Fo/Fc Analysis', /)
99980 FORMAT (A, 2F10.2, 2A)
99979 FORMAT (60('='))
99978 FORMAT (/)
      END
      SUBROUTINE PLA121 (NRTWIN)
      PARAMETER (NP12=600,NP13=500,NP17=99,NPVD=40000000,
     1           NP23=18000,NP38=125,NP39=30,MM=10,NAL=100)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /LEPAG/ AXES(15, 23), TM(3, 3), CL(3, 5), TP(3, 3),
     1 TG(3, 3), TPQ(3, 3), TPS(3, 3), G(3, 3), OR(3, 3), ROTQ(3, 3),
     2 TRMXT (3, 3), T(3), H(3), TC(6), CELL(7), OCELL(7), RCELL(7),
     3 IDET, NVEC
      COMMON // JNSC(2, NP23), VOID(NPVD)
      DIMENSION IHKL(3), SUMT(NAL), SUMN(NAL), SCLA(NAL), SUMFC(NAL)
      COMMON /PL120/ TWM(3, 3, 4), IHKLR(3, 4), IHKLD(3, 4), SCL, IADR,
     1 NREF, NTW(4), DRVAL(4), NADR, HMAX, KMAX, LMAX, MTWIN(8), NTWIN,
     2 BASFM(4)
      COMMON /PL138/ IHKLS(5, 48), PHIS(48), NSYM, NSYMH, MHK, MPH,
     1  ICNTR, IND1, IND2, IND3
      INTEGER HMAX
      DO 30 K = 1, NREF
        KMM = (K - 1) * MM
        DO 10 J = 1, 3
          IHKL(J) = NINT(VOID(KMM + J))
          H(J)    = IHKL(J)
   10   CONTINUE
        FOK  = VOID(KMM + 4)
        FCK  = VOID(KMM + 5)
        TH   = VOID(KMM + 7)
        CALL GEN002 (1, TWM(1, 1, NRTWIN), H, T, XDUM)
        IHT  = NINT(T(1))
        IKT  = NINT(T(2))
        ILT  = NINT(T(3))
        FCKT = 0.0
        IF (ABS(T(1) - IHT) .LT. PAR(415)) THEN
          IF (ABS(T(2) - IKT) .LT. PAR(415)) THEN
            IF (ABS(T(3) - ILT) .LT. PAR(415)) THEN
              IHKLTP = ILT * MHK + IKT * MPH + IHT
              JJJ = IADR + IHKLTP
              IF (JJJ .GT. NPVD) GOTO 20
              J  = NINT(VOID(JJJ))
              IF (J .LT. 0) THEN
                GOTO 20
              ELSE IF (J .GT. 0) THEN
                FCKT0 = VOID((J - 1) * MM + 5)
              ENDIF
              ST  = SQRT(GEN095 (PAR(191), IHT, IKT, ILT)) * PAR(17)
              IF (ST .LT. 1.0) THEN
                THT = ASIN (ST) * GL(5)
              ELSE
                THT = 0.0
              ENDIF
              IF (ABS(TH - THT) .LE. PAR(420)) THEN
                IF (ABS(IHT) .LE. HMAX .AND. ABS(IKT) .LE. KMAX .AND.
     1              ABS(ILT) .LE. LMAX) THEN
                  NTW(NRTWIN) = NTW(NRTWIN) + 1
                  FCKT       = FCKT0
                ENDIF
              ENDIF
            ENDIF
          ENDIF
        ENDIF
   20   VOID (KMM + 10) = FCKT
   30 CONTINUE
      SUMFO = 0.0
      NALM = 100
      STAL = 1.0 / NALM
      CALL GEN074 (SUMFC, 0.0, 1, NALM)
      DO 60 K = 1, NREF
        KMM   = (K - 1) * MM
        FCKT  = VOID(KMM + 10)
        FOK   = VOID(KMM + 4)
        FCK   = VOID(KMM + 5)
        SUMFO = SUMFO + FOK
        DO 50 I = 1, NALM
          ALF = (I - 1) * STAL
          SUMFC(I) = SUMFC(I) + (1.0 - ALF) * FCK + ALF * FCKT
   50   CONTINUE
   60 CONTINUE
      DO 70 I = 1, NALM
        SCLA(I) = SUMFC(I) / SUMFO
        SUMT(I) = 0.0
        SUMN(I) = 0.0
   70 CONTINUE
      DO 90 K = 1, NREF
        KMM  = (K - 1) * MM
        FCKT = VOID(KMM + 10)
        FOK  = VOID(KMM + 4)
        FCK  = VOID(KMM + 5)
        DO 80 I = 1, NALM
          ALF  = (I - 1) * STAL
          FCKS = (1.0 - ALF) * FCK + ALF * FCKT
          SUMT(I) = SUMT(I) + ABS(SCLA(I) * FOK - FCKS)
          SUMN(I) = SUMN(I) + SCLA(I) * FOK
   80   CONTINUE
   90 CONTINUE
      BASF  = 0.0
      RVAL  = SUMT(1) / SUMN(1)
      DRVAL(NRTWIN) = - RVAL
      DO 100 I = 2, NALM
        YUNK = SUMT(I) /SUMN(I)
        IF (YUNK .LT. RVAL) THEN
          BASF = (I - 1) * STAL
          RVAL = YUNK
        ENDIF
  100 CONTINUE
      DRVAL(NRTWIN) = DRVAL(NRTWIN) + RVAL
      BASFM(NRTWIN) = BASF
      MTWIN(NRTWIN * 2 - 1) = NINT (DRVAL(NRTWIN) * 1000.0)
      MTWIN(NRTWIN * 2    ) = NRTWIN
      RETURN
      END
      SUBROUTINE PLA122
      PARAMETER (NP12=600,NP13=500,NP17=99,NPVD=40000000,
     1           NP23=18000,NP38=125,NP39=30,MM=10)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /LEPAG/ AXES(15, 23), TM(3, 3), CL(3, 5), TP(3, 3),
     1 TG(3, 3), TPQ(3, 3), TPS(3, 3), G(3, 3), OR(3, 3), ROTQ(3, 3),
     2 TRMXT (3, 3), T(3), H(3), TC(6), CELL(7), OCELL(7), RCELL(7),
     3 IDET, NVEC
      COMMON // JNSC(2, NP23), VOID(NPVD)
      DIMENSION IHKL(3)
      COMMON /PL120/ TWM(3, 3, 4), IHKLR(3, 4), IHKLD(3, 4), SCL, IADR,
     1 NREF, NTW(4), DRVAL(4), NADR, HMAX, KMAX, LMAX, MTWIN(8), NTWIN,
     2 BASFM(4)
      COMMON /PL138/ IHKLS(5, 48), PHIS(48), NSYM, NSYMH, MHK, MPH,
     1  ICNTR, IND1, IND2, IND3
      INTEGER HMAX, MTW(4)
      NTX = 0
      IRT = (2 - ICNTR) * IPR(575) + 1
      CALL PLA269 (0)
      CALL PLA269 (2)
      WRITE (LU7, 99999)
      NTWIN = 0
      DO 10 K = 1, 4
        IF (IPR(570 + K) .EQ. 1) THEN
          NTWIN      = NTWIN + 1
          MTW(NTWIN) = MTWIN(K * 2)
        ENDIF
   10 CONTINUE
      IPR(2) = -11
      DO 40 K = 1, NREF
        KMM = (K - 1) * MM
        DO 20 J = 1, 3
          IHKL(J) = NINT(VOID(KMM + J))
          H(J)    = IHKL(J)
   20   CONTINUE
        FOK  = VOID(KMM + 4)
        FCK  = VOID(KMM + 5)
        SIG  = VOID(KMM + 6)
        TH   = VOID(KMM + 7)
        IFOK = NINT(FOK * SCL)
        ISIG = NINT(SIG * SCL)
        NTY  = 0
        DO 30 NRTW = 1, NTWIN
          NRTWIN = MTW(NRTW)
          CALL GEN002 (1, TWM(1, 1, NRTWIN), H, T, XDUM)
          IHT  = NINT(T(1))
          IKT  = NINT(T(2))
          ILT  = NINT(T(3))
          FCKT = 0.0
          IPRN = 0
          IF (ABS(T(1) - IHT) .LT. PAR(415)) THEN
            IF (ABS(T(2) - IKT) .LT. PAR(415)) THEN
              IF (ABS(T(3) - ILT) .LT. PAR(415)) THEN
                IHKLTP = ILT * MHK + IKT * MPH + IHT
                J      = NINT(VOID(IADR + IHKLTP))
                IF (J .LT. 0) THEN
                  GOTO 30
                ELSE IF (J .GT. 0) THEN
                  FCKT0 = VOID((J - 1) * MM + 5)
                ENDIF
                ST  = SQRT(GEN095 (PAR(191), IHT, IKT, ILT)) * PAR(17)
                IF (ST .LT. 1.0) THEN
                  THT = ASIN (ST) * GL(5)
                ELSE
                  THT = 0.0
                ENDIF
                IF (ABS(TH - THT) .LE. PAR(420)) THEN
                  IF (ABS(IHT) .LE. HMAX .AND. ABS(IKT) .LE. KMAX .AND.
     1                ABS(ILT) .LE. LMAX) THEN
                    NTY  = 1
                    FCKT = FCKT0
                    NTC  = - (NRTW + 1) * IRT
                    IF (IPR(575) .EQ. 1) THEN
                      WRITE (LU17, 99998) -IHT, -IKT, -ILT, IFOK, ISIG,
     1                                     NTC
                    ENDIF
                    WRITE (LU17, 99998)  IHT,  IKT,  ILT, IFOK, ISIG,
     1                                   NTC + (IRT - 1)
                    IPRN = 1
                  ENDIF
                ENDIF
              ENDIF
            ENDIF
          ENDIF
   30   CONTINUE
        IF (IPR(575) .EQ. 1) THEN
          WRITE (LU17, 99998) ( -NINT(H(J)), J = 1, 3), IFOK, ISIG, -2
        ENDIF
        WRITE (LU17, 99998) (NINT(H(J)), J = 1, 3), IFOK, ISIG, 1
        NTX = NTX + NTY
        IF (IPR(469) .NE. 0) THEN
          CALL PLA269 (1)
          IF (IPRN .NE. 0) THEN
            WRITE (LU7, 99997) NTX, (NINT(H(J)), J = 1, 3),
     1             FOK, FCK, SIG, IHT, IKT, ILT, FCKT,
     2             TH, THT, TH - THT
          ELSE
            WRITE (LU7, 99996) (NINT(H(J)), J = 1, 3), FOK, FCK, SIG
          ENDIF
        ENDIF
        VOID (KMM + 10) = FCKT
   40 CONTINUE
      WRITE (LU6, 99995) (MTW(K), K = 1, NTWIN)
      CALL PLA269 (0)
      WRITE (LU7, 99995) (MTW(K), K = 1, NTWIN)
      IF (IRT .EQ. 1) THEN
        WRITE (LU6, 99994) NREF, NTX, (BASFM(MTW(I)),
     1                     I = 1, NTWIN)
        WRITE (LU7, 99994) NREF, NTX, (BASFM(MTW(I)),
     1                     I = 1, NTWIN)
      ELSE
        WRITE (LU6, 99994) NREF, NTX,
     1                     (BASFM(MTW(NTWIN + 1 - I)) / 2.0,
     2                      BASFM(MTW(NTWIN + 1 - I)) / 2.0,
     3                     I = 1, NTWIN)
        WRITE (LU7, 99994) NREF, NTX,
     1                     (BASFM(MTW(NTWIN + 1 - I)) / 2.0,
     2                      BASFM(MTW(NTWIN + 1 - I)) / 2.0,
     3                     I = 1, NTWIN)
      ENDIF
      RETURN
99999 FORMAT (3X, 'nr', 6X, 'H   K   L', 7X, 'FOK', 7X, 'FCK', 7X,
     1        'SIG', 5X, 'HT  KT  LT', 6X, 'FCKT',
     2        8X, 'TH', 7X, 'THT', 4X, 'DEL-TH', /, 105('='))
99998 FORMAT (3I4, 2I8, I4)
99997 FORMAT (I5, I7, 2I4, 3F10.2, I7, 2I4, 4F10.2)
99996 FORMAT (5X, I7, 2I4, 3F10.2)
99995 FORMAT (/, ':: TwinRotMatrix #', 4I5)
99994 FORMAT (':: Total Number of Reflections in HKLF 5 file   =', I6,
     2  /, '::       Number of which with Twin Contribution =', I6,
     3  /, '::                          Estimated BASF Line =', 8F5.2)
      END
      SUBROUTINE PLA123
      PARAMETER (NP4=9,NP10=16,NP12=600,NP13=500,NP17=99,NPVD=40000000,
     1           NP22=256,NP23=18000,NP38=125,NP39=30,MM=10)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9,  IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /PLA22/ LGR(12), XSYST(8), IBVL(8), LAT(7)
      CHARACTER LGR*5, XSYST*12, IBVL*1, LAT*1
      COMMON /LEPAG/ AXES(15, 23), TM(3, 3), CL(3, 5), TP(3, 3),
     1 TG(3, 3), TPQ(3, 3), TPS(3, 3), G(3, 3), OR(3, 3), ROTQ(3, 3),
     2 TRMXT (3, 3), T(3), H(3), TC(6), CELL(7), OCELL(7), RCELL(7),
     3 IDET, NVEC
      COMMON /PL120/ TWM(3, 3, 4), IHKLR(3, 4), IHKLD(3, 4), SCL, IADR,
     1 NREF, NTW(4), DRVAL(4), NADR, HMAX, KMAX, LMAX, MTWIN(8), NTWIN,
     2 BASFM(4)
      COMMON /PL138/ IHKLS(5, 48), PHIS(48), NSYM, NSYMH, MHK, MPH,
     1  ICNTR, IND1, IND2, IND3
      COMMON // JNSC(2, NP23), VOID(NPVD)
      COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0
      COMMON /CGG11/ BCD, SBCD
      CHARACTER BCD*132, SBCD*132
      COMMON /CGGT/ IGGT
      CHARACTER IGGT*80
      DIMENSION IMX(3), JMX(3), XYZ(3), TAU(3), ROT(3, 3), IAS(8),
     1          AS(3, 8)
      INTEGER HMAX
      HH    = HORS / 2.0
      VH    = VERT / 2.0
      RD    = 0.9 * VH
      IBRV  = IPR(241)
   10 NTPLT = MTWIN(IPR(543) * 2)
      STL   = PAR(449)
      RADM  = RD
      DO 20 I = 1, 3
        IMX(I) = INT (2 * STL * PAR(100 + I))
        JMX(I) = 2 * IMX(I) + 1
        RADM   = MIN (RADM, RD / IMX(I))
   20 CONTINUE
      RADM = RADM * 0.45
      NV   = NADR
      FCMX = 0.0
      DO 60 I = 1, JMX(1)
        II = I - IMX(1) - 1
        DO 50 J = 1, JMX(2)
          JJ = J - IMX(2) - 1
          DO 40 K = 1, JMX(3)
            KK = K - IMX(3) - 1
            H(1) = II
            H(2) = JJ
            H(3) = KK
            YUNK = 0
            IF (IBRV .GT. 1) THEN
              IF (GEN049 (LAT(IBRV), II, JJ, KK) .LT. 0.0) YUNK = -1.0
            ENDIF
            ITP  = -1
            IF (II .EQ. 0 .AND. JJ .EQ. 0 .AND. KK .EQ. 0) ITP = 0
            IF (II .EQ. 1 .AND. JJ .EQ. 0 .AND. KK .EQ. 0) ITP = 1
            IF (II .EQ. 0 .AND. JJ .EQ. 1 .AND. KK .EQ. 0) ITP = 2
            IF (II .EQ. 0 .AND. JJ .EQ. 0 .AND. KK .EQ. 1) ITP = 3
            IF (II .EQ. 1 .AND. JJ .EQ. 1 .AND. KK .EQ. 0) ITP = 4
            IF (II .EQ. 1 .AND. JJ .EQ. 0 .AND. KK .EQ. 1) ITP = 5
            IF (II .EQ. 0 .AND. JJ .EQ. 1 .AND. KK .EQ. 1) ITP = 6
            DO 30 L = 1, 2
              IF (L .EQ. 1) THEN
                T(1) = H(1)
                T(2) = H(2)
                T(3) = H(3)
                FCK  = 0.0
                IF (IABS(NINT(T(1))) .LE. HMAX .AND.
     1              IABS(NINT(T(2))) .LE. KMAX .AND.
     2              IABS(NINT(T(3))) .LE. LMAX) THEN
                  IHKLP = NINT(T(3)) * MHK + NINT(T(2)) * MPH
     1                  + NINT(T(1))
                  N     = NINT(VOID(IADR + IHKLP))
                  IF (N .GT. 0) FCK = VOID((N - 1) * MM + 5)
                ENDIF
                IF (FCK .GT. 0) THEN
                  FCX = LOG(FCK)
                ELSE
                  FCX = 0.0
                ENDIF
                FCMX = MAX (FCMX, FCX)
              ELSE
                CALL GEN002 (1, TWM(1, 1, NTPLT), H, T, XDUM)
              ENDIF
              CALL GEN002 (1, ROTQ, T, XYZ, XDUM)
              IF (SQRT(GEN009 (XYZ, XYZ)) .LT. 2 * STL) THEN
                VOID(NV + 1)  = L
                VOID(NV + 2)  = H(1)
                VOID(NV + 3)  = H(2)
                VOID(NV + 4)  = H(3)
                VOID(NV + 5)  = XYZ(1)
                VOID(NV + 6)  = XYZ(2)
                VOID(NV + 7)  = XYZ(3)
                VOID(NV + 8)  = ITP
                VOID(NV + 9)  = YUNK
                VOID(NV + 10) = FCX
                NV            = NV + 10
              ENDIF
   30       CONTINUE
   40     CONTINUE
   50   CONTINUE
   60 CONTINUE
   70 CALL GEN097 (IAS, 1, 8, 0)
   80 DO 90 I = 1, 3
        TAU(I) = OR(I, IPR(394))
   90 CONTINUE
      XTAU = SQRT(GEN009 (TAU, TAU))
      DO 100 I = 1, 3
        TAU(I) = TAU(I) / XTAU
  100 CONTINUE
      IF (ABS(TAU(1)) + ABS(TAU(2)) .LT. 0.0001) THEN
        OME = 0.0
        CHI = 90.0 / GL(5)
      ELSE
        OME = ATAN2 (TAU(2), TAU(1))
        CHI = ATAN2 (TAU(3), SQRT(TAU(1)**2 + TAU(2)**2))
      ENDIF
      CALL GEN043 (3, TP, OME)
      CALL GEN043 (2, TG, 90.0 / GL(5) - CHI)
      CALL GEN004 (TG, TP, ROT)
      IF (IPR(394) .EQ. 2 .OR. IPR(394) .EQ. 3) THEN
        CALL GEN043 (3, TG, 180.0 / GL(5))
      ELSE
        CALL GEN043 (3, TG, 90.0 / GL(5))
      ENDIF
      CALL GEN004 (TG, ROT, ROT)
      BCD = 'PlotTwinLat'//CHAR(0)
      CALL GGIP (HORS, VERT, 0.0, 1)
      CALL GGIP20 (90.0,  BCD, 11, 1.2, 2, 8, 2.3, 2.5)
      CALL PLA117 (HORS, VERT, -1)
      VRT = VERT - 0.4
      CALL GGIP20 (0.0, 'Twin Matrix', 11, 0.25, 5, 1, 2.0, VRT)
      VRT = VRT - 0.2
      DO 110 I = 1, 3
        WRITE (LINE, 99999) (TWM(I, J, NTPLT), J = 1, 3)
        VRT = VRT - 0.4
        CALL GGIP20 (0.0, LINE, 21, 0.25, 1, 1, 0.5, VRT)
  110 CONTINUE
      VRT = VRT - 0.7
      WRITE (LINE, 99996) (IHKLD(I, NTPLT), I = 1, 3)
      CALL GGIP20 (0.0, LINE, 17, 0.30, 1, 1, 1.0, VRT)
      VRT = VRT - 0.6
      WRITE (LINE, 99998) (IHKLR(I, NTPLT), I = 1, 3)
      CALL GGIP20 (0.0, LINE, 17, 0.30, 1, 1, 1.0, VRT)
      IF (IPR(394) .EQ. 1) THEN
        LINE = 'Zone - H ='
      ELSE IF (IPR(394) .EQ. 2) THEN
        LINE = 'Zone - K ='
      ELSE
        LINE = 'Zone - L ='
      ENDIF
      WRITE (LINE(11:13), 99997) IPR(576)
      VRT = VRT - 0.6
      CALL GGIP20 (0.0, LINE, 13, 0.35, 5, 1, 1.0, VRT)
      WRITE (LINE, '(''Resol = '', F5.1)') PAR(449)
      VRT = VRT - 0.6
      CALL GGIP20 (0.0, LINE, 13, 0.35, 1, 1, 1.0, VRT)
      WRITE (LINE, '('' BASF ='', F6.2)') BASFM(NTPLT)
      VRT = VRT - 0.6
      CALL GGIP20 (0.0, LINE, 13, 0.35, 1, 1, 1.0, VRT)
      WRITE (LINE, '(''DRVAL ='', F6.3)') DRVAL(NTPLT)
      VRT = VRT - 0.6
      CALL GGIP20 (0.0, LINE, 13, 0.35, 1, 1, 1.0, VRT)
      VRT = VERT
      WRITE (LINE, '(''SpGr '', A)') SPGRNM(1)(1:7)
      VRT = VRT - 0.6
      CALL GGIP20 (0.0, LINE, 12, 0.35, 1, 1, HORS - 4.0, VRT)
      WRITE (LINE, '(''a    '', F7.2)') PAR(101)
      VRT = VRT - 0.6
      CALL GGIP20 (0.0, LINE, 12, 0.35, 1, 1, HORS - 4.0, VRT)
      WRITE (LINE, '(''b    '', F7.2)') PAR(102)
      VRT = VRT - 0.6
      CALL GGIP20 (0.0, LINE, 12, 0.35, 1, 1, HORS - 4.0, VRT)
      WRITE (LINE, '(''c    '', F7.2)') PAR(103)
      VRT = VRT - 0.6
      CALL GGIP20 (0.0, LINE, 12, 0.35, 1, 1, HORS - 4.0, VRT)
      WRITE (LINE, '(''alpha'', F7.2)') PAR(104)
      VRT = VRT - 0.6
      CALL GGIP20 (0.0, LINE, 12, 0.35, 1, 1, HORS - 4.0, VRT)
      WRITE (LINE, '(''beta '', F7.2)') PAR(105)
      VRT = VRT - 0.6
      CALL GGIP20 (0.0, LINE, 12, 0.35, 1, 1, HORS - 4.0, VRT)
      WRITE (LINE, '(''gamma'', F7.2)') PAR(106)
      VRT = VRT - 0.6
      CALL GGIP20 (0.0, LINE, 14, 0.35, 1, 1, HORS - 4.0, VRT)
      CALL GGIP (HH, VH, 0.0, -3)
      CALL PLA289 (0.0, 0.0, RD, 36)
      SCF  = RD / (2 * STL)
      BAS2 = BASFM(NTPLT)
      BAS1 = 1.0 - BAS2
      SCPR0 = IPR(576) / XTAU
      DO 130 N = NADR, NV, 10
        SCPR = GEN009 (TAU, VOID(N + 5))
        IF (ABS(SCPR0 - SCPR) .LT. 0.01) THEN
          IPEN = NINT (VOID(N + 1))
          ITP  = NINT (VOID(N + 8))
          IPLT = NINT (VOID(N + 9))
          DO 120 I = 1, 3
            T(I) = VOID (N + I + 4) * SCF
  120     CONTINUE
          IF (IPEN .EQ. 1) THEN
            NADD = 0
          ELSE
            NADD = 4
          ENDIF
          IF (IPR(394) .EQ. 1) THEN
            IF (ITP .EQ. 2) IAS(1 + NADD) = N
            IF (ITP .EQ. 0) IAS(2 + NADD) = N
            IF (ITP .EQ. 3) IAS(3 + NADD) = N
            IF (ITP .EQ. 6) IAS(4 + NADD) = N
          ELSE IF (IPR(394) .EQ. 2) THEN
            IF (ITP .EQ. 1) IAS(1 + NADD) = N
            IF (ITP .EQ. 0) IAS(2 + NADD) = N
            IF (ITP .EQ. 3) IAS(3 + NADD) = N
           IF (ITP .EQ. 5) IAS(4 + NADD) = N
          ELSE IF (IPR(394) .EQ. 3) THEN
            IF (ITP .EQ. 1) IAS(1 + NADD) = N
            IF (ITP .EQ. 0) IAS(2 + NADD) = N
            IF (ITP .EQ. 2) IAS(3 + NADD) = N
            IF (ITP .EQ. 4) IAS(4 + NADD) = N
          ENDIF
          CALL GEN002 (1, ROT, T, XYZ, XLNG)
          IF (IPLT .EQ. 0) THEN
            RADIUS = RADM * VOID(N + 10) / FCMX
            IF (IPEN .EQ. 1) THEN
              RADIUS = MAX (RADIUS, 0.02)
              NSTEP = 12
            ELSE
              RADIUS = MAX (RADIUS * BAS2 / BAS1, 0.02)
              NSTEP = 3
            ENDIF
            CALL GGIP (0.0, FLOAT(IPEN), 0.0, 0)
            CALL PLA289 (XYZ(1), XYZ(2), RADIUS, NSTEP)
          ENDIF
        ENDIF
  130 CONTINUE
      IF (IPR(576) .EQ. 0) THEN
        DO 150 J = 1, 8
          DO 140 I = 1, 3
            IASJ = IAS(J)
            IF (IASJ .EQ. 0) IASJ = IAS(2)
            T(I) = VOID (IASJ + I + 4) * SCF
  140     CONTINUE
          CALL GEN002 (1, ROT, T, AS(1, J), XLNG)
  150   CONTINUE
        DO 160 I = 1, 2
          NADD = (2 - I) * 4
          CALL GGIP (0.0, FLOAT(3 - I), 0.0, 0)
          CALL GGIP (AS(1, 1 + NADD), AS(2, 1 + NADD), 0.0, 3)
          CALL GGIP (AS(1, 2 + NADD), AS(2, 2 + NADD), 0.0, 2)
          CALL GGIP (AS(1, 3 + NADD), AS(2, 3 + NADD), 0.0, 2)
          CALL GGIP (AS(1, 4 + NADD), AS(2, 4 + NADD), 0.0, 2)
          CALL GGIP (AS(1, 1 + NADD), AS(2, 1 + NADD), 0.0, 2)
  160   CONTINUE
        CALL GGIP20 (0.0, 'O', 1, 0.25, 1, 2, AS(1, 2) -0.3,
     1                 AS(2, 2) - 0.3)
        IF (IPR(394) .EQ. 1) THEN
          CALL GGIP20 (0.0, 'K', 1, 0.25, 1, 2, AS(1, 1),
     1                 AS(2, 1) + 0.1)
          CALL GGIP20 (0.0, 'L', 1, 0.25, 1, 2, AS(1, 3) + 0.1,
     1                 AS(2, 3))
        ELSE IF (IPR(394) .EQ. 2) THEN
          CALL GGIP20 (0.0, 'H', 1, 0.25, 1, 2, AS(1, 1),
     1                 AS(2, 1) + 0.1)
          CALL GGIP20 (0.0, 'L', 1, 0.25, 1, 2, AS(1, 3) + 0.1,
     1                 AS(2, 3))
        ELSE IF (IPR(394) .EQ. 3) THEN
          CALL GGIP20 (0.0, 'H', 1, 0.25, 1, 2, AS(1, 1),
     1                 AS(2, 1) + 0.1)
          CALL GGIP20 (0.0, 'K', 1, 0.25, 1, 2, AS(1, 3) + 0.1,
     1                 AS(2, 3))
        ENDIF
      ENDIF
      CALL PLA013 (0, 1)
      IF (IGGT(1:1) .EQ. '!') THEN
        GOTO 70
      ELSE IF (IGGT(1:4) .EQ. 'TWIN') THEN
        GOTO 10
      ELSE IF (IGGT(1:4) .EQ. 'NEXT') THEN
        IPR(576) = MAX (-IMX(IPR(394)), MIN (IMX(IPR(394)),
     1             IPR(576) + IPR(389)))
        GOTO 80
      ELSE IF (IGGT(1:4) .EQ. 'ZONE') THEN
        GOTO 70
      ELSE IF (IGGT(1:4) .EQ. 'RESO') THEN
        GOTO 10
      ELSE
        IPR(543) = 0
      ENDIF
      RETURN
99999 FORMAT (3F7.3)
99998 FORMAT ('(', I3, 2I5, ' )')
99997 FORMAT (I3)
99996 FORMAT ('[', I3, 2I5, ' ]')
      END
      SUBROUTINE PLA124
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16,
     1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP22=256,NP23=18000,
     2 NP25=99,NP29=63,NP38=125,NP39=30,NP41=200,NP45=2048,NP47=9,
     3 NPVD=40000000,MM=10)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9,  IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /Q/ ICL, IFL(NP17)
      CHARACTER ICL*(NP45), IFL*7
      COMMON /PL120/ TWM(3, 3, 4), IHKLR(3, 4), IHKLD(3, 4), SCL, IADR,
     1 NREF, NTW(4), DRVAL(4), NADR, HMAX, KMAX, LMAX, MTWIN(8), NTWIN,
     2 BASFM(4)
      COMMON /PL138/ IHKLS(5, 48), PHIS(48), NSYM, NSYMH, MHK, MPH,
     1  ICNTR, IND1, IND2, IND3
      COMMON // JNSC(2, NP23), VOID(NPVD)
      COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0
      COMMON /CGGT/ IGGT
      CHARACTER IGGT*80
      COMMON /NPPLOT/ YCC, YINT, YSLOPE
      CHARACTER FORM*9
      INTEGER HMAX
      NFPK = 32000
C * Analysis of Friedel Pair Differences
      IF (ICNTR .EQ. 2) THEN
        WRITE (LU6, 99999)
      ELSE IF (NREF .GT. NFPK) THEN
        WRITE (LU6, 99981) NFPK
      ELSE
        IGBL(23) = 29
        NADR  = NREF * MM
        MPH   = 2 * HMAX + 1
        MPK   = 2 * KMAX + 1
        MPL   = 2 * LMAX + 1
        MHK   = MPH * MPK
        MHKL  = MPL * MHK
        MHKLH = (MHKL - 1) / 2
        IADR  = NPVD - MHKLH
        IADR1 = NPVD - MHKL
        DO 10 I = 1, MHKL
          VOID(IADR1 + I) = 0.0
   10   CONTINUE
        DO 30 I = 1, NREF
          IMM    = (I - 1) * MM
          XJS(1) = VOID(IMM + 1)
          XJS(2) = VOID(IMM + 2)
          XJS(3) = VOID(IMM + 3)
          DO 20 NS = 1, NSYMH
            CALL SGSM (LINE, NS, XJS, LU7, 5, IER)
            IH    = NINT(XJS(7))
            IK    = NINT(XJS(8))
            IL    = NINT(XJS(9))
            IHKLP = IL * MHK + IK * MPH + IH
            VOID (IADR + IHKLP) =  I
   20     CONTINUE
   30   CONTINUE
   40   NF0  = 0
        NF   = 0
        NPLS = 0
        NMIN = 0
        NFR  = 0
        CALL GEN074 (DATC, 0.0, 1, 101)
        CALL PLA269 (0)
        DO 60 I = 1, NREF
          IMM   = (I - 1) * MM
          IH    = NINT(VOID(IMM + 1))
          IK    = NINT(VOID(IMM + 2))
          IL    = NINT(VOID(IMM + 3))
          FOK1  = VOID(IMM + 4)
          FCK1  = VOID(IMM + 5)
          SIG1  = VOID(IMM + 6)
          IHKLP = IL * MHK + IK * MPH + IH
          N = NINT(VOID(IADR - IHKLP))
          IF (N .GT. I) THEN
            NF0  = NF0 + 1
            M    = (N - 1) * MM
            FOK2 = VOID(M + 4)
            FCK2 = VOID(M + 5)
            SIG2 = VOID(M + 6)
            FOKD = FOK1 - FOK2
            FCKD = FCK1 - FCK2
            SIGM = SQRT(SIG1**2 + SIG2**2)
            NFR  = NFR + 1
            VOID (NADR + NFR) = (FCKD - FOKD) / SIGM
            DO 50 J = 1, 101
              YK = (J - 51) * 0.1
              DATC(J) = DATC(J) - (((YK * FCKD - FOKD) / SIGM)**2) / 2
   50       CONTINUE
            IF (ABS(FCK1 - FCK2) .GE. PAR(452) * SIGM) THEN
              IF (NF .LT. NP23) THEN
                NF          = NF + 1
                SIGM        = MAX (SIGM, 0.01)
                JNSC(1, NF) = 100000000
     1                      - NINT(100.0 * ABS(FCK1 - FCK2) / SIGM)
                JNSC(2, NF) = I * NFPK + N
              ENDIF
            ENDIF
          ENDIF
   60   CONTINUE
        IF (NF .LT. 3) THEN
          IF (PAR(452) .GT. 0.0) THEN
            PAR(452) = 0.0
            GOTO 40
          ENDIF
        ENDIF
C * NORMAL PROBABILITY PLOT
        IF (NFR .GT. 0) THEN
          WRITE (LU7, 99969)
          CALL PLA282 (2, VOID(NADR + 1), VOID(NADR + NREF + 1), NFR,
     1                 LU7)
          CALL PLA269 (0)
        ENDIF
        SUM  = 0.0
        SUMW = 0.0
        XMAX = 0.0
        YMAX = 0.0
        RCT  = 0.0
        RCN  = 0.0
        DDP  = -999999.0
        DDM  =  999999.0
        IF (NF .GT. 0) THEN
          CALL GEN037 (JNSC, 1, NF)
          DO 70 N = 1, NF
            J     = JNSC(2, N)
            I     = J / NFPK
            J     = MOD (J, NFPK)
            IMM   = (I - 1) * MM
            JMM   = (J - 1) * MM
            IH1   = NINT(VOID(IMM + 1))
            IK1   = NINT(VOID(IMM + 2))
            IL1   = NINT(VOID(IMM + 3))
            FOK1  = VOID(IMM + 4)
            FCK1  = VOID(IMM + 5)
            SIG1  = VOID(IMM + 6)
            IH2   = NINT(VOID(JMM + 1))
            IK2   = NINT(VOID(JMM + 2))
            IL2   = NINT(VOID(JMM + 3))
            FOK2  = VOID(JMM + 4)
            FCK2  = VOID(JMM + 5)
            SIG2  = VOID(JMM + 6)
            FOKD  = FOK1 - FOK2
            FCKD  = FCK1 - FCK2
            SIGM  = SIG1**2 + SIG2**2
            RCT   = RCT + FOKD * FCKD / SIGM
            RCN   = RCN + FCKD**2 / SIGM
            SIGM = SQRT(SIGM)
            IF (FOKD * FCKD .GT. 0.0) THEN
              NPLS = NPLS + 1
            ELSE
              NMIN = NMIN + 1
            ENDIF
            IF (ABS(FOKD) .LT. 3.0 * ABS(FCKD)) THEN
              XMAX  = MAX (XMAX, ABS(FCKD))
              YMAX  = MAX (YMAX, ABS(FOKD))
            ENDIF
            IF (FCKD .NE. 0.0) THEN
              RATIO = FOKD / FCKD
              DCDOS = (FCKD - FOKD) / SIGM
              DDP   = MAX (DDP, DCDOS)
              DDM   = MIN (DDM, DCDOS)
              IF (SIGM .GT. 0.0) THEN
                WGHT  = ABS(FCKD) / SIGM
                SUM   = SUM  + WGHT * RATIO
                SUMW  = SUMW + WGHT
              ENDIF
            ENDIF
            IF (N .EQ. 1) THEN
              WRITE (LU7, 99997) PAR(452)
              CALL PLA269 (3)
              WRITE (LU7, 99996)
              CALL PLA269 (2)
            ENDIF
            IF (N .LT. 21) THEN
              IF (N .EQ. 1) WRITE (LU6, 99993)
              WRITE (LU6, 99994) IH1, IK1, IL1, IH2, IK2, IL2,
     1                           FOKD, FCKD, SIGM, WGHT, RATIO, DCDOS
            ENDIF
            CALL PLA269 (1)
            WRITE (LU7, 99998) IH1, IK1, IL1, FOK1, FCK1, SIG1,
     1                         IH2, IK2, IL2, FOK2, FCK2, SIG2,
     2                         FOKD, FCKD, SIGM, WGHT, RATIO, DCDOS
   70     CONTINUE
          SUM = SUM / SUMW
        ENDIF
        IF (IPR(593) .NE. 0) THEN
          DO 75 J = 1, 101
            DATC(J) = DATC(J) / YSLOPE**2
   75     CONTINUE
        ENDIF
        DATCM = DATC(1)
        DO 80 J = 2, 101
          IF (DATC(J) .GT. DATCM) DATCM = DATC(J)
   80   CONTINUE
        XG0 = 0.0
        XG1 = 0.0
        XG2 = 0.0
        DO 90 J = 1, 101
          YK  = (J - 51) * 0.1
          XG1 = XG1 + YK * EXP (DATC(J) - DATCM)
          XG0 = XG0 +      EXP (DATC(J) - DATCM)
   90   CONTINUE
        XG  = XG1 / XG0
        DO 100 J = 1, 101
          YK  = (J - 51) * 0.1
          XG2 = XG2 + (YK - XG)**2 * EXP (DATC(J) - DATCM)
  100   CONTINUE
        FLEQ  = (1.0 - XG) / 2.0
        SFLEQ = SQRT (XG2 / XG0) / 2.0
        XPLLL = DATC(61) - DATCM
        XMNLL = DATC(41) - DATCM
        XTWLL = DATC(51) - DATCM
        XPLLL = EXP(XPLLL)
        XTWLL = EXP(XTWLL)
        XMNLL = EXP(XMNLL)
        XSMLL = XPLLL + XTWLL + XMNLL
        XPLLL = XPLLL / XSMLL
        XMNLL = XMNLL / XSMLL
        XTWLL = XTWLL / XSMLL
        IF (RCN .NE. 0) THEN
          RCO = RCT / RCN
        ELSE
          RCO = 0.0
        ENDIF
        WRITE (LU6, 99995) SUM, NF, NF0, DDM, DDP
        CALL PLA269 (3)
        WRITE (LU7, 99995) SUM, NF, NF0, DDM, DDP
C * SCATTER DISPLAY
  110   IF (XMAX .NE. 0.0 .AND. YMAX .NE. 0.0) THEN
          SCLX = 0.90 * VERT / (2.0 * XMAX)
          SCLY = 0.90 * VERT / (2.0 * YMAX)
          XOR  = VERT / 2.0
          YOR  = VERT / 2.0
          CALL GGIP (HORS, VERT, 0.0, 1)
          CALL PLA117 (VERT, VERT, -1)
          CALL PLA269 (0)
          LINE = 'BIJVOET-PAIR SCATTER PLOT'
          VRT  = VERT - 0.6
          CALL GGIP20 (0.0, LINE, 25, 0.35, 5 + IGBL(68), 2, 6.0, VRT)
          LINE = 'DELTA Fobs**2'
          CALL GGIP20 (90.0, LINE, 13, 0.35, 1, 2, 0.6, VERT - 4.6)
          LINE = 'DELTA Fcalc**2'
          CALL GGIP20 (0.0, LINE, 14, 0.35, 1, 2, VERT - 4.6, 0.2)
          WRITE (LINE, 99984) SPGRNM(1)(1:7)
          WRITE (LU7,  99968) LINE
          CALL GGIP20 (0.0, LINE, 19, 0.35, 1, 2, VERT + 0.2, VRT)
          VRT = VRT - 0.2
          IF (PAR(433) .LT. 999999.0) THEN
            VRT = VRT - 0.7
            WRITE (LINE, 99992) PAR(433)
            WRITE (LU7,  99968) LINE
            CALL GGIP20 (0.0, LINE, 21, 0.35, 1, 2, VERT + 0.2, VRT)
          ENDIF
          IF (PAR(434) .LT. 999999.0) THEN
            VRT = VRT - 0.7
            WRITE (LINE, 99980) PAR(434)
            WRITE (LU7,  99968) LINE
            CALL GGIP20 (0.0, LINE, 21, 0.35, 1, 2, VERT + 0.2, VRT)
          ENDIF
          VRT = VRT - 1.5
          WRITE (LU7,  99967)
          WRITE (LINE, 99990)
          WRITE (LU7,  99968) LINE
          CALL GGIP20 (0.0, LINE, 14, 0.45, 5 + IGBL(68), 2,
     1                 VERT + 0.2, VRT)
          VRT = VRT - 0.8
          WRITE (LINE, 99987) PAR(452)
          WRITE (LU7,  99968) LINE
          CALL GGIP20 (0.0, LINE, 21, 0.35, 1, 2, VERT + 0.2, VRT)
          VRT = VRT - 0.7
          WRITE (LINE, 99989) NF
          WRITE (LU7,  99968) LINE
          CALL GGIP20 (0.0, LINE, 21, 0.35, 1, 2, VERT + 0.2, VRT)
          VRT = VRT - 0.7
          WRITE (LINE, 99988) NF0
          WRITE (LU7,  99968) LINE
          CALL GGIP20 (0.0, LINE, 21, 0.35, 1, 2, VERT + 0.2, VRT)
          VRT = VRT - 0.7
          WRITE (LINE, 99986) NPLS
          WRITE (LU7,  99968) LINE
          CALL GGIP20 (0.0, LINE, 21, 0.35, 1, 2, VERT + 0.2, VRT)
          VRT = VRT - 0.7
          WRITE (LINE, 99985) NMIN
          WRITE (LU7,  99968) LINE
          CALL GGIP20 (0.0, LINE, 21, 0.35, 1, 2, VERT + 0.2, VRT)
          VRT = VRT - 0.7
          WRITE (LINE, 99991) SUM
          WRITE (LU7,  99968) LINE
          CALL GGIP20 (0.0, LINE, 21, 0.35, 1, 2, VERT + 0.2, VRT)
          VRT = VRT - 0.7
          WRITE (LINE, 99970) RCO
          WRITE (LU7,  99968) LINE
          CALL GGIP20 (0.0, LINE, 21, 0.35, 1, 2, VERT + 0.2, VRT)
          VRT = VRT - 1.0
          WRITE (LU7,  99967)
          WRITE (LINE, 99966)
          WRITE (LU7,  99968) LINE
          CALL GGIP20 (0.0, LINE, 21, 0.35, 5 + IGBL(68), 2,
     1       VERT + 0.2, VRT)
          VRT = VRT - 0.9
          WRITE (LINE, 99965) YCC
          WRITE (LU7,  99968) LINE
          CALL GGIP20 (0.0, LINE, 21, 0.35, 1, 2, VERT + 0.2, VRT)
          VRT = VRT - 0.7
          WRITE (LINE, 99964) YINT
          WRITE (LU7,  99968) LINE
          CALL GGIP20 (0.0, LINE, 21, 0.35, 1, 2, VERT + 0.2, VRT)
          VRT = VRT - 0.7
          WRITE (LINE, 99963) YSLOPE
          WRITE (LU7,  99968) LINE
          CALL GGIP20 (0.0, LINE, 21, 0.35, 1, 2, VERT + 0.2, VRT)
          VRT = VRT - 1.0
          WRITE (LU7,  99967)
          WRITE (LINE, 99974)
          WRITE (LU7,  99968) LINE
          CALL GGIP20 (0.0, LINE, 21, 0.35, 5 + IGBL(68), 2,
     1                 VERT + 0.2, VRT)
          VRT = VRT - 0.9
          WRITE (LINE, 99973) NF0
          WRITE (LU7,  99968) LINE
          CALL GGIP20 (0.0, LINE, 21, 0.35, 1, 2, VERT + 0.2, VRT)
          VRT = VRT - 0.7
          IF (XPLLL .GT. 0.001) THEN
            WRITE (FORM, '(F9.3)') XPLLL
          ELSE
            WRITE (FORM, '(E9.1)') XPLLL
          ENDIF
          WRITE (LINE, 99979) FORM
          WRITE (LU7,  99968) LINE
          CALL GGIP20 (0.0, LINE, 21, 0.35, 1, 2, VERT + 0.2, VRT)
          VRT = VRT - 0.7
          IF (XTWLL .GT. 0.001) THEN
            WRITE (FORM, '(F9.3)') XTWLL
          ELSE
            WRITE (FORM, '(E9.1)') XTWLL
          ENDIF
          WRITE (LINE, 99977) FORM
          WRITE (LU7,  99968) LINE
          CALL GGIP20 (0.0, LINE, 21, 0.35, 1, 2, VERT + 0.2, VRT)
          VRT = VRT - 0.7
          IF (XMNLL .GT. 0.001) THEN
            WRITE (FORM, '(F9.3)') XMNLL
          ELSE
            WRITE (FORM, '(E9.1)') XMNLL
          ENDIF
          WRITE (LINE, 99978) FORM
          WRITE (LU7,  99968) LINE
          CALL GGIP20 (0.0, LINE, 21, 0.35, 1, 2, VERT + 0.2, VRT)
          VRT = VRT - 0.7
          WRITE (LINE, 99972) XG
          WRITE (LU7,  99968) LINE
          CALL GGIP20 (0.0, LINE, 21, 0.35, 1, 2, VERT + 0.2, VRT)
          VRT = VRT - 0.7
          YUNK = SQRT (XG2 / XG0)
          IF (YUNK .GT. 0.0001) THEN
            WRITE (FORM, '(F9.4)') YUNK
          ELSE
            WRITE (FORM, '(E9.1)') YUNK
          ENDIF
          WRITE (LINE, 99971) FORM
          WRITE (LU7,  99968) LINE
          CALL GGIP20 (0.0, LINE, 21, 0.35, 1, 2, VERT + 0.2, VRT)
          VRT = VRT - 0.7
          WRITE (LINE, 99976) FLEQ
          WRITE (LU7,  99968) LINE
          CALL GGIP20 (0.0, LINE, 21, 0.35, 1, 2, VERT + 0.2, VRT)
          VRT = VRT - 0.7
          IF (SFLEQ .GT. 0.001) THEN
            WRITE (FORM, '(F9.3)') SFLEQ
          ELSE
            WRITE (FORM, '(E9.1)') SFLEQ
          ENDIF
          WRITE (LINE, 99975) FORM
          WRITE (LU7,  99968) LINE
          CALL GGIP20 (0.0, LINE, 21, 0.35, 1, 2, VERT + 0.2, VRT)
          CALL GGIP (XOR, YOR, 0.0, -3)
          DX = 0.45 * VERT
          CALL GGIP (0.0, FLOAT(5 + IGBL(68)), 0.0, 0)
          CALL GGIP (0.0, - DX, 0.0, 3)
          CALL GGIP (0.0, + DX, 0.0, 2)
          CALL GGIP (- DX, 0.0, 0.0, 3)
          CALL GGIP (DX,   0.0, 0.0, 2)
          CALL GGIP (0.0,  0.0, 0.0, 3)
          DY = XMAX * RCO / YMAX
          IF (DY .LT. 1.0) THEN
            DX0 = - DX
            DY0 = - DX * DY
          ELSE
            DX0 = - DX / DY
            DY0 = - DX
          ENDIF
          CALL GGIP (0.0, 3.0, 0.0, 0)
          CALL GGIP (DX0, DY0, 0.0, 2)
          CALL GGIP (0.0,  0.0, 0.0, 3)
          WRITE (LINE, 99983) XMAX
          CALL GGIP20 (90.0, LINE, 9, 0.3, 1, 2, DX + 0.4, -1.2)
          WRITE (LINE, 99983) YMAX
          CALL GGIP20 (0.0, LINE, 9, 0.3, 1, 2, -2.8, DX - 0.3)
          DSH = 0.05
          DO 130 N = 1, NF
            J     = JNSC(2, N)
            I     = J / NFPK
            J     = MOD (J, NFPK)
            IMM   = (I - 1) * MM
            JMM   = (J - 1) * MM
            FOK1  = VOID(IMM + 4)
            FCK1  = VOID(IMM + 5)
            SIG1  = VOID(IMM + 6)
            FOK2  = VOID(JMM + 4)
            FCK2  = VOID(JMM + 5)
            SIG2  = VOID(JMM + 6)
            FOKD  = SCLY * (FOK1 - FOK2)
            FCKD  = SCLX * (FCK1 - FCK2)
            SIG   = SCLY * SQRT(SIG1**2 + SIG2**2)
            IF (ABS(FOKD) .GT. 0.45 * VERT) GOTO 130
            DO 120 M = 1, 3, 2
              IF (FOKD * FCKD .GE. 0.0) THEN
                COLR = 1.0
              ELSE
                COLR = 2.0
              ENDIF
              CALL GGIP (0.0, COLR, 0.0, 0)
              X = (M - 2) * FCKD
              Y = (M - 2) * FOKD
              CALL GGIP (X,       Y + DSH, 0.0, 3)
              CALL GGIP (X + DSH, Y,       0.0, 2)
              CALL GGIP (X,       Y - DSH, 0.0, 2)
              CALL GGIP (X - DSH, Y,       0.0, 2)
              CALL GGIP (X,       Y + DSH, 0.0, 2)
              IF (X .GT. 0.0) THEN
                CALL GGIP (X, Y + SIG, 0.0, 3)
                CALL GGIP (X, Y - SIG, 0.0, 2)
                IF (X .GT. DX / 2.0 .OR. Y .LT. -DX / 2.0) THEN
                  IH = NINT(VOID(IMM + 1))
                  IK = NINT(VOID(IMM + 2))
                  IL = NINT(VOID(IMM + 3))
                  WRITE (LINE, 99982) IH, IK, IL
                  IF (MOD(N, 2) .EQ. 1) THEN
                    ADD =  0.1
                  ELSE
                    ADD = -1.1
                  ENDIF
                  CALL GGIP20 (-45.0, LINE, 9, 0.16, 5 + IGBL(68),
     1                         1, X + ADD , Y - ADD)
                ENDIF
              ENDIF
  120       CONTINUE
  130     CONTINUE
        ENDIF
        CALL PLA013 (0, 1)
        CALL GEN072 (IGGT, IFL, FN, KL, KN, 0, LU6, 1, 1, 80, 7, NP17)
        IF (IFL(1)(1:3) .EQ. 'END') THEN
          GOTO 140
        ELSE IF (IFL(1)(1:4) .EQ. 'EXIT') THEN
          GOTO 140
        ELSE IF (IFL(1)(1:5) .EQ. 'SIGMA') THEN
          GOTO 40
        ELSE IF (IFL(1)(1:5) .EQ. 'SLOPE') THEN
          GOTO 40
        ELSE
          GOTO 110
        ENDIF
      ENDIF
  140 RETURN
99999 FORMAT (':: No Bijvoet Pair Analysis for Centrosymmetric',
     1        ' Structure')
99998 FORMAT (2(3I4, 2F10.2, F8.2), 3F9.2, 2F8.2, F9.3)
99997 FORMAT ('Analyses of Bijvoet-Pair (Friedel-Pair) Differences',
     1        ' for abs(Fcalcl**2 - Fcalc2**2))/Sigma .GT. ', F6.2, /,
     2        101('='), /)
99996 FORMAT (' IH1 IK1 IL1    FO1**2    FC1**2  SIGMA1',
     1        ' IH2 IK2 IL2    FO2**2    FC2**2  SIGMA2',
     2        '   DELOBS  DELCALC SIG(DEL) DLC/SIG DLO/DLC  DC-DO/S', /,
     3        132('='))
99995 FORMAT (/, 'Average Weighted Ratio =', F6.2, ' for', I5,
     1        ' Bijvoet Pairs (out of', I7, ')', /,
     2        ' MIN, MAX = ', 2F8.3, /)
99994 FORMAT (3I4, 2X, 3I4, 5F9.2, F9.3)
99993 FORMAT (/, ' IH1 IK1 IL1   IH2 IK2 IL2   DELOBS  DELCALC',
     1        ' SIG(DEL)  DLC/SIG  DLO/DLC DC-DO/SG', /)
99992 FORMAT ('Flack Param', F10.3)
99991 FORMAT ('Aver. Ratio', F10.3)
99990 FORMAT ('Bijvoet Pairs:')
99989 FORMAT ('Selected ...', I9)
99988 FORMAT ('Out of .....', I9)
99987 FORMAT ('Sigma Crit..', F9.2)
99986 FORMAT ('Number Plus ', I9)
99985 FORMAT ('Number Minus', I9)
99984 FORMAT ('Space Group ', A)
99983 FORMAT (F9.2)
99982 FORMAT (3I3)
99981 FORMAT (':: No Bijvoet Pair Analyses: More than', I6,
     1        'Reflections')
99980 FORMAT ('Flack S.U. ', F10.3)
99979 FORMAT ('P(ok).......', A)
99978 FORMAT ('P(wrong) ...', A)
99977 FORMAT ('P(rac-twin).', A)
99976 FORMAT ('FLEQ .......', F9.3)
99975 FORMAT ('FLEQ S.U. ..', A)
99974 FORMAT ('Bayesian Statistics')
99973 FORMAT ('Bijvoet Pairs', I8)
99972 FORMAT ('G ..........', F9.4)
99971 FORMAT ('G S.U. .....', A)
99970 FORMAT ('RC .........', F9.3)
99969 FORMAT (':: NPP for (delta(Fcalc**2) - delta(Fobs**2))/sigma', /,
     1        '   Sigma = sqrt(sigma(Fobs1**2) + sigma(Fobs2**2))')
99968 FORMAT (A)
99967 FORMAT (/)
99966 FORMAT ('Normal Prob. Plot')
99965 FORMAT ('Corr. Coeff.', F9.3)
99964 FORMAT ('Intercept ..', F9.3)
99963 FORMAT ('Slope ......', F9.3)
      END
      SUBROUTINE PLA125
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118,
     1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NPVD=40000000,
     2 NP22=256,NP23=18000,NP25=99,NP29=63,NP38=125,NP39=30,NP41=200,
     3 NP45=2048,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /Q/ ICL, IFL(NP17)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9),
     1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10),
     2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10),
     3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770)
      COMMON // JNSC(2 * NP23), VOID(NPVD)
      COMMON /ISCR/ NXYZ(3), NXYZ0(3), IGR(3), JGR(3), KGR(3), MGR(3),
     1              IJGR(3)
      DIMENSION DUMW(3, 3), EW(3), NGPV(3), NGNX(3), NJG(4, 2),
     1 EV(3, 3), I123(4, 3)
      COMMON /PAGENM/ PAGET, PAGEIND(25)
      CHARACTER PAGET*8, PAGEIND*8
      COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0
      COMMON /NAMES/ NAME(8), EXTENS, PROGNM, FNLU1, FNLU16, RDTYPE
      CHARACTER NAME*80, EXTENS*9, PROGNM*28, FNLU1*80, FNLU16*80,
     1          RDTYPE*7
      COMMON /FNAME/ KNM(8), KXT, KNM16
      CHARACTER PLPATH*255
      INTEGER FINDEXE
      EXTERNAL SYSTEM
      IGBL(23) = 24
      NGB      = 0
      NGE      = 0
      CSLA     = 0.0
      REWIND LU15
      NSYM = IPR(48)
      CALL GEN097 (I123, 1, 12, 0)
      I123(2, 1) = 1
      I123(3, 2) = 1
      I123(4, 3) = 1
      NGRTR      = ICHAR('>')
      NDOT       = ICHAR('.')
   10 ISAR  = IPR(39) + 1
      IF (ISAR .GE. NP1) THEN
        IF (IGBL(3) .NE. 1) IPR(2) = 25
        GOTO 460
      ENDIF
      IAT       = NP1
      XLAB(IAT) = IPR(464)
      IPR(58)   = 0
      IPR(61)   = IPR(75) + 1
      IPR(98)   = 0
      IPR(104)  = IPR(61)
      IPR(127)  = 0
      IPR(188)  = 0
      IPR(190)  = 0
      IPR(198)  = 0
      IF (IPR(491) .EQ. 0) THEN
        IF (IGBL(3) .EQ. 0) THEN
          IPR(491) = 40000
        ELSE
          IPR(491) = 5000
        ENDIF
      ENDIF
      IPR(199) = 0
      IF (IPR(214) .GT. 0) PAR(80)  = PAR(84) / IPR(214)
      PAR(19)  = PAR(84)
      IF (IPR(189) .EQ. 1) THEN
        PAR(20) = PAR(19)
      ELSE
        PAR(20) = 0.0
      ENDIF
      O11 = OR(1, 1)
      O12 = OR(1, 2)
      O13 = OR(1, 3)
      O22 = OR(2, 2)
      O23 = OR(2, 3)
      O33 = OR(3, 3)
      IF (NINT(PAR(100 + IPR(187)) / PAR(80)) .GT. 130) THEN
        CALL GEN014 (IPR(186), IPR(187))
        IF (NINT(PAR(100 + IPR(187)) / PAR(80)) .GT. 130) THEN
          CALL GEN014 (IPR(185), IPR(187))
        ENDIF
      ENDIF
      DO 20 K = 1, 3
        KK           = IPR(184 + K)
        NGRID        = NINT(PAR(100 + KK) / (PAR(80) * 12)) * 12
        PAR(80  + K) = 1.0 / NGRID
        IPR(193 + K) = NGRID
        MGR(K)       = IFIX(NGRID * PAR(84) * PAR(112 + KK)) + 1
   20 CONTINUE
      DO 30 K = 1, 3
        IPR(394 + IPR(184 + K)) = IPR(193 + K)
   30 CONTINUE
      N1     = IPR(194)
      N2     = IPR(195)
      N3     = IPR(196)
      N23    = N2 * N3
      NTGRD  = N1 * N23
      KGR(1) = N23
      KGR(2) = N3
      KGR(3) = 1
      IF (IGBL(3) .EQ. 1) THEN
        NMXG = 2 ** 20
      ELSE
        NMXG = 2 ** 24
      ENDIF
      N      = N1 * N2 * N3
      WRITE (LU6, 99986) PAR(80), NTGRD * 100.0 / NPVD
      IF (NTGRD .GT. NPVD .OR. N .GT. NMXG) THEN
        IPR(214) = IPR(214) - 1
        IF (IPR(214) .GT. 0) THEN
          IF (PAR(84) / IPR(214) .LT. 0.41) GOTO 10
        ENDIF
        IF (IGBL(3) .EQ. 1) THEN
          WRITE (LU20, 99973) '_603', 1.0, 1.0
        ELSE
          IPR(2) = 19
        ENDIF
        GOTO 460
      ENDIF
      WRITE (PRBUF, 99999) PAR(80), PAR(84)
C * START WINDOW FOR SOLV/VOID
      IF (IGBL(25) * IGBL(32) .EQ. 1 .AND. IPR(121) .EQ. 0 .AND.
     1    IGBL(3) .NE. 5) THEN
        IWIN = 1
        CALL GGIP (HORS, VERT, 0.0, 1)
        VRT = VERT - 0.6
        CALL GGIP20 (0.0, PRBUF, 68, 0.4, 5 + IGBL(68), 2, 1.0, VRT)
        IF (IPR(483) .GT. 0 .AND. IPR(484) .EQ. 0) THEN
          WRITE (PRBUF, 99968)
          WRITE (LU6, 99971) PRBUF(1:80)
          CALL GGIP20 (0.0, PRBUF, 60, 0.5, 2, 2, 3.0, 1.0)
        ENDIF
        CALL GGIP20 (0.0, 'WorkinG', 7, 3.0, 2, 10, 5.0, 8.0)
        WRITE (PRBUF, 99990) PAR(84)
        CALL GGIP20 (0.0, PRBUF, 68, 0.35, 1, 2, 0.5, 5.0)
        CALL GGIP (0.0, 0.0, 0.0, 6)
        VRT = VRT - 0.2
      ENDIF
      IF (IGBL(63) .GT. 2) THEN
        PAGET = 'VOIDS'
        CALL PLA269 (0)
        CALL PLA269 (14)
        IF (LMT(IENS(IAN), 1) .EQ. 'Cg') THEN
          IAN0 = IAN - 1
        ELSE
          IAN0 = IAN
        ENDIF
        WRITE (PRBUF, 99999) PAR(80), PAR(84)
        WRITE (LU7, 99969) PRBUF
        WRITE (LU6, 99975) (LMT(IENS(I), 1),  I = 1, IAN0)
        WRITE (LU7, 99975) (LMT(IENS(I), 1),  I = 1, IAN0)
        WRITE (LU6, 99974) (RADR(IENS(I), 4), I = 1, IAN0)
        WRITE (LU7, 99974) (RADR(IENS(I), 4), I = 1, IAN0)
        WRITE (LU7, 99989) (CHAR(IPR(184 + K) + ICHAR('W')),
     1    PAR(80 + K), IPR(193 + K),
     2    PAR(100 + IPR(184 + K)) / IPR(193 + K), K = 1, 3)
        IF (IPR(197) .EQ. 1) THEN
          WRITE (LU7, 99997)
          DO 40 K = 1, IAN
            JX1 = IEL(IEN(K))
            J1  = JX1 / 100
            J2  = MOD(JX1, 100)
            NQ1(1 : 1) = CHAR(ICHAR('A') + J1 - 1)
            IF ( J2 .NE. 0) THEN
              NQ1(2 : 2) = CHAR(ICHAR('a') + J2 - 1)
            ELSE
              NQ1(2 : 2) = ' '
            ENDIF
            WRITE (LU7, 99996) K, NQ1(1:2)
   40     CONTINUE
        ENDIF
      ENDIF
      CALL GEN074 (VOID, 0.0, 1, NTGRD)
      NJG(1, 1) = - 1
      NJG(1, 2) = 25
      L         = 0
   50 L         = L + 1
      JGR(L)    = - MGR(L) - 1
   60 JGR(L)    =   JGR(L) + 1
      IF (JGR(L) .GT. MGR(L)) THEN
        L = L - 1
        IF (L .EQ. 0) GOTO 90
        GOTO 60
      ENDIF
      IF (L .LT. 3) GOTO 50
      IF (ABS(JGR(1)) .LT. 2 .AND. ABS(JGR(2)) .LT. 2 .AND.
     1    ABS(JGR(3)) .LT. 2) THEN
        IF (ABS(JGR(1)) + ABS(JGR(2)) + ABS(JGR(3)) .EQ. 0) GOTO 60
        NJG(1, 1) = NJG(1, 1) + 1
        INDX  = NJG(1, 1)
      ELSE
        DO 70 K = 1, 3
          V6(IPR(184 + K)) = PAR(80 + K) * JGR(K)
   70   CONTINUE
        IF (SQRT(GEN006(V6, AA, V6)) .GT. PAR(84)) GOTO 60
        NJG(1, 2) = NJG(1, 2) + 1
        INDX  = NJG(1, 2)
      ENDIF
      INDX3 = INDX * 3
      IF (INDX3 + 3 .GT. 2 * NP23) THEN
        WRITE (LU6, 99979)
        GOTO 460
      ENDIF
      DO 80 K = 1, 3
        JNSC(INDX3 + K) = JGR(K)
   80 CONTINUE
      GOTO 60
   90 NJGR = NJG(1, 2)
      DO 130 N = 2, 4
        NJG(N, 1) = NJG(N - 1, 2) - 1
        NJG(N, 2) = NJG(N - 1, 2) + 8
        DO 120 I = 1, NJGR
          I1 = JNSC(I * 3 - 2)
          I2 = JNSC(I * 3 - 1)
          I3 = JNSC(I * 3)
          IF (ABS(I1) .LT. 2 .AND. ABS(I2) .LT. 2 .AND.
     1        ABS(I3) .LT. 2) THEN
            IF (JNSC(I * 3 - 4 + N) .EQ. 1) THEN
              NJG(N, 1) = NJG(N, 1) + 1
              INDX      = NJG(N, 1)
            ELSE
              GOTO 120
            ENDIF
          ELSE
            J3  = 0
            I1N = I1 + I123(N, 1)
            I2N = I2 + I123(N, 2)
            I3N = I3 + I123(N, 3)
            DO 100 J = 1, NJGR
              IF (ABS(JNSC(J3 + 1) - I1N) +
     1            ABS(JNSC(J3 + 2) - I2N) +
     2            ABS(JNSC(J3 + 3) - I3N) .EQ. 0) GOTO 120
              J3 = J3 + 3
  100       CONTINUE
            NJG(N, 2) = NJG(N, 2) + 1
            INDX      = NJG(N, 2)
          ENDIF
          INDX3 = INDX * 3
          IF (INDX3 + 3 .GT. 2 * NP23) THEN
            WRITE (LU6, 99979)
            GOTO 460
          ENDIF
          DO 110 K = 1, 3
            JNSC(INDX3 + K) = JNSC(I * 3 - 3 + K)
  110     CONTINUE
  120   CONTINUE
  130 CONTINUE
      NHV    = 0
      IVOIDX = -1
  140 IVOIDX = IVOIDX + 1
      IF (IVOIDX .EQ. N1) THEN
        IF (IPR(189) .EQ. 1) THEN
          IF (IPR(43) .EQ. 0) THEN
            PERC = 100.0 * (1 - IPR(190) / FLOAT(NTGRD))
            WRITE (PRBUF, 99992) IPR(198), PERC
          ELSE
            WRITE (PRBUF, 99976)
          ENDIF
          IF (IWIN .EQ. 1) THEN
            VRT = VRT - 0.8
            CALL GGIP20 (0.0, PRBUF, 80, 0.35, 1, 2, 1.0, VRT)
          ENDIF
          WRITE (LU6, 99993) PRBUF(1:80)
          IF (IGBL(63) .GT. 1) THEN
            CALL PLA269 (5)
            WRITE (LU7, 99993) PRBUF(1:80)
            WRITE (LU7, 99985)
          ENDIF
        ENDIF
        NGPV(1)  = -1000
        NGPV(2)  = -1000
        NGPV(3)  = -1000
        ISLA     = ISAR
        IPR(530) = 0
        DO 270 N = 1, NTGRD
          IF (NINT(VOID(N)) .EQ. NGRTR) THEN
            NGRD = N
            IF (IPR(189) .EQ. 2) THEN
              NGB      = NTGRD
              NGE      = NTGRD
              ISLA     = ISLA + 1
              IPR(530) = IPR(530) + 1
              IF (ISLA .GT. NP1 - IPR(75)) THEN
                IF (IGBL(3) .NE. 1) IPR(2) = 25
                GOTO 460
              ENDIF
              IF (ISLA - ISAR .GT. 26) THEN
                IF (ISLA - ISAR .GT. NP41) THEN
                  WRITE (LU6, '(''Too Many Voids'')')
                  WRITE (LU20, 99973) '_604', 1, 1
                  GOTO 460
                ENDIF
                CSLA = ICHAR('Z')
              ELSE
                CSLA = ICHAR('A') + IPR(530) - 1
              ENDIF
              IATC(ISLA) = 0
              JATC(ISLA) = 0
              DO 150 K = 1, 3
                XXO(ISLA, K) = 0.0
                NXYZ0(K)     = 0
  150         CONTINUE
              DO 160 K = 1, 9
                SXYZ(K, IPR(530)) = 0.0
  160         CONTINUE
              VOID(NGRD) = CSLA
            ENDIF
  170       NGRD0  = NGRD - 1
            IGR(1) = NGRD0 / N23
            IGR(3) = NGRD0 - IGR(1) * N23
            IGR(2) = IGR(3) / N3
            IGR(3) = IGR(3) - IGR(2) * N3
            CALL PLA126 (ISLA, NXYZ0, IGR, 2)
            DO 180 L = 1, 3
              NGNX(L) = NXYZ0(L) + IGR(L)
  180       CONTINUE
            NJI = 1
            IF (NGPV(3) + 1 .EQ. NGNX(3)) THEN
              IF (NGPV(2) .EQ. NGNX(2)) THEN
                IF (NGPV(1) .EQ. NGNX(1)) NJI = 4
              ENDIF
            ELSE IF (NGPV(2) + 1 .EQ. NGNX(2)) THEN
              IF (NGPV(1) .EQ. NGNX(1)) THEN
                IF (NGPV(3) .EQ. NGNX(3)) NJI = 3
              ENDIF
            ELSE IF (NGPV(1) + 1 .EQ. NGNX(1)) THEN
              IF (NGPV(2) .EQ. NGNX(2)) THEN
                IF (NGPV(3) .EQ. NGNX(3)) NJI = 2
              ENDIF
            ENDIF
            IF (NJI .EQ. 1) THEN
              NJ3    = - 3
              NJB    = 1
              NJE    = NJGR
            ELSE
              NJ3 = NJG(NJI - 1, 2) * 3 - 3
              NJB = NJG(NJI - 1, 2) + 1
              NJE = NJG(NJI    , 2)
            ENDIF
            DO 190 L = 1, 3
              NGPV(L) = NGNX(L)
  190       CONTINUE
            DO 250 NJ = NJB, NJE
              NJ3 = NJ3 + 3
              M   = 1
              DO 220 L = 1, 3
                I193L   = IPR(193 + L)
                NXYZ(L) = NXYZ0(L)
                IJGRL   = IGR(L) + JNSC(NJ3 + L)
  200           IF (IJGRL .LT. 0) THEN
                  IJGRL   = IJGRL   + I193L
                  NXYZ(L) = NXYZ(L) - I193L
                  GOTO 200
                ELSE
  210             IF (IJGRL .GE. I193L) THEN
                    IJGRL   = IJGRL   - I193L
                    NXYZ(L) = NXYZ(L) + I193L
                    GOTO 210
                  ENDIF
                ENDIF
                M       = M + IJGRL * KGR(L)
                IJGR(L) = IJGRL
  220         CONTINUE
              IVOIDM = NINT(VOID(M))
              IF (IVOIDM .LT. NGRTR) THEN
                IF (IVOIDM .NE. NDOT) THEN
                  IF (IPR(189) .EQ. 1) THEN
                    VOID(M) = NDOT
                  ELSE
                    VOID(M) = CSLA
                  ENDIF
                  CALL PLA126 (ISLA, NXYZ, IJGR, 1)
                ENDIF
              ELSE IF (IVOIDM .EQ. NGRTR) THEN
                IF (IPR(189) .EQ. 2) THEN
                    IF (NGE + 2 .GT. NPVD) THEN
                      IF (NGB .GT. NTGRD) THEN
                        I = NTGRD
                        J = NGB
  230                   I = I + 2
                        VOID(I - 1) = VOID(J + 1)
                        VOID(I)     = VOID(J + 2)
                        J = J + 2
                        IF (J .LT. NGE) GOTO 230
                        NGB = NTGRD
                        NGE = I
                      ENDIF
                      IPR(214) = IPR(214) - 1
                      GOTO 10
                    ENDIF
                    NGE = NGE + 2
                    NXYZP = 555
                    NXYZM = 100
                    DO 240 I = 1, 3
                      NXYZP = NXYZP
     1                      + NXYZ(I) * NXYZM / IPR(193 + I)
                      NXYZM = NXYZM / 10
  240               CONTINUE
                    VOID(NGE - 1) = NXYZP
                    VOID(NGE)     = M
                    VOID(M)       = CSLA
                ENDIF
              ENDIF
  250       CONTINUE
            IF (IPR(189) .EQ. 2) THEN
              IF (NGE .GT. NGB) THEN
                NGB   = NGB + 2
                NXYZP = NINT(VOID(NGB - 1))
                NXYZM = 100
                DO 260 I = 1, 3
                  NXYZI    = NXYZP / NXYZM
                  NXYZ0(I) = (NXYZI - 5) * IPR(193 + I)
                  NXYZP    = NXYZP - NXYZI * NXYZM
                  NXYZM    = NXYZM / 10
  260           CONTINUE
                NGRD = NINT(VOID(NGB))
                GOTO 170
              ENDIF
            ENDIF
          ENDIF
  270   CONTINUE
        J1 = -1
  280   J1 = J1 + 1
        IF (J1 .EQ. IPR(194)) GOTO 300
        IF (IPR(197) .EQ. 1 .AND. IGBL(63) .GT. 2) THEN
          CALL PLA269 (-2)
          WRITE (LU7, 99998) CHAR(IPR(185) + ICHAR('W')), J1,
     1      IPR(194) - 1, CHAR(IPR(186) + ICHAR('W')),
     2      CHAR(IPR(187) + ICHAR('W'))
        ENDIF
        J2  = -1
  290   J2  = J2 + 1
        IF (J2 .EQ. IPR(195)) GOTO 280
        KK0 = J1 * N23 + J2 * N3
        KKM = KK0 + N3
        KK0 = KK0 + 1
        IF (IPR(197) .EQ. 1 .AND. IGBL(63) .GT. 2) THEN
          CALL PLA269 (1)
          WRITE (LU7, 99995) (CHAR(NINT(VOID(KK))), KK = KK0, KKM)
        ENDIF
        GOTO 290
  300   PAR(79)  = PAR(98) / NTGRD
        PAR(150) = IPR(188) * PAR(79)
        IF (IWIN .EQ. 1) THEN
          WRITE (PRBUF, 99990) PAR(84), IPR(198)
          CALL GGIP20 (0.0, PRBUF, 68, 0.35, 0, 2, 0.5, 5.0)
          CALL GGIP20 (0.0, PRBUF(69:76), 8, 0.35, 0, 2, 21.0, 5.0)
          CALL GGIP20 (0.0, 'WorkinG', 7, 3.0, 0, 10, 5.0, 8.0)
          CALL GGIP20 (0.0, 'Collect S.A.R.', 14, 0.35, 0, 2, 11.0,
     1                 3.0)
          IF (IPR(483) .GT. 0 .AND. IPR(484) .EQ. 0) THEN
            WRITE (PRBUF, 99968)
            CALL GGIP20 (0.0, PRBUF, 60, 0.5, 0, 2, 3.0, 1.0)
          ENDIF
          CALL GGIP (0.0, 0.0, 0.0, 6)
        ENDIF
        IF (PAR(150) .GT. 0.0) THEN
          IF (IGBL(63) .GT. 1) THEN
            IF (IPR(197) .EQ. 1) CALL PLA269 (0)
            CALL PLA269 (3)
            PCT = PAR(150) * 100.0 / PAR(98)
            WRITE (LU6, 99994) PAR(150), PAR(98), PCT
            WRITE (LU7, 99994) PAR(150), PAR(98), PCT
            IF (IPR(189) .EQ. 2) THEN
              WRITE (LU6, 99981)
              CALL PLA269 (6)
              WRITE (LU7, 99981)
              IF (IPR(210) .NE. 1) THEN
                CALL PLA269 (4)
                WRITE (LU7, 99980)
                WRITE (LU6, 99980)
              ENDIF
              WRITE (PRBUF, 99984)
              WRITE (LU6, 99970) PRBUF(1:80)
              CALL PLA269 (3)
              WRITE (LU7, 99970) PRBUF(1:80)
              IF (IWIN .EQ. 1) THEN
                IF (ISLA - ISAR .GT. 15)
     1            PRBUF(55:) = ' Sqrt(Eigenvalues) (Ang.)'
                VRT = VRT - 0.8
                CALL GGIP20 (0.0, PRBUF, 80, 0.35, 5 + IGBL(68),
     1                             2, 1.0, VRT)
                VRT = VRT - 0.2
              ENDIF
            ENDIF
          ENDIF
          DO 340 K = ISAR + 1, ISLA
            KISAR  = K - ISAR
            APERC  = JATC(K) * 100.0 / NTGRD
            AVOL   = APERC * PAR(98) / 100.0
            PAR(289) = MAX (PAR(289), AVOL)
            DO 310 L = 1, 3
              XXO(K, L) = XXO(K, L) / JATC(K)
              SXYZ(9 + L, KISAR) = XXO(K, L)
  310       CONTINUE
            DUMW(1, 1) = SXYZ(4, KISAR) - SXYZ(1, KISAR)**2 / JATC(K)
            DUMW(1, 2) = SXYZ(7, KISAR)
     1                 - SXYZ(1, KISAR) * SXYZ(2, KISAR) / JATC(K)
            DUMW(1, 3) = SXYZ(8, KISAR)
     1                 - SXYZ(1, KISAR) * SXYZ(3, KISAR) / JATC(K)
            DUMW(2, 2) = SXYZ(5, KISAR)
     1                 - SXYZ(2, KISAR)**2 / JATC(K)
            DUMW(2, 3) = SXYZ(9, KISAR)
     1                 - SXYZ(2, KISAR) * SXYZ(3, KISAR) / JATC(K)
            DUMW(3, 3) = SXYZ(6, KISAR)
     1                 - SXYZ(3, KISAR)**2 / JATC(K)
            CALL GEN024 (DUMW, EV, EW, DUMV)
            CALL GEN004 (ROR, DUMV, DUMW)
            DO 330 I = 1, 3
              VMAX = 0.0
              DO 320 J = 1, 3
                VMAX = MAX (VMAX, ABS(DUMW(J, I)))
  320         CONTINUE
              OHASHI = IATC(K) * AVOL / JATC(K)
              IATCK  = MIN (999999, IATC(K))
              OHASH  = MIN (9999.9, OHASHI)
              WRITE (PRBUF, 99987) K - ISAR, JATC(K), IATCK,
     1          NINT(APERC), NINT(AVOL), OHASH,
     2          (XXO(K, L), L = 1, 3), I, (DUMW(J, I) / VMAX, J = 1, 3),
     3          SQRT(EW(I) / JATC(K))
              IF (I .NE. 1) CALL GEN038 (PRBUF, 1, 53)
              WRITE (LU6, 99972) PRBUF(1:80)
              IF (IGBL(63) .GT. 1) THEN
                CALL PLA269 (1)
                WRITE (LU7, 99972) PRBUF(1:80)
              ENDIF
              IF (IWIN .EQ. 1) THEN
                IF (ISLA - ISAR .GT. 15) THEN
                  IF (I .EQ. 3) THEN
                    WRITE (PRBUF, 99967) K - ISAR, JATC(K), IATCK,
     1          NINT(APERC), NINT(AVOL), OHASH,
     2          (XXO(K, L), L = 1, 3), (SQRT(EW(L) / JATC(K)), L = 1, 3)
                    VRT = VRT - 0.4
                    CALL GGIP20 (0.0, PRBUF, 80, 0.35, 1, 2, 1.0, VRT)
                  ENDIF
                ELSE
                  VRT = VRT - 0.4
                  CALL GGIP20 (0.0, PRBUF, 80, 0.35, 1, 2, 1.0, VRT)
                ENDIF
              ENDIF
  330       CONTINUE
  340     CONTINUE
          N1     = ISAR + 1
          RHODUM = 0.0
          CALL PLA138 (2, 4.5, N1, ISLA, RHODUM, IDUM)
        ELSE
          WRITE (PRBUF, 99988)
          IF (IWIN .EQ. 1) THEN
            VRT = VRT - 5.0
            CALL GGIP20 (0.0, PRBUF, 60, 0.45, 3, 2, 1.0, VRT)
          ENDIF
          WRITE (LU6, 99971) PRBUF
          IF (IGBL(63) .GT. 1) WRITE (LU7, 99971) PRBUF
          IPR(210) = 0
        ENDIF
        IF (IPR(200) .EQ. 2) THEN
          WRITE (LU6, 99978)
          IF (IGBL(63) .GT. 0) THEN
            CALL PLA269 (3)
            WRITE (LU7, 99978)
          ENDIF
          WRITE (LU20, 99973) '_601', PAR(289), PAR(289)
          IF (PAR(289) .GT. 20.0) THEN
            CALL PLA015 (0, 4)
          ELSE
            CALL PLA015 (0, 3)
          ENDIF
        ENDIF
        GOTO 470
      ENDIF
      IF (IVOIDX + 1 .EQ. N1) THEN
        IF (IPR(198) .GT. 0) THEN
          IF (IGBL(25) * IGBL(32) .EQ. 1 .AND.
     1        IPR(121) .EQ. 0 .AND. IGBL(3) .NE. 5) THEN
            CALL GGIP20 (0.0, PRBUF(69:76), 8, 0.35, 0, 2, 21.0, 5.0)
            WRITE (PRBUF, 99990) PAR(84), IPR(198)
            CALL GGIP20 (0.0, PRBUF(69:76), 8, 0.35, 1, 2, 21.0, 5.0)
            WRITE (LU6, 99972) PRBUF(1:80)
            CALL GGIP20 (0.0, 'Collect S.A.R.', 14, 0.35, 3, 2, 11.0,
     1                   3.0)
            CALL GGIP (0.0, 0.0, 0.0, 6)
          ENDIF
        ENDIF
      ENDIF
      XXO(IAT, IPR(185)) = IVOIDX * PAR(81)
      IVOIDY             = -1
  350 IVOIDY             = IVOIDY + 1
      IF (IVOIDY .GE. N2) GOTO 140
      XXO(IAT, IPR(186)) = IVOIDY * PAR(82)
      IVOIDZ             = -1
  360 IVOIDZ             = IVOIDZ + 1
      IF (IVOIDZ .GE. N3) GOTO 350
      XXO(IAT, IPR(187)) = IVOIDZ * PAR(83)
      NHV                = NHV + 1
      IF (NINT(VOID(NHV)) .NE. 0) GOTO 360
      DO 380 IO = 1, 3
        JO = 4 - IO
        KO = JO + 3
        XXO(IAT, KO) = 0.0
        DO 370 LO = JO, 3
          XXO(IAT, KO) = XXO(IAT, KO) + XXO(IAT, LO) * OR(JO, LO)
  370   CONTINUE
  380 CONTINUE
      IPR(199) = 0
      CALL PLA070 (IAT, KAT)
      IF (IPR(2) .NE. 0) THEN
        IF (IGBL(3) .EQ. 1) IPR(2) = 0
        GOTO 470
      ENDIF
      IF (IPR(199) .LT. 0) THEN
        IPR(190)  = IPR(190) + 1
        VOID(NHV) = ICHAR(' ')
      ELSE IF (IPR(199) .EQ. 0) THEN
        DO 400 JS = 1, NSYM
          DO 390 I9 = 1, 3
            XJX(I9 + 3) = 0.0
            XJX(I9) = XXO(IAT, I9)
  390     CONTINUE
          CALL SGSM (ICL, JS, XJX, LU6, 3, IERR)
          IVDX = MOD(NINT(XJX(6 + IPR(185)) / PAR(81)) + N1, N1)
          IVDY = MOD(NINT(XJX(6 + IPR(186)) / PAR(82)) + N2, N2)
          IVDZ = MOD(NINT(XJX(6 + IPR(187)) / PAR(83)) + N3, N3)
          NHVL = IVDX * N23 + IVDY * N3 + IVDZ + 1
          IF (NINT(VOID(NHVL)) .EQ. 0) THEN
            IPR(190)  = IPR(190) + 1
            IPR(198)  = IPR(198) + 1
            IF (IPR(198) .EQ. 1) WRITE (LU6, 99991)
            IF (MOD(IPR(198), 1000) .EQ. 0) THEN
              IF (IGBL(25) * IGBL(32) .EQ. 1 .AND.
     1            IGBL(3) .NE. 5 .AND. IPR(121) .EQ. 0) THEN
                CALL GGIP20 (0.0, PRBUF(69:76), 8, 0.35, 0, 2, 21.0,
     1                       5.0)
                WRITE (PRBUF, 99990) PAR(84), IPR(198)
                CALL GGIP20 (0.0, PRBUF(69:76), 8, 0.35, 1, 2, 21.0,
     1                       5.0)
                CALL GGIP (0.0, 0.0, 0.0, 6)
              ELSE
                IF (IPR(198) .GT. IPR(491) * NSYM) THEN
                  IF (IGBL(3) .EQ. 1) THEN
                    WRITE (LU20, 99973) '_602', 1.0, 1.0
                    GOTO 460
                  ENDIF
                ENDIF
              ENDIF
            ENDIF
            VOID(NHVL) = ICHAR('>')
          ENDIF
  400   CONTINUE
      ELSE
        CRIT   = PAR(23) - PAR(20)
        CRIT2  = CRIT**2
        LSKX   = INT(CRIT / (PAR(81) * PAR(100 + IPR(185)))) + 1
        LSKY   = INT(CRIT / (PAR(82) * PAR(100 + IPR(186)))) + 1
        LSKZ   = INT(CRIT / (PAR(83) * PAR(100 + IPR(187)))) + 1
        IVD    = IPR(59) + 1
        IF (IVD .LT. 10) THEN
          ICHR = ICHAR('0') + IVD
        ELSE
          ICHR = ICHAR('*')
        ENDIF
        DO 450 JS = 1, NSYM
          DO 410 I = 1, 3
            XJX(I + 3) = 0.0
            XJX(I) = XXO(KAT, I)
  410     CONTINUE
          CALL SGSM (ICL, JS, XJX, LU6, 3, IERR)
          XXOM5  = XJX(6 + IPR(185))
          XXOM6  = XJX(6 + IPR(186))
          XXOM7  = XJX(6 + IPR(187))
          LVKX   = NINT (XXOM5 / PAR(81))
          LVKY   = NINT (XXOM6 / PAR(82))
          LVKZ   = NINT (XXOM7 / PAR(83))
          LXMIN  = MAX (LVKX - LSKX, IVOIDX)
          LYMIN  = MAX (LVKY - LSKY, 0)
          LZMIN  = MAX (LVKZ - LSKZ, 0)
          LXMAX  = MIN (LVKX + LSKX, N1 - 1)
          LYMAX  = MIN (LVKY + LSKY, N2 - 1)
          LZMAX  = MIN (LVKZ + LSKZ, N3 - 1)
          LVOIDX = LXMIN  - 1
  420     LVOIDX = LVOIDX + 1
          IF (LVOIDX .GT. LXMAX) GOTO 450
          XJX(IPR(185)) = LVOIDX * PAR(81) - XXOM5
          LVOIDY = LYMIN  - 1
  430     LVOIDY = LVOIDY + 1
          IF (LVOIDY .GT. LYMAX) GOTO 420
          XJX(IPR(186)) = LVOIDY * PAR(82) - XXOM6
          NHVL   = LVOIDX * N23 + LVOIDY * N3 + LZMIN
          LVOIDZ = LZMIN  - 1
  440     LVOIDZ = LVOIDZ + 1
          IF (LVOIDZ .GT. LZMAX) GOTO 430
          NHVL = NHVL + 1
          IF (NINT(VOID(NHVL)) .NE. 0) GOTO 440
          XJX(IPR(187)) = LVOIDZ * PAR(83) - XXOM7
          IF ((O11 * XJX(1) + O12 * XJX(2) + O13 * XJX(3))**2
     1                      + (O22 * XJX(2) + O23 * XJX(3))**2
     2      + (O33 * XJX(3))**2 .LT. CRIT2) VOID(NHVL) = ICHR
          GOTO 440
  450   CONTINUE
        IPR(199) = 0
      ENDIF
      GOTO 360
  460 IPR(210) = 0
  470 IF (IPR(188) .GT. 0) THEN
        IF (IPR(326) .EQ. 2) THEN
          IF (IWIN .EQ. 1) CALL PLA127
        ELSE IF (IPR(326) .EQ. 3) THEN
          IPR(580) = 2
C * GENERATE F3D STYLE INPUT FOR SOLV-MAP
          OPEN (UNIT = LU65, FILE = NAME(1)(1:KNM(1))//'.slv',
     1          STATUS = 'UNKNOWN')
          WRITE (LU65, 99966) JID(1:50),
     1          ((OR(I, J), J = 1, 3), I = 1, 3),
     2          (PAR(I), I = 101, 106), (IPR(I), I = 395, 397)
          NX   = IPR(395)
          NY   = IPR(396)
          NZ   = IPR(397)
          MXYZ = NX * NY * NZ
          NXY  = NX * NY
          CALL GEN074 (VOID, 0.0, 1, MXYZ)
          REWIND LU15
  480     READ (LU15, END = 490) IX, IY, IZ
          IF (IX .LT. 0)  IX = IX + NX
          IF (IY .LT. 0)  IY = IY + NY
          IF (IZ .LT. 0)  IZ = IZ + NZ
          IF (IX .GE. NX) IX = IX - NX
          IF (IY .GE. NY) IY = IY - NY
          IF (IZ .GE. NZ) IZ = IZ - NZ
          VOID (IZ * NXY + IY * NX + IX + 1) = 1.0
          GOTO 480
  490     DO 510 K = 1, NZ
            M = (K - 1) * NXY
            WRITE (LU65, 99965) K - 1
            DO 500 J = 1, NY
              N = M + (J - 1) * NX
              WRITE (LU65, 99964) (NINT(VOID(N + I)), I = 1, NX)
  500       CONTINUE
  510     CONTINUE
          WRITE (LU65, 99963) IPR(39)
          DO 520 I = 1, IPR(39)
            CALL GEN048 (-4, IFG(I), 15, IVAL)
            NQ1 = LMT(IVAL + 1, 1)
            CALL GEN020 (1, NQ1, 2, 2)
            N = 0
            IF (NQ1(1:1) .EQ. ' ') N = 1
            WRITE (LU65, 99962) NQ1(1+N:4+N), (XXO(I, J), J = 1, 3)
  520     CONTINUE
          CLOSE (LU65)
C * F3D
          PLPATH = ' '
          NE = FINDEXE ('F3DEXE', PLPATH, 'f3d')
          IF (NE .GT. 0) THEN
            PLPATH(NE + 1:) = ' '//NAME(1)(1:KNM(1))//'.slv &'
            CALL SYSTEM (PLPATH)
          ENDIF
          IPR(580) = -2
          IPR(2)   = -1
        ENDIF
      ENDIF
      IGBL(23) = 10
      RETURN
99999 FORMAT ('Search for and Analysis of Solvent Accessible Voids',
     1        ' in the Structure - Grid =', F5.2,
     2        'Angstrom, Probe Radius =', F6.2, ' Angstrom.')
99998 FORMAT (A, '-Section : ', I5, ' - (Max =', I5, ') --- ',
     1        A, '-Vertical and ', A, '-Horizontal', /)
99997 FORMAT (//, 'SOLV-Map Gridpoint Entries: ', //,
     1            '- Numerical  : Atom Type Number', /,
     2            '- ''*''        : Atom Type Number > 9', /,
     3            '- Alphabetic : Independent Solvent Accessible Void',
     4        /)
99996 FORMAT (/, 'Atom Type Number ', I3, ' = Label ', A)
99995 FORMAT (130A)
99994 FORMAT (':: Total Potential Solvent Area Vol', F9.1, ' Ang^3', /,
     1        18X, 'per Unit Cell Vol', F9.1, ' Ang^3 [',F4.1,'%]', /)
99993 FORMAT (/, A, /)
99992 FORMAT (':: Nr of VOID Grid-points =', I8,
     1       ',  - Percent Filled Space:', F5.1)
99991 FORMAT (':: Note: VOID/SOLV/SQUEEZE is relatively',
     1       ' compute intense and experimental', /)
99990 FORMAT (':: Nr of gridpoints at least', F5.2, ' Ang.',
     1        ' from nearest vdWaals Surface=', I8)
99989 FORMAT (3(/, ':: Grid: ', A, '-Axis Step =', F7.4,
     1        ' = Points', I4, ', Angstrom Step =', F5.2), //)
99988 FORMAT (':: Unit cell Contains NO Residual Solvent',
     1       ' Accessible Void.')
99987 FORMAT (I2, I7, '[', I6, ']', I3, I6, '[', F6.1, ']', 1X, 3F6.3,
     1        I2, 1X, 3F6.3, F6.2)
99986 FORMAT (':: VOID/SOLV Gridstep (Angstrom) (re)set to', F5.2,
     1       ', Percent Memory =', F5.1)
99985 FORMAT ('(See A.I. Kitajgorodskij, Molecular Crystals and',
     1        ' Molecules, New-York, Academic Press, 1973.)', /)
99984 FORMAT ('Area #GridPoint VolPerc.  Vol(A^3)', 2X,
     1        'X(av) Y(av) Z(av) Eigenvector(frac) Sig(Ang)')
99981 FORMAT ('Note: Expected volumes for solvent molecules are:',
     1       /, 6X, 'A hydrogen bonded H2O-molecule      40 Ang^3',
     2       /, 6X, 'Small molecules (e.g. Toluene) 100-300 Ang^3',
     3      //, 6X, 'Values below for gridpoints and volumes in [] '
     4       /, 6X, 'refer to areas where atom centers may reside.')
99980 FORMAT (/, ':: Use the CALC SQUEEZE instruction to calculate '
     1 , 'and optionally correct for', /,
     2 ':: Density identified in solvent accessible areas',
     3 ' (Reflection data required)')
99979 FORMAT (/, ':: Internal Problem: Request Aborted')
99978 FORMAT (' :: Note: use CALC VOID (not CALC SOLV) for',
     1       ' Packing Index. ', /)
99976 FORMAT ('No Packing Index - Disordered Structure')
99975 FORMAT ('van der Waals (or ion) Radii used in the Analysis',
     1        /, 80('='), /, 16(3X, A))
99974 FORMAT (80('-'), /, 16F5.2)
99973 FORMAT (A, 2F10.0)
99972 FORMAT (A)
99971 FORMAT (/, A, /)
99970 FORMAT (/, A, /, 80('-'))
99969 FORMAT (A, /, 132('='), /)
99968 FORMAT ('Warning: No Hydrogen Atoms in VOID/SQUEEZE Model')
99967 FORMAT (I2, I7, '[', I6, ']', I3, I6, '[', F6.1, ']', 1X, 3F6.3,
     1        3F8.3)
99966 FORMAT ('TITL ', A, /, 'TRAN ', 3F9.4, F8.4, 2F9.4, 2F8.4, F9.4,
     1  /, 'CELL ', 6F9.4, /, 'SIZE', 3I8)
99965 FORMAT ('SECTION', I8)
99964 FORMAT (250I1)
99963 FORMAT ('ATOMS',  I8)
99962 FORMAT (A, 3F10.4)
      END
      SUBROUTINE PLA126 (ISLA, NXYZ, IJGR, NADD)
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16,
     1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP25=99,NP29=63,
     2 NP38=125,NP39=30,NP41=200,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      DIMENSION NXYZ(3), IJGR(3), VO(3), IJGRD(3)
      IPR(188) = IPR(188) + 1
      IF (IPR(189) .EQ. 2) THEN
        JATC(ISLA) = JATC(ISLA) + 1
        IF (NADD .EQ. 2) IATC(ISLA) = IATC(ISLA) + 1
        ISL        = IPR(530)
        IATP(ISLA) = IATP(ISLA) + 1
        DO 10 I = 1, 3
          J            = IPR(184 + I)
          V6(J)        = PAR(80 + I)  * (NXYZ(I) + IJGR(I))
          XXO(ISLA, J) = XXO(ISLA, J) + V6(J)
   10   CONTINUE
        VO(1) = OR(1, 1) * V6(1) + OR(1, 2) * V6(2) + OR(1, 3) * V6(3)
        VO(2) =                    OR(2, 2) * V6(2) + OR(2, 3) * V6(3)
        VO(3) =                                       OR(3, 3) * V6(3)
        SXYZ(1, ISL) = SXYZ(1, ISL) + VO(1)
        SXYZ(2, ISL) = SXYZ(2, ISL) + VO(2)
        SXYZ(3, ISL) = SXYZ(3, ISL) + VO(3)
        SXYZ(4, ISL) = SXYZ(4, ISL) + VO(1)**2
        SXYZ(5, ISL) = SXYZ(5, ISL) + VO(2)**2
        SXYZ(6, ISL) = SXYZ(6, ISL) + VO(3)**2
        SXYZ(7, ISL) = SXYZ(7, ISL) + VO(1) * VO(2)
        SXYZ(8, ISL) = SXYZ(8, ISL) + VO(1) * VO(3)
        SXYZ(9, ISL) = SXYZ(9, ISL) + VO(2) * VO(3)
        IF (IPR(326) .GT. 0) THEN
          DO 20 I = 1, 3
            IF (IPR(326) .EQ. 1) THEN
              IJG = MOD(NXYZ(I) + IJGR(I), IPR(193 + I))
              IF (IJG .LT. 0) IJG = IJG + IPR(193 + I)
              IJGRD(IPR(184 + I)) = IJG
            ELSE
              IJGRD(IPR(184 + I)) = NXYZ(I) + IJGR(I)
            ENDIF
   20     CONTINUE
          WRITE (LU15) IJGRD, ISL, NADD
        ENDIF
      ENDIF
      RETURN
      END
      SUBROUTINE PLA127
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118,
     1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NPVD=40000000,
     2 NP22=256,NP23=18000,NP25=99,NP29=63,NP38=125,NP39=30,NP41=200,
     3 NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9),
     1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10),
     2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10),
     3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770)
      COMMON // JNSC(2, NP23), VOID(NPVD)
      COMMON /ISCR/ NXYZ(3), NXYZ0(3), IGR(3), JGR(3), KGR(3), MGR(3),
     1              IJGR(3)
      COMMON /CGGT/ IGGT
      CHARACTER IGGT*80
      COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0
      DIMENSION IGMN(3), IGMX(3), ISH(3), IMX(3),
     1  XMN(3), XMX(3)
      COMMON /UNITC/ IUNCL(2, 12)
      IPR(116) = 1
      IPR(140) = 0
      IPR(526) = 0
      IND3     = 3
      IND2     = 2
      IND1     = 1
      IPR(527) = 1
      IPR(528) = 1
      IPR(529) = 0
      IPR(532) = 0
      IPR(533) = 1
      IPR(534) = 1
      IGBL(75) = 0
      NAT      = IPR(39)
      NSYM     = IPR(48)
      NRES     = IPR(75)
   10 CALL PLA013 (1, 1)
      IF (IGGT(1:4) .EQ. 'EXIT') LRET = 2
      IF (IGGT(1:1) .EQ. 'N')    LRET = 2
      IF (LRET .EQ. 1) THEN
        GOTO 30
      ELSE IF (LRET .EQ. 2) THEN
        GOTO 620
      ELSE IF (LRET .EQ. 3) THEN
        GOTO 20
      ELSE IF (LRET .EQ. 4) THEN
        GOTO 60
      ENDIF
   20 IPR(526) = -1
   30 IF (IPR(526) .EQ. -1) THEN
        DUMMY = PAR(389) / GL(5)
        CALL GEN051 (1, RMAT, DUMMY, IPR(479))
        IPR(526) = 0
      ELSE IF (IPR(526) .EQ. 0) THEN
        CALL GEN021 (RMAT, 1)
        DO 40 I = 1, 3
          X = - GL(27 + I) / GL(5)
          L = I
          CALL GEN051 (0, RMAT, X, L)
   40   CONTINUE
      ELSE IF (IPR(526) .EQ. 1) THEN
        CALL GEN043 (2, RMAT,  90.0 / GL(5))
        IND3 = 1
        IND2 = 2
        IND1 = 3
      ELSE IF (IPR(526) .EQ. 2) THEN
        CALL GEN043 (1, RMAT, -90.0 / GL(5))
        IND3 = 2
        IND2 = 1
        IND1 = 3
      ELSE IF (IPR(526) .EQ. 3) THEN
        CALL GEN043 (1, RMAT,   0.0 / GL(5))
        IND3 = 3
        IND2 = 2
        IND1 = 1
      ELSE
        GOTO 50
      ENDIF
      CALL GEN096 (RMAT, IROTX, IROTY, IROTZ, IDET, V6, YANK, QM)
      GL(28)   = IROTX
      GL(29)   = IROTY
      GL(30)   = IROTZ
      IPR(526) = 4
   50 ANG = IPR(116) * 3.0 / GL(5)
      CALL GEN043 (2, ROTM1, - ANG)
      CALL GEN043 (2, ROTM2,   ANG)
   60 CALL GGIP (HORS, VERT, 0.0, 1)
      ISTER    = IPR(533)
      HRS      = HORS / ISTER
      CALL PLA117 (HORS, VERT, 0)
      DO 70 I = 1, 3
        IGMN(I) =  999
        IGMX(I) = -999
        XMN(I)  =  999.0
        XMX(I)  = -999.0
   70 CONTINUE
      NOFF  = 0
      NBOND = 0
      NP    = 0
      IF (IPR(527) .EQ. 1) THEN
        DO 110 I = 1, 2
          V3(1) = I - 1
          DO 100 J = 1, 2
            V3(2) = J - 1
            DO 90 K = 1, 2
              V3(3) = K - 1
              CALL GEN002 (1, OR, V3, V2, XLNG)
              VOID(NOFF + 1) = - (V3(1) * 4 + V3(2) * 2 + V3(3))
              DO 80 M = 1, 3
                XMN(M) = MIN (XMN(M), V2(M))
                XMX(M) = MAX (XMX(M), V2(M))
                VOID (NOFF + 1 + M) = V2(M)
   80         CONTINUE
              NP   = NP + 1
              NOFF = NOFF + 7
   90       CONTINUE
  100     CONTINUE
  110   CONTINUE
        DO 130 I = 1, 2
          DO 120 J = 1, 12
            JNSC(I, J) = IUNCL(I, J)
  120     CONTINUE
  130   CONTINUE
        NBOND = 12
      ENDIF
      IF (IPR(528) .EQ. 1) THEN
        DO 250 K = 1, NRES
          IF (IPR(140) .EQ. 0 .OR. K .EQ. IPR(140)) THEN
            CALL GEN074 (V5, 0.0, 1, 3)
            N = 0
            DO 160 I = 1, NAT
              CALL GEN048 (-6, IFG(I), 9, IRESI)
              IF (IRESI .EQ. K) THEN
                N = N + 1
                DO 150 J = 1, 3
                  V5(J) = V5(J) + XXO(I, J)
  150           CONTINUE
              ENDIF
  160       CONTINUE
            DO 170 J = 1, 3
              V5(J) = V5(J) / N
  170       CONTINUE
            IF (IPR(537) .EQ. 1) THEN
              NS = NSYM
            ELSE
              NS = 1
            ENDIF
            DO 240 N = 1, NS
              DO 180 I = 1, 3
                XJX(I + 3) = 0.0
                XJX(I)     = V5(I)
  180         CONTINUE
              CALL SGSM (IDM, N, XJX, LU6, 3, IERR)
              DO 190 I = 1, 3
                XJX(I + 3) =  - (INT(XJX(6 + I) + 5.0) - 5)
  190         CONTINUE
              DO 230 I = 1, NAT
                CALL GEN048 (-6, IFG(I), 9, IRESI)
                IF (IRESI .EQ. K) THEN
                  DO 200 J = 1, 3
                    XJX(J) = XXO(I, J)
  200             CONTINUE
                  CALL SGSM (IDM, N, XJX, LU6, 3, IERR)
                  DO 210 J = 1, 3
                    V2(1) = OR(1, 1) * XJX(7) + OR(1, 2) * XJX(8)
     1                    + OR(1, 3) * XJX(9)
                    V2(2) = OR(2, 2) * XJX(8) + OR(2, 3) * XJX(9)
                    V2(3) = OR(3, 3) * XJX(9)
  210             CONTINUE
                  DO 220 J = 1, 3
                    XMN(J) = MIN (XMN(J), V2(J))
                    XMX(J) = MAX (XMX(J), V2(J))
                    VOID (NOFF + 1 + J) = V2(J)
  220             CONTINUE
                  VOID (NOFF + 1) = I
                  NP   = NP   + 1
                  NOFF = NOFF + 7
                ENDIF
  230         CONTINUE
  240       CONTINUE
          ENDIF
  250   CONTINUE
        NOF = IPR(527) * 8
        DO 300 I = NOF + 1, NP
          NI = NINT (VOID(I * 7 - 6))
          DO 260 K = 1, 3
            V2(K) = VOID(I * 7 - 6 + K)
  260     CONTINUE
          CALL GEN048 (-4, IFG(NI), 15, NO1)
          DISTI = REL(IEN(NO1 + 1)) + 0.4
          DO 290 J = NOF + 1, NP
            NJ = NINT (VOID(J * 7 - 6))
            DO 270 K = 1, 3
              V3(K) = VOID(J * 7 - 6 + K)
  270       CONTINUE
            CALL GEN048 (-4, IFG(NJ), 15, NO2)
            DISTMX = DISTI + REL(IEN(NO2 + 1))
            DIST   = 0
            DO 280 K = 1, 3
              DIST = DIST + (V2(K) - V3(K))**2
  280       CONTINUE
            IF (SQRT(DIST) .LT. DISTMX) THEN
              IF (NBOND .LT. NP23) THEN
                NBOND          = NBOND + 1
                JNSC(1, NBOND) = I
                JNSC(2, NBOND) = J
                IF (NBOND .EQ. NP23) WRITE (LU6, 99997) NP23
              ENDIF
            ENDIF
  290     CONTINUE
  300   CONTINUE
      ENDIF
      NVL = IPR(531)
      NF  = NOFF
      REWIND LU15
  310 READ (LU15, END = 340) IGR, NV, NADD
      IF (NVL .NE. 0 .AND. NV .NE. NVL) GOTO 310
      IF (IPR(529) .NE. 1 .OR. NADD .EQ. 2) THEN
        DO 320 I = 1, 3
          IF (IPR(535) .NE. 0) THEN
            IF (IGR(I) .LT. 0) IGR(I) = IGR(I) + IPR(394 + I)
          ENDIF
          V3(I) = FLOAT(IGR(I)) / IPR(394 + I)
  320   CONTINUE
        V2(1) = OR(1, 1) * V3(1) + OR(1, 2) * V3(2) + OR(1, 3) * V3(3)
        V2(2) =                    OR(2, 2) * V3(2) + OR(2, 3) * V3(3)
        V2(3) =                                       OR(3, 3) * V3(3)
        NP = NP + 1
        NOFF = NOFF + 7
        IF (NOFF .GT. NPVD) GOTO 630
        DO 330 I = 1, 3
          IGMN(I) = MIN (IGMN(I), IGR(I))
          IGMX(I) = MAX (IGMX(I), IGR(I))
          XMN(I)  = MIN (XMN(I),  V2(I))
          XMX(I)  = MAX (XMX(I),  V2(I))
          VOID(NOFF - 6 + I) = V2(I)
          VOID(NOFF - 3 + I) = IGR(I)
  330   CONTINUE
      ENDIF
      GOTO 310
  340 DO 350 I = 1, 3
        ISH(I) = - IGMN(I) + 1
        IMX(I) =   IGMX(I) + ISH(I) + 1
        V8(I)  =   (XMN(I) + XMX(I)) / 2.0
  350 CONTINUE
      WRITE (LU6, 99999)
      WRITE (LU6, 99998)
     1  (IPR(394 + I), IGMN(I), IGMX(I), ISH(I), IMX(I), I = 1, 3)
      CALL GEN074 (XMN,  999.0, 1, 3)
      CALL GEN074 (XMX, -999.0, 1, 3)
      DO 390 I = 1, NP
        N = (I - 1) * 7
        DO 370 M = 1, 3
          V4(M) = VOID(N + 1 + M) - V8(M)
  370   CONTINUE
        CALL GEN002 (1, RMAT, V4, V5, XLNG)
        DO 380 M = 1, 3
          XMN(M) = MIN (XMN(M),  V5(M))
          XMX(M) = MAX (XMX(M),  V5(M))
          VOID(N + 1 + M) = V5(M)
          VOID(N + 4 + M) = VOID(N + 4 + M) + ISH(M)
  380   CONTINUE
  390 CONTINUE
      SHX   = HORS / ((XMX(1) - XMN(1)) * ISTER)
      SHY   = VERT / (XMX(2) - XMN(2))
      SCALE = MIN (SHX, SHY) * 0.80
      DO 410 I = 1, NP
        N = (I - 1) * 7 + 1
        DO 400 M = 1, 3
          VOID (N + M) = SCALE * VOID(N + M)
  400   CONTINUE
  410 CONTINUE
      IP1 =  IMX(IND1) + 1
      IP2 = (IMX(IND2) + 1) * IP1
      IP3 = (IMX(IND3) + 1) * IP2
      IB  = NOFF + 1
      IE  = NOFF + IP3 * 4
      IF (IE .GT. NPVD) GOTO 630
      CALL GEN074 (VOID, 0.0, IB, IE)
      NF0 = NF
  430 NF0 = NF0 + 7
      IF (NF0 .GT. NOFF) GOTO 450
      DO 440 I = 1, 3
        V2(I)  = VOID (NF0 - 6 + I)
        IGR(I) = NINT(VOID(NF0 - 3 + I))
  440 CONTINUE
      IADR = (IGR(IND3) * IP2 + IGR(IND2) * IP1 + IGR(IND1)) * 4 + NOFF
      VOID(IADR + 1) = 99.0
      VOID(IADR + 2) = V2(1)
      VOID(IADR + 3) = V2(2)
      VOID(IADR + 4) = V2(3)
      GOTO 430
  450 DO 500 K = 1, IMX(IND3) + 1
        NBK = (K - 1) * IP2
        DO 490 J = 1, IMX(IND2) + 1
          NBJ = (J - 1) * IP1
          DO 480 I = 1, IMX(IND1) + 1
            NB = (NBK + NBJ + I - 1) * 4 + 1 + NOFF
            N  = - 1
            IF (VOID(NB) .GT. 0.0) THEN
                MBK = (K  - 1) * IP2
                DO 470 J0 = 1, 3
                  MBJ = (J + J0 - 3) * IP1
                  DO 460 I0 = 1, 3
                    MB = (MBK + MBJ + I + I0 - 3) * 4 + 1 + NOFF
                    IF (VOID(MB) .NE. 0.0) THEN
                      N = N + 1
                    ENDIF
  460             CONTINUE
  470           CONTINUE
              VOID(NB) =  N
            ENDIF
  480     CONTINUE
  490   CONTINUE
  500 CONTINUE
      HRSH = HORS / (2.0 * ISTER)
      VRTH = VERT / 2.0
      IF (ISTER .EQ. 1) THEN
        COL1 = 1.0 + IPR(116)
        COL2 = 3.0
      ELSE
        COL1 = 1.0
        COL2 = 1.0
      ENDIF
      IF ((IPR(116) .EQ. 0 .OR. IPR(533) .EQ. 2) .AND.
     1     IPR(346) .EQ. 1) THEN
        IF (IPR(529) .EQ. 1) THEN
          CL1 = 2
          CL2 = 2
        ELSE
          CL1 = 5
          CL2 = 5
        ENDIF
      ELSE
        CL1 = COL1
        CL2 = COL2
      ENDIF
      N0 = 8
      IF (IPR(534) .EQ. 2) THEN
        N1 = 1
        N3 = 3
        N4 = 1
      ELSE
        N1 = 2
        N3 = 2
        N4 = 0
      ENDIF
      CALL GGIP (HRSH, VRTH, 0.0, -3)
      DO 570 K = 1, IMX(IND3) + 1
        NBK = (K - 1) * IP2
        DO 560 J = 1, IMX(IND2) + 1
          NBJ = (J - 1) * IP1
          DO 550 I = 1, IMX(IND1) + 1
            NB = (NBK + NBJ + I - 1) * 4 + NOFF
            N = NINT(VOID(NB + 1))
            IF (N .GT. 0) THEN
              IF (N .LT. N0) THEN
                DO 510 L = 1, 3
                  V2(L) = VOID(NB + 1 + L)
  510           CONTINUE
                CALL GEN002 (1, ROTM1, V2, V4, XLNG)
                DO 540 J0 = N1, N3
                  DO 530 I0 = N1, N3
                    IF (ABS(J0 -2) + ABS(I0 -2) .EQ. N4) THEN
                      MB = NB + ((J0 - 2) * IP1 + I0 - 2) * 4
                      M = NINT (VOID(MB + 1))
                      IF (M .GT. 0 .AND. M .LT. N0) THEN
                        DO 520 L = 1, 3
                          V3(L) = VOID(MB + 1 + L)
  520                   CONTINUE
                        CALL GEN002 (1, ROTM1, V3, V5, XLNG)
                        CALL GGIP (0.0, CL1, 0.0, 0)
                        CALL GGIP (V4(1), V4(2), 0.0, 3)
                        CALL GGIP (V5(1), V5(2), 0.0, 2)
                        IF (IPR(116) .EQ. 1) THEN
                          CALL GEN002 (1, ROTM2, V2, V6, XLNG)
                          CALL GEN002 (1, ROTM2, V3, V8, XLNG)
                          CALL GGIP (0.0, CL2, 0.0, 0)
                          IF (ISTER .EQ. 2) THEN
                            V61 = V6(1) + HRS
                            V81 = V8(1) + HRS
                          ELSE
                            V61 = V6(1)
                            V81 = V8(1)
                          ENDIF
                          CALL GGIP (V61, V6(2), 0.0, 3)
                          CALL GGIP (V81, V8(2), 0.0, 2)
                        ENDIF
                      ENDIF
                    ENDIF
  530             CONTINUE
  540           CONTINUE
              ENDIF
            ENDIF
  550     CONTINUE
  560   CONTINUE
  570 CONTINUE
      IF (NBOND .GT. 0) THEN
        DO 590 I = 1, NBOND
          DO 580 J = 1, 3
            V3(J) = VOID((JNSC(1, I) - 1) * 7 + 1 + J)
            V4(J) = VOID((JNSC(2, I) - 1) * 7 + 1 + J)
  580     CONTINUE
          CALL GEN002 (1, ROTM1, V3, V5, XLNG)
          CALL GEN002 (1, ROTM1, V4, V6, XLNG)
          CALL GGIP (0.0, COL1, 0.0, 0)
          CALL GGIP (V5(1), V5(2), 0.0, 3)
          CALL GGIP (V6(1), V6(2), 0.0, 2)
          IF (IPR(116) .EQ. 1) THEN
            CALL GEN002 (1, ROTM2, V3, V5, XLNG)
            CALL GEN002 (1, ROTM2, V4, V6, XLNG)
            IF (ISTER .EQ. 2) THEN
              V5(1) = V5(1) + HRS
              V6(1) = V6(1) + HRS
            ELSE
              CALL GGIP (0.0, COL2, 0.0, 0)
            ENDIF
            CALL GGIP (V5(1), V5(2), 0.0, 3)
            CALL GGIP (V6(1), V6(2), 0.0, 2)
          ENDIF
  590   CONTINUE
        NLAB = IPR(527) * 8 + IGBL(75) * NAT
        IF (NLAB .GT. 0) THEN
          DO 610 I = 1, NLAB
            NQ1 = ' '
            NL = NINT (VOID((I - 1) * 7 + 1))
            DO 600 J = 1, 3
              V2(J) = VOID((I - 1) * 7 + J + 1)
  600       CONTINUE
            CALL GEN002 (1, ROTM1, V2, V3, XLNG)
            CALL GEN002 (1, ROTM2, V2, V4, XLNG)
            IENR = 0
            IF (NL .LE. 0) THEN
              IF (IPR(532) .NE. 0) THEN
                IF (NL .EQ. 0) THEN
                  NQ1 = 'O'
                ELSE IF (NL .EQ. -4) THEN
                  NQ1 = 'a'
                ELSE IF (NL .EQ. -2) THEN
                  NQ1 = 'b'
                ELSE IF (NL .EQ. -1) THEN
                  NQ1 = 'c'
                ENDIF
              ENDIF
            ELSE
              CALL PLA047 (XLAB(NL), NQ1, MN, IENR, 0, IGBL(55), 0, 0)
            ENDIF
            IF (IENR .NE. 1 .OR. IPR(232) .EQ. 1) THEN
              CALL GGIP20 (0.0, NQ1, 5, PAR(349), NINT(COL1), 2,
     1              V3(1) + 0.4, V3(2) - 0.4)
              IF (IPR(116) .EQ. 1) THEN
                IF (ISTER .EQ. 2) V4(1) = V4(1) + HRS
                CALL GGIP20 (0.0, NQ1, 5, PAR(349), NINT(COL2), 2,
     1              V4(1) + 0.4, V4(2) - 0.4)
              ENDIF
            ENDIF
  610     CONTINUE
        ENDIF
      ENDIF
      GOTO 10
  620 RETURN
  630 STOP 'STOP: VOID Array too small; raise NPVD for larger version'
99999 FORMAT (/, 'NGRID IGMN IGMX  ISH  IMX', /)
99998 FORMAT (5I5, /)
99997 FORMAT (/, ':: Bonds Skipped: NBOND .GE. NP23 =', I6, /)
      END
      SUBROUTINE PLA129
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16,
     1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NPVD=40000000,
     2 NP22=256, NP23=18000,NP25=99,NP29=63,NP34=509,NP38=125,NP39=30,
     3 NP41=200,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 DID*9, TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON // JNSC(2, NP23), VOID(NPVD)
      COMMON /SFCLC/ NATO, NNG(3), NGRID
      COMMON /PL138/ IHKLS(5, 48), PHIS(48), NSYM, NSYMH, MHK, MPH,
     1  ICNTR, IND1, IND2, IND3
      COMMON /FNAME/ KNM(8), KXT, KNM16
      COMMON /NAMES/ NAME(8), EXTENS, PROGNM, FNLU1, FNLU16, RDTYPE
      CHARACTER NAME*80, EXTENS*9, PROGNM*28, FNLU1*80, FNLU16*80,
     1          RDTYPE*7
      COMMON /CIF/ CIFDIR
      CHARACTER CIFDIR(NP34)*36
      DIMENSION STAT(20, 9)
      INTEGER HMAX
      COMMON /PAGENM/ PAGET, PAGEIND(25)
      CHARACTER PAGET*8, PAGEIND*8
      COMMON /CGG11/ BCD, SBCD
      CHARACTER BCD*132, SBCD*132
      COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0
      PAGET = 'SQUEEZE'
      CALL PLA269 (-2)
      WRITE (LU7, 99991)
      IF (IGBL(25) * IGBL(32) .EQ. 1 .AND. IGBL(3) .NE. 5) THEN
        IWIN = 1
        CALL GGIP (HORS, VERT, 0.0, 1)
        VRT = VERT - 0.8
        WRITE (BCD, '(24X, ''PLATON/SQUEEZE '')')
        CALL GGIP20 (0.0, BCD, 80, 0.50, 5 + IGBL(68), 2, 1.0, VRT)
        WRITE (BCD, 99976)
        VRT = VRT - 1.0
        CALL GGIP20 (0.0, BCD, 80, 0.40, 5 + IGBL(68), 2, 0.1, VRT)
        CALL GGIP (0.0, 0.0, 0.0, 6)
        VRT = VRT - 0.2
      ELSE
        IWIN = 0
      ENDIF
      NSYM  = IPR(48)
      NSYMH = IPR(255)
      ICNTR = IPR(257)
      ICENT = ICNTR - 1
      EPS   = 2.0 - ICENT
      IND1  = 1
      IND2  = 2
      IND3  = 3
      CALL PLA130 (NATO, 0)
      IF (NATO .LT. 0) GOTO 260
      IF (IGBL(15) .LT. 0) THEN
        IPR(2) = 43
        GOTO 260
      ENDIF
      IF (IPR(259) .EQ. 5 .OR. IPR(259) .EQ. 6) THEN
        IHEXL = 1
      ELSE
        IHEXL = 0
      ENDIF
      NREF = 0
      HMAX = -999
      KMAX = -999
      LMAX = -999
      CALL GEN108 (LU17, 0)
      IEND = -1
    5 CALL PLA133 (IH, IK, IL, IHT, IKT, ILT, XI, SIGI,
     1  UCINT, ACALS, BCALS, ACOR, IEND)
      IF (IEND .EQ. 0) THEN
        HMAX = MAX (HMAX, IABS(IHT))
        KMAX = MAX (KMAX, IABS(IKT))
        IF (IHEXL .EQ. 1) THEN
          HMAX = MAX (KMAX, HMAX, IABS(IHT + IKT))
          KMAX = HMAX
        ENDIF
        LMAX = MAX (LMAX, IABS(ILT))
        NREF = NREF + 1
        WRITE (LU17, 99972) IHT, IKT, ILT, MAX(0.0, XI), SIGI
        GOTO 5
      ENDIF
      IF (IPR(259) .EQ. 4) THEN
        HMAX = MAX (HMAX, KMAX)
        KMAX = HMAX
      ELSE IF (IPR(259) .EQ. 7) THEN
        HMAX = MAX (HMAX, KMAX, LMAX)
        KMAX = HMAX
        LMAX = HMAX
      ENDIF
      IF (NREF .EQ. 0) THEN
        IPR(2) = 39
        GOTO 260
      ENDIF
      WRITE (LU6, 99999) NREF, HMAX, KMAX, LMAX
      CALL PLA269 (3)
      WRITE (LU7, 99999) NREF, HMAX, KMAX, LMAX
      N1   = IPR(395)
      N2   = IPR(396)
      N3   = IPR(397)
      N23  = N2 * N3
      N123 = N1 * N23
      CALL GEN074 (VOID, 0.0, 1, N123)
      DO 20 I = 1, 3
        DO 10 J = 4, 8
          NNG(I) = 2**J
          IF (PAR(100 + I) * 3.0 .LT. NNG(I)) GOTO 20
   10   CONTINUE
   20 CONTINUE
      IF (NNG(1) .LE. 2 * HMAX) NNG(1) = NNG(1) * 2
      IF (NNG(2) .LE. 2 * KMAX) NNG(2) = NNG(2) * 2
      IF (NNG(3) .LE. 2 * LMAX) NNG(3) = NNG(3) * 2
      M1 = NNG(1)
      M2 = NNG(2)
      M3 = NNG(3)
      IPR(395) = M1
      IPR(396) = M2
      IPR(397) = M3
      NGRID    = M1 * M2 * M3
      PAR(79)  = PAR(98) / NGRID
      WRITE (LU6, 99992) (PAR(100 + I), I= 1, 3), N1, N2, N3,
     1                   M1, M2, M3, PAR(101) / M1, PAR(102) / M2,
     2                   PAR(103) / M3
      CALL PLA269 (5)
      WRITE (LU7, 99992) (PAR(100 + I), I = 1, 3), N1, N2, N3,
     1                   M1, M2, M3, PAR(101) / M1, PAR(102) / M2,
     2                   PAR(103) / M3
      CALL GEN108 (LU15, 0)
   30 READ (LU15, END = 40)  IX, IY, IZ, IV
      VOID(IX * N23 + IY * N3 + IZ + 1) = IV
      GOTO 30
   40 CALL GEN108 (LU15, 0)
      DO 70 I = 1, M1
        IX  = I - 1
        X0  = FLOAT(IX) * N1 / M1
        JX0 = INT(X0)
        X0  = 1.0 - X0 + JX0
        JX1 = MOD(JX0 + 1, N1) * N23 + 1
        JX0 = JX0 * N23 + 1
        DO 60 J = 1, M2
          IY  = J - 1
          Y0  = FLOAT(IY) * N2 / M2
          JY0 = INT(Y0)
          Y0  = 1.0 - Y0 + JY0
          JY1 = MOD(JY0 + 1, N2) * N3
          JY0 = JY0 * N3
          DO 50 K = 1, M3
            IZ  = K - 1
            Z0  = FLOAT(IZ) * N3 / M3
            JZ0 = INT(Z0)
            Z0  = 1.0 - Z0 + JZ0
            JZ1 = MOD(JZ0 + 1, N3)
            VI  = 0.0
            IVV = 0
            IV0 = NINT(VOID(JX0 + JY0 + JZ0))
            IF (IV0 .NE. 0) THEN
              VI  = VI + X0 * Y0 * Z0
              IVV = IV0
            ENDIF
            IV1 = NINT(VOID(JX0 + JY0 + JZ1))
            IF (IV1 .NE. 0) THEN
              VI  = VI + X0 * Y0 * (1.0 - Z0)
              IVV = IV1
            ENDIF
            IV2 = NINT(VOID(JX0 + JY1 + JZ0))
            IF (IV2 .NE. 0) THEN
              VI  = VI + X0 * (1.0 - Y0) * Z0
              IVV = IV2
            ENDIF
            IV3 = NINT(VOID(JX0 + JY1 + JZ1))
            IF (IV3 .NE. 0) THEN
              VI  = VI + X0 * (1.0 - Y0) * (1.0 - Z0)
              IVV = IV3
            ENDIF
            IV4 = NINT(VOID(JX1 + JY0 + JZ0))
            IF (IV4 .NE. 0) THEN
              VI  = VI + (1.0 - X0) * Y0 * Z0
              IVV = IV4
            ENDIF
            IV5 = NINT(VOID(JX1 + JY0 + JZ1))
            IF (IV5 .NE. 0) THEN
              VI  = VI + (1.0 - X0) * Y0 * (1.0 - Z0)
              IVV = IV5
            ENDIF
            IV6 = NINT(VOID(JX1 + JY1 + JZ0))
            IF (IV6 .NE. 0) THEN
              VI  = VI + (1.0 - X0) * (1.0 - Y0) * Z0
              IVV = IV6
            ENDIF
            IV7 = NINT(VOID(JX1 + JY1 + JZ1))
            IF (IV7 .NE. 0) THEN
              VI  = VI + (1.0 - X0) * (1.0 - Y0) * (1.0 - Z0)
              IVV = IV7
            ENDIF
            IF (VI .GT. 0.5) THEN
              LOC = 2 * ((IZ * M2 + IY) * M1 + IX + 1)
              WRITE (LU15) LOC, IVV
            ENDIF
   50     CONTINUE
   60   CONTINUE
   70 CONTINUE
      CALL PLA137 (HMAX, KMAX, LMAX, NREF, IADR, NREFA)
      IF (NREFA .LT. 0) GOTO 260
      NLPMX = IPR(142)
      NLOPM = NLPMX
      FS000 = 0.0
      FSOLD = 0.0
      RFSOD = 999.0
      DO 250 NLOOP = 1, NLPMX
        SUMFO = 0.0
        SUMFC = 0.0
        SMFO  = 0.0
        N13   = 0
        IF (NLOOP .GT. 2) EPS = 1.0
        DO 80 N = 1, NREFA
          IH = NINT(VOID(N13 + 9))
          IK = NINT(VOID(N13 + 10))
          IL = NINT(VOID(N13 + 11))
          ST = SQRT(GEN095 (PAR(191), IH, IK, IL))
          IF (ST .GT. PAR(290)) THEN
            FO    = VOID(N13 + 1)
            ACAL  = VOID(N13 + 3) + VOID(N13 + 12) + EPS * VOID(N13 + 5)
            BCAL  = VOID(N13 + 4) + VOID(N13 + 13) + EPS * VOID(N13 + 6)
            FC    = SQRT(ACAL**2 + BCAL**2)
            SUMFO = SUMFO + FO
            SUMFC = SUMFC + FC
          ENDIF
          N13   = N13 + 13
   80   CONTINUE
        SCF = SUMFC / SUMFO
        WRITE (LU6, 99997) SCF, PAR(290)
        CALL PLA269 (3)
        WRITE (LU7, 99997) SCF, PAR(290)
        SUMFO = SUMFO * SCF
        SUMDL = 0.0
        SMFO  = 0.0
        SMDL  = 0.0
        N13   = 0
        N112  = 0
        NOUTL = 0
        DO 90 N = 1, NREFA
          FO    = VOID(N13 + 1) * SCF
          SIGF  = MAX (VOID(N13 + 2) * SCF, 0.0001)
          ACAL  = VOID(N13 + 3) + VOID(N13 + 12)
          BCAL  = VOID(N13 + 4) + VOID(N13 + 13)
          ACALS = ACAL + EPS * VOID(N13 + 5)
          BCALS = BCAL + EPS * VOID(N13 + 6)
          FCS   = SQRT(ACALS**2 + BCALS**2)
          DELTA = ABS(FO - FCS)
          IF (NLOOP .EQ. 1) THEN
            IH    = NINT(VOID(N13 + 9))
            IK    = NINT(VOID(N13 + 10))
            IL    = NINT(VOID(N13 + 11))
          ENDIF
          IF (NLOOP .GT. 1 .AND. DELTA .GT. PAR(292) * SIGF) THEN
            IH    = NINT(VOID(N13 + 9))
            IK    = NINT(VOID(N13 + 10))
            IL    = NINT(VOID(N13 + 11))
            VOID(N13 + 7) = 0.0
            VOID(N13 + 8) = 0.0
            NOUTL = NOUTL + 1
            IF (NOUTL .EQ. 1) THEN
              WRITE (LU6, 99987) PAR(292)
              CALL PLA269 (1)
              WRITE (LU7, 99987) PAR(292)
            ENDIF
            WRITE (LU6, 99986) IH, IK, IL, FO, FCS, SIGF, DELTA / SIGF
            CALL PLA269 (1)
            WRITE (LU7, 99986) IH, IK, IL, FO, FCS, SIGF, DELTA / SIGF
          ELSE
            SUMDL = SUMDL + DELTA
            IF (FO .GT. 4 * SIGF) THEN
              SMFO = SMFO + FO
              SMDL = SMDL + DELTA
              N112 = N112 + 1
            ENDIF
            VOID(N13 + 7) = FO * ACALS / FCS - ACAL
            VOID(N13 + 8) = FO * BCALS / FCS - BCAL
          ENDIF
          IF (NLOOP .LT. NLOPM) THEN
            VOID(N13 + 5) = 0.0
            VOID(N13 + 6) = 0.0
          ENDIF
          N13 = N13 + 13
   90   CONTINUE
        RF  = SUMDL / SUMFO
        RFS = SMDL  / SMFO
        WRITE (BCD, 99993) NLOOP, RF, NREFA, RFS, N112
        WRITE (LU6, 99970) BCD
        CALL PLA269 (5)
        WRITE (LU7, 99970) BCD
        IF (IWIN .EQ. 1) THEN
          WRITE (BCD, 99977) NLOOP, RF, NREFA, RFS, N112, NINT(FS000)
          VRT = VRT - 0.7
          CALL GGIP20 (0.0, BCD, 80, 0.35, 1, 2, 0.1, VRT)
          CALL GGIP (0.0, 0.0, 0.0, 6)
        ENDIF
        IF (NLOOP .LT. NLOPM) THEN
          CALL GEN108 (LU15, 0)
          DO 110 I = 1, 2
            DO 100 J = 1, NP41
              SXYZ(I, J) = 0.0
  100       CONTINUE
  110     CONTINUE
          NV = 0
          IBOT = NREFA * 13
          ITOP = IBOT + NGRID * 2
          IF (ITOP + 3 * (M1 + 2) * (M2 + 2) .GT. IADR) THEN
            WRITE (LU6, 99996) 2, CHAR(IPR(223))
            WRITE (LU7, 99996) 2, CHAR(IPR(223))
            GOTO 260
          ENDIF
          IF (IPR(304) .EQ. 0) THEN
            CALL PLA136 (VOID(1), VOID(IBOT + 1), VOID(ITOP + 1),
     1           NREFA, FS000)
          ELSE
            CALL PLA136 (VOID(1), VOID(IBOT + 1), VOID(ITOP + 1),
     1           NREFA, 0.000)
          ENDIF
          CALL GEN108 (LU9, 0)
  120     READ (LU15, END = 130) ILOC, NVOID
          LOC    = IBOT + ILOC
          DELRHO = VOID(LOC - 1) / NGRID
          WRITE (LU9) LOC, DELRHO
          SXYZ(1, NVOID) = SXYZ(1, NVOID) + 1
          SXYZ(2, NVOID) = SXYZ(2, NVOID) + DELRHO
          NV = MAX (NV, NVOID)
          GOTO 120
  130     FS000 = 0
          WRITE (PRBUF, 99995)
          WRITE (LU6, 99974) PRBUF(1:80)
          CALL PLA269 (3)
          WRITE (LU7, 99974) PRBUF(1:80)
          DO 140 I = 1, NV
            YUNK  = SXYZ(2, I)
            IF (YUNK .GT. 0.0) FS000 = FS000 + YUNK
            VVOL = SXYZ(1, I) * PAR(79)
            AVOL = VVOL / (YUNK / 8)
            WRITE (PRBUF, 99984) I, (SXYZ(J, I), J = 10, 12),
     1         NINT (VVOL), NINT (YUNK), MAX (0.0, VVOL / YUNK),
     2         MAX (0, NINT(AVOL))
            WRITE (LU6, 99975) PRBUF(1:80)
            CALL PLA269 (1)
            WRITE (LU7, 99975) PRBUF(1:80)
  140     CONTINUE
          PAR(149) = FS000
          WRITE (LU6, 99994) NINT(FS000)
          CALL PLA269 (2)
          WRITE (LU7, 99994) NINT(FS000)
          VA = 0
          DO 150 I = IBOT + 1, ITOP, 2
            VA = VA + VOID(I) / NGRID
            VOID(I)     = 0.0
            VOID(I + 1) = 0.0
  150     CONTINUE
          WRITE (LU6, 99985) NINT(VA)
          CALL PLA269 (2)
          WRITE (LU7, 99985) NINT(VA)
          CALL GEN108 (LU9, 0)
          DRHOMN =  99999.0
          DRHOMX = -99999.0
  160     READ (LU9, END = 170) LOC, DELRHO
          DRHOMN = MIN (DRHOMN, DELRHO)
          DRHOMX = MAX (DRHOMX, DELRHO)
          IF (DELRHO .GT. PAR(285)) VOID(LOC - 1) = DELRHO
          GOTO 160
  170     DRHOMX = DRHOMX * NGRID / PAR(98)
          DRHOMN = DRHOMN * NGRID / PAR(98)
          WRITE (LU6, 99983) DRHOMN, DRHOMX, PAR(285),
     1                       PAR(329), PAR(330), PAR(269)
          CALL PLA269 (3)
          WRITE (LU7, 99983) DRHOMN, DRHOMX, PAR(285),
     1                       PAR(329), PAR(330), PAR(269)
          CALL GEN028 (VOID(IBOT + 1), NNG, 3, 1)
          IF (IPR(304) .NE. 0) THEN
            WRITE (LU6, 99969) VOID(IBOT + 1)
            WRITE (LU7, 99969) VOID(IBOT + 1)
          ENDIF
          N13 = 0
          DO 180 I = 1, NREFA
            IH = NINT(VOID(N13 + 9))
            IK = NINT(VOID(N13 + 10))
            IL = NINT(VOID(N13 + 11))
            IF (IH .LT. 0) IH = IH + M1
            IF (IK .LT. 0) IK = IK + M2
            IF (IL .LT. 0) IL = IL + M3
            LOC           = IBOT + 2 * ((IL * M2 + IK) * M1 + IH + 1)
            VOID(N13 + 5) = VOID(LOC - 1)
            VOID(N13 + 6) = VOID(LOC)
            N13           = N13 + 13
  180     CONTINUE
          IF (ABS(ABS(FS000) - ABS(FSOLD)) .LT. PAR(250) * NSYM
     1        .AND. FS000 .GT. 1.0 .AND. RFSOD - RFS .LT. 0.005) THEN
            NLOPM = NLOOP + 1
          ELSE
            FSOLD = FS000
            RFSOD = RFS
          ENDIF
        ELSE
          OPEN (LU61, FILE = NAME(1)(1:KNM(1))//'.sqf',
     1          STATUS = 'UNKNOWN')
          WRITE (LU61, 99968) (CIFDIR(I), I = 503, 508)
          DO 185 I = 1, NV
            WRITE (LU61, 99967) I, SXYZ(10, I), SXYZ(11, I),
     1        SXYZ(12, I), SXYZ(1,  I) * PAR(79), SXYZ(2,  I)
  185     CONTINUE
          WRITE (LU61, 99966) CIFDIR(509)
          CLOSE (LU61)
          CALL GEN108 (LU17, 0)
          DO 200 I = 1, 20
            DO 190 J = 1, 9
              STAT(I, J) = 0.0
  190       CONTINUE
  200     CONTINUE
          I8MAX = 0
          SCLI8 = 1.0
          DO 220 K = 1, 2
            IF (K .EQ. 2) THEN
              IF (I8MAX .GT. 99999000) THEN
                SCLI8 = FLOAT(99999000) / FLOAT (I8MAX)
              ENDIF
            ENDIF
            NPRT = 0
            IEND = -1
  210       CALL PLA133 (IH, IK, IL, IHT, IKT, ILT, XI, SIGI,
     1        DUM1, DUM2, DUM3, DUM4, IEND)
            IF (IEND .EQ. 1) GOTO 220
            ISIGI = NINT(SCLI8 * SIGI)
            IHKL  = ILT * MHK + IKT * MPH + IHT
            IF (IHKL .GT. 0) THEN
              ISGN = 1
            ELSE
              ISGN = -1
              IHKL = - IHKL
            ENDIF
            N = NINT(VOID(IADR + IHKL)) - 1
            IF (N .GE. 0) THEN
              FO    = SQRT(MAX(0.0, XI)) * SCF
              ACALM =  VOID(N * 13 + 3) + VOID(N * 13 + 12)
              BCALM = (VOID(N * 13 + 4) + VOID(N * 13 + 13)) * ISGN
              ACALS =  VOID(N * 13 + 5)
              BCALS =  VOID(N * 13 + 6) * ISGN
              ACALT = ACALS + ACALM
              BCALT = BCALS + BCALM
              FCALT = SQRT(ACALT**2 + BCALT**2)
              FOA   = (FO * ACALT / FCALT - ACALS) / SCF
              FOB   = (FO * BCALT / FCALT - BCALS) / SCF
              IXI   = NINT (SCLI8 * (FOA**2 + FOB**2))
              NXI   = NINT (SCLI8 * XI)
              IF (K .EQ. 1) THEN
                I8MAX = MAX (I8MAX, IXI)
                I8MAX = MAX (I8MAX, ISIGI)
                I8MAX = MAX (I8MAX, NXI)
              ELSE
                IF (IGBL(37) .NE. 0) THEN
                  WRITE (LU17, 99979) IH, IK, IL, IXI, ISIGI,
     1              (V2(I), V3(I), I = 1, 3), NXI, ACALS, BCALS, 1.0
                ELSE
                  WRITE (LU17, 99978) IH, IK, IL, IXI, ISIGI,
     1                              NXI, ACALS, BCALS, 1.0
                ENDIF
                ST   = SQRT(GEN095(PAR(191), IH, IK, IL))
                FCS  = SQRT(ACALS**2 + BCALS**2)
                FCM  = SQRT(ACALM**2 + BCALM**2)
                PFCS = ATAN2(BCALS, ACALS) * GL(5)
                PFCM = ATAN2(BCALM, ACALM) * GL(5)
                PFCT = ATAN2(BCALT, ACALT) * GL(5)
                DEL1  = MOD(PFCM + 360.0 - PFCS, 360.0)
                IF (DEL1 .GT. 180.0) DEL1 = 360.0 - DEL1
                DEL2  = MOD(PFCM + 360.0 - PFCT, 360.0)
                IF (DEL2 .GT. 180.0) DEL2 = 360.0 - DEL2
                IF (SIGI .GT. 0.0) THEN
                  DELS = ABS(FO**2 - FCALT**2) / (SCF**2 * SIGI)
                  IF (ST .LE. PAR(286) .AND. DELS .GT. PAR(288)) THEN
                    NPRT = NPRT + 1
                    IF (NPRT .EQ. 1) THEN
                      CALL PLA269 (-2)
                      WRITE (LU7, 99998)
                    ENDIF
                    CALL PLA269 (1)
                    WRITE (LU7, 99973) IH, IK, IL, ST, FO, FCM, FCS,
     1                FCALT, DELS, XI * SCF**2, SIGI * SCF**2
                  ENDIF
                ENDIF
                N = MAX (1, MIN (20, INT(ST * 20 + 0.5)))
                STAT(N, 1) = STAT(N, 1) + FCM
                STAT(N, 2) = STAT(N, 2) + FCS
                STAT(N, 3) = STAT(N, 3) + FCALT
                STAT(N, 4) = STAT(N, 4) + FO
                STAT(N, 5) = STAT(N, 5) + DEL1
                STAT(N, 6) = STAT(N, 6) + DEL2
                STAT(N, 7) = STAT(N, 7) + 1.0
                STAT(N, 8) = STAT(N, 8) + ABS(FCM - FO)
                STAT(N, 9) = STAT(N, 9) + ABS(FCALT - FO)
              ENDIF
            ENDIF
            GOTO 210
  220     CONTINUE
          WRITE (LU17, 99971)
          CALL PLA269 (0)
          WRITE (LU7, 99989)
          DO 240 I = 1, 20
            IF (STAT(I, 7) .GT. 0.0) THEN
              IF (STAT(I, 4) .NE. 0.0) THEN
                STAT(I, 8) = STAT(I, 8) / STAT(I, 4)
                STAT(I, 9) = STAT(I, 9) / STAT(I, 4)
              ELSE
                STAT(I, 8) = 0.0
                STAT(I, 9) = 0.0
              ENDIF
              DO 230 J = 1, 6
                STAT(I, J) = STAT(I, J) / STAT(I, 7)
  230         CONTINUE
              ST = I / 20.0
              WRITE (LU7, 99988) ST, (STAT(I, K), K = 1, 9)
            ENDIF
  240     CONTINUE
          WRITE (LU7, 99982)
          IF (MAX(-PAR(329), PAR(330)) .GT. 1.0)
     1      WRITE (LU7, 99981) PAR(329), PAR(330)
          IF (IPR(489) + IPR(490) .GT. 0)
     1      WRITE (LU7, 99980) IPR(489) + IPR(490)
          WRITE (LU6, 99990)
          WRITE (LU7, 99990)
          GOTO 260
        ENDIF
  250 CONTINUE
  260 IF (IWIN .EQ. 1) CALL PLA297 (0)
      RETURN
99999 FORMAT (/, ':: # Accepted Reflns     Hmax Kmax Lmax', /,
     1           '::', 12X, I6, 3X, 3I5)
99998 FORMAT ('  H  K  L  Sinth/l F(obs)  F(mod) F(solv)  ',
     1        'F(tot) D(F^2)/S       I       Sig(I)', /)
99997 FORMAT (/, ':: Fo-scale =', E12.6, ' - SinT/L-Min =', F5.2,
     1        ' for Fo/Fc-Scaling', /)
99996 FORMAT (/, 'F: Scratch Array Overrun Code', I2, ' (Fatal)', /,
     1        '    Use larger program version i.e. larger NPVD', A, /)
99995 FORMAT ('Void  X(av) Y(av) Z(av) Volume Ang^3 El-Count (e-)',
     1        ' Vol/Electron Vol/Atom')
99994 FORMAT (/, 'Total (Positive) Electron Count in Voids/Cell =', I6)
99993 FORMAT (':: Cycle =', I3, ', R(F) =', F5.2, ', Nref(Hemi) =',
     1        I6, ', R(F > 4SIGF) =', F5.2, ' Nref =', I6)
99992 FORMAT (/, ':: A,  B,  C  (Angstrom) = ', 3F10.3, /,
     1           ':: NX, NY, NZ (SOLV-MAP) = ', 3I10, /,
     2           ':: NX, NY, NZ (FFT-MAP)  = ', 3I10, /,
     3           ':: Resolution (FFT-MAP)  = ', 3F10.2, ' Angstrom')
99991 FORMAT ('SQUEEZE - Procedure (cf. BYPASS-procedure - ',
     1 'P. van der Sluis & A.L. Spek (1990). Acta Cryst. A46, ',
     2 '194-201)', /, 120('='))
99990 FORMAT (/, 'Note on how to Proceed after SQUEEZE:', /, 80('='), /
     1 '- The file .hkp now contains solvent free reflection data.', /,
     2 '- Rename this file .hkp to .hkl', /,
     3 '- Use this new .hkl file to continue SHELXL refinement with ',
     4 'a solvent-free .ins.', /,
     4 '- After L.S.-convergence, run PLATON with the new .hkl and',
     5 ' .res files', /, '  with the instruction ''CALC FCF'' to ',
     6 'produce a final FoFc-CIF on .hkp', /,
     7 '- Rename this .hkp file to .fcf.', /,
     8 '- Append the .sqf file produced by PLATON',
     9 ' (detailing the SQUEEZE results)', /,
     * '  to the .cif produced by SHELXL', /, 80('='))
99989 FORMAT ('SQUEEZE Statistics on the Difference Map Phasing', /,
     1        80('='), //,
     2  'FcMod  = Average contribution to Fc from discrete model', /,
     3  'FcSolv = Average contribution to Fc from solvent region', /,
     4  'FcTot  = Average Fc total ( = model + solvent contrib.)', /,
     5  'DelMS  = Average Phase difference between model and',
     6  ' solvent contrib.', /,
     7  'DelMT  = Average Phase difference between model  and',
     8  ' combined contrib.', /,
     9  'N      = Number of reflections in Sin(Theta)/Lambda range',/,
     *  'R(Mod) = SIGMA(ABS(ABS(FcMod) - Fo)) / SIGMA(Fo)', /,
     1  'R(Tot) = SIGMA(ABS(ABS(FcTot) - Fo)) / SIGMA(Fo)', /,
     2  /, 'SinT/L <FcMod> <FcSolv>  <FcTot>    <Fo> ',
     3        ' <DelMS> <DelMT>    N  R(Mod) R(Tot)', /, 80('='))
99988 FORMAT (F4.2, 4F9.2, 2F8.2, F7.0, 2F7.3)
99987 FORMAT (':: Omitted Outliers H K L Fo Fc Sig Del/Sig',
     1 ' - [Abs(Fo-Abs(Fc))>', F5.0, 'Sig]', /)
99986 FORMAT (3I5, 4F12.2)
99985 FORMAT (/, 'Total (Fo-Fc)map Electron Count in  Unit Cell =', I6)
99984 FORMAT (I4, 1X, 3F6.3, 3X, I10, I9, 8X, F10.1, 4X, I5)
99983 FORMAT (/, 'VOID-Fo-Fc-Map:    Rho(min) =', F10.2,
     1        ', Rho(max) =', F10.2, ', RhoCutOff =', F6.2, /,
     2        'PeaksCloseToAtoms: Rho(min) =', F10.2, ', Rho(max) =',
     3        F10.2, ', RhoCutOff =', F6.2)
99982 FORMAT (/, 'Comments on and Analysis of the SQUEEZE run',
     1        /, 80('='))
99981 FORMAT (/, '- Significant Residual Density Excursion(s) in  the',
     1        /, '  Ordered part of the Structure:', 2F6.1)
99980 FORMAT (/, '- Model includes', I4, ' Isotropic Non-H-Atoms', /,
     1           '  Rerun SQUEEZE with Anisotropically Refined Model')
99979 FORMAT (3I4, 2I8, 4X, 6F8.5, I8, 2F8.2, F8.4)
99978 FORMAT (3I4, 2I8, 52X, I8, 2F8.2, F8.4)
99977 FORMAT (I3, F9.3, 3X, I10, F12.3, I11, I10)
99976 FORMAT ('Cycle  R(F) Nref(Hemi)  R(F .gt. 4Sig Nref  El/Cell')
99975 FORMAT (A)
99974 FORMAT (A, /, 80('='))
99973 FORMAT (3I3, 6F8.2, F12.2, F10.2)
99972 FORMAT (3I4, 2F15.2)
99971 FORMAT (1X)
99970 FORMAT (/, A, /)
99969 FORMAT ('FFT-F000 = ', F10.2)
99968 FORMAT ('# SQUEEZE RESULTS (APPEND TO CIF)', /,
     1        'loop_', 6(/, 2X, A))
99967 FORMAT (I10, 3(F10.3), F10.1, F10.1)
99966 FORMAT (A, /, ';', /, ';')
      END
      SUBROUTINE PLA130 (NATO, MBRAV)
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118,
     1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP22=256,
     2 NP25=99,NP29=63,NP38=125,NP39=30,NP41=200,NP45=2048,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /Q/ ICL, IFL(NP17)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9),
     1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10),
     2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10),
     3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770)
      DIMENSION RIK(3, 3), UKL(3, 3)
      NAT   = IPR(37)
      NSYMR = IPR(255)
      NSYMI = IPR(257)
      IF (MBRAV .NE. 0) THEN
        IBV = IPR(256)
      ELSE
        IBV = 1
      ENDIF
      NSYML = NSYMR * NSYMI * IBV
      IF (NAT * NSYML .GT. NP1) THEN
        WRITE (LU6, 99997) NP1
        NATO = -1
        GOTO 200
      ENDIF
      CALL GEN021 (UKL, 0)
C * GET ATOM PARAMETERS FROM (SAVE)FILE
      NUEQ = 0
      NPDS = 0
      CALL GEN108 (LU4, 0)
   10 READ (LU4, END = 90) ICT, XNQNR, (FN(K), K = 1, 8)
      DO 20 I = 1, NAT
        IF (NINT(XLAB(I)) .EQ. NINT(XNQNR)) THEN
          K = I
          IF (ICT .EQ. 1) THEN
            CALL GEN048 (-1, IFG(K), 30, IVAL)
            IF (IVAL .EQ. 1) THEN
              FN(4) = 0.0
              CALL PLA047 (XNQNR, NQ1, MN, IENR, 1, IGBL(55), 0, 0)
              WRITE (LU6, 99996) NQ1
              WRITE (LU7, 99996) NQ1
            ENDIF
            DO 40 J = 1, 4
              XXO(K, J) = FN(J)
   40       CONTINUE
            CALL GEN048 (-4, IFG(K), 15, NO1)
            M = IEN (NO1 + 1)
            IF (IPR(493) .NE. 5) THEN
              M = (M - 1) * 15
              DO 50 J = 1, 9
                CON(K, J) = SFAC(M + J)
   50         CONTINUE
            ELSE
              CON(K, 9) = RNSCL(M)
            ENDIF
            IF (IPR(493) .EQ. 1) THEN
              M = M + 14
            ELSE IF (IPR(493) .EQ. 2) THEN
              M = M + 12
            ELSE IF (IPR(493) .EQ. 3) THEN
              M = M + 10
            ELSE
              M = 0
            ENDIF
            IATP(K) = M
          ELSE IF (ICT .EQ. 2) THEN
            IF (IPR(210) .EQ. - 2) THEN
              DO 60 J = 1, 6
                DUMA(J) = FN(J)
   60         CONTINUE
              CALL GEN025 (UIJ, DUMA, -1)
              CALL PLA210 (PAR, OR, UIJ, UKL, DUMA, DUMV, XSD(K, 1))
              IF (XSD(K, 1) .LT. 0.00) THEN
                XSD(K, 1) = 0.03
                NPDS = NPDS + 1
              ENDIF
              CALL GEN048 (1, IFG(K), 4, 0)
              NUEQ = NUEQ + 1
            ELSE
              DO 70 J = 1, 6
                XSD(K, J) = FN(J)
   70         CONTINUE
            ENDIF
          ELSE IF (ICT .EQ. 4) THEN
            XSD(K, 1) = FN(1)
          ELSE IF (ICT .EQ. 6) THEN
            GOTO 90
          ENDIF
          GOTO 10
        ENDIF
   20 CONTINUE
      GOTO 10
   90 IF (IPR(210) .EQ. -3) THEN
        DO 95 K = 1, NAT
          XSD(K, 1) = PAR(247)
          CALL GEN048 (1, IFG(K), 4, 0)
   95   CONTINUE
      ENDIF
      K = NAT
      IF (NSYML .GT. 1) THEN
        DO 160 L = 2, NSYML
          DO 170 I = 1, NAT
            CALL GEN048 (-1, IFG(I), 4, IVAL)
            DO 100 M = 1, 3
              XJX(M) = XXO(I, M)
              XJX(M + 3) = 0.0
  100       CONTINUE
            CALL SGSM (ICL, L, XJX, LU7, 3, IERR)
            K = K + 1
            DO 110 M = 1, 3
              XXO(K, M) = XJX(M + 6)
  110       CONTINUE
            XLAB(K)   = XLAB(I)
            XXO(K, 4) = XXO(I, 4)
            IFG(K)    = IFG(I)
            JFG(K)    = JFG(I)
            DO 120 M = 1, 9
              CON(K, M) = CON(I, M)
  120       CONTINUE
            IATP(K) = IATP(I)
            IF (IVAL .EQ. 1) THEN
              CALL SGSM (ICL, L, XJX, LU7, 6, IERR)
              DO 130 M = 1, 9
                J0 = MOD (M - 1, 3) + 1
                K0 = ((M - 1) / 3)  + 1
                RIK(J0, K0) = XJX(M)
  130         CONTINUE
              CALL GEN005 (RIK, RIK)
              DO 140 J = 1, 6
                DUMA(J) = XSD(I, J)
  140         CONTINUE
              CALL GEN025 (UKL, DUMA, -1)
              CALL GEN001 (1, RIK, UKL, UIJ)
              CALL GEN025 (UIJ, DUMA, 1)
              DO 150 J = 1, 6
                XSD(K, J) = DUMA(J)
  150         CONTINUE
            ELSE
              XSD(K, 1) = XSD(I, 1)
            ENDIF
  170     CONTINUE
  160   CONTINUE
      ENDIF
      NATO = K
      IF (NUEQ .GT. 0) WRITE (LU6, 99999) NUEQ
      IF (NPDS .GT. 0) WRITE (LU6, 99998) NPDS
  200 RETURN
99999 FORMAT (':: # Anisotropic atoms converted to isotropic =', I4)
99998 FORMAT (':: # of NPDs reset to U = 0.03 =', I4)
99997 FORMAT ('F: # of Atoms in Expanded set exceeds NP1 =', I5)
99996 FORMAT (':: ', A, ' OMITted From SF-Calculations')
      END
      SUBROUTINE PLA131 (IH, IK, IL, ACAL, BCAL, ACALA, BCALA, SNTHA)
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118,
     1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP25=99,
     2 NP29=63,NP38=125,NP39=30,NP41=200,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9),
     1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10),
     2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10),
     3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770)
      COMMON /SFCLC/ NATO, NNG(3), NGRID
      APIK  = GL(8)
      IBV   = IPR(256)
      ACALA = 0.0
      BCALA = 0.0
      STLK  = GEN095 (PAR(191), IH, IK, IL)
      SNTHA = SQRT(STLK) * PAR(17)
      IF (IPR(414) .LT. 4) THEN
        DO 20 I = 1, NATO
          ARG = GL(6) * (IH * XXO(I, 1) + IK * XXO(I, 2)
     1                 + IL * XXO(I, 3))
          CARG = COS(ARG)
          SARG = SIN(ARG)
          CALL GEN048 (-1, IFG(I), 4, IVAL)
          IF (IVAL .EQ. 0) THEN
            TF =  EXP(- APIK * STLK * XSD(I, 1))
          ELSE
            TF = XSD(I, 1) * IH**2 * PAR(191)
     1         + XSD(I, 2) * IK**2 * PAR(192)
     2         + XSD(I, 3) * IL**2 * PAR(193)
     3         + 2.0 * XSD(I, 4) * IK * IL * PAR(114) * PAR(115)
     4         + 2.0 * XSD(I, 5) * IH * IL * PAR(113) * PAR(115)
     5         + 2.0 * XSD(I, 6) * IH * IK * PAR(113) * PAR(114)
            TF =  EXP(- GL(7) * TF)
          ENDIF
          FACT = XXO(I, 4) * IBV * TF
          FSC = CON(I, 9)
          IF (IPR(493) .NE. 5) THEN
            DO 10 J = 1, 7, 2
              FSC = FSC + CON(I, J) * EXP(- CON(I, J + 1) * STLK)
   10       CONTINUE
          ENDIF
          FACTR = FACT * FSC
          ACAL  = ACAL + FACTR * CARG
          BCAL  = BCAL + FACTR * SARG
          IATPI = IATP(I)
          IF (IATPI .NE. 0) THEN
            FACTD = FACT  * SFAC(IATPI)
            FACTC = FACT  * SFAC(IATPI + 1)
            ACALA = ACALA + FACTD * CARG - FACTC * SARG
            BCALA = BCALA + FACTD * SARG + FACTC * CARG
          ENDIF
   20   CONTINUE
      ENDIF
      RETURN
      END
      SUBROUTINE PLA132 (IH, IK, IL, XI, SIGI, CALI, UCINT,
     1 ACALS, BCALS, ACOR, IEND)
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16,
     1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP22=256,NP25=99,
     2 NP29=63,NP38=125,NP39=30,NP41=200,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /PL130/ TRMX(3, 3), STHKM, ISKIP, ITSKP, IOBS, ICALC,
     1 NDEC, SHXMP
      DIMENSION XINT(2)
      CHARACTER EXTEN*4, FOFC*4
      COMMON /FNAME/ KNM(8), KXT, KNM16
      COMMON /NAMES/ NAME(8), EXTENS, PROGNM, FNLU1, FNLU16, RDTYPE
      CHARACTER NAME*80, EXTENS*9, PROGNM*28, FNLU1*80, FNLU16*80,
     1          RDTYPE*7
      COMMON /HKL/ IH0, IK0, IL0, HMAX, KMAX, LMAX
      COMMON /MOLEN/ FMOL
      CHARACTER FMOL*19
      CHARACTER XDATA*10
      INTEGER HMAX
      CALI  = 0.0
      UCINT = 0.0
      ACALS = 0.0
      BCALS = 0.0
      ACOR  = 1.0
      IF (IEND .EQ. -1) THEN
        ISKIP    = 0
        ITSKP    = 0
        PAR(166) = 0.0
        SHXMP    = 1.0
        IF (IPR(408) .EQ. 2 .AND. PAR(168) .GT. 0) PAR(165) = PAR(168)
        STHKM = (SIN(PAR(165) / GL(5)) / PAR(17))**2
        IF (IABS(IGBL(8)) .NE. 2) THEN
          DO 20 I = 1, 3
            DO 10 J = 1, 3
              TRMX(I, J) = TM1(I, J)
   10       CONTINUE
   20     CONTINUE
        ELSE
          IF (IGBL(29) .LE. 0) THEN
            K = 230
            DO 40 I = 1, 3
              DO 30 J = 1, 3
                K = K + 1
                TRMX(I, J) = PAR(K)
   30         CONTINUE
   40       CONTINUE
          ELSE
            CALL GEN021 (TRMX, 1)
          ENDIF
        ENDIF
        CALL GEN074 (V2, 0.0, 1, 3)
        CALL GEN074 (V3, 0.0, 1, 3)
        NDEC = 0
        IF (IPR(408) .LE. 0) THEN
          IF (IGBL(15) .EQ. 0) THEN
            EXTEN = '.hkl'
          ELSE IF (IGBL(15) .EQ. 1) THEN
            EXTEN = '.fcf'
          ENDIF
          FOFC = 'FoFc'
          IF (IPR(132) .EQ. 0) THEN
            FOFC = ' OBS'
          ELSE IF (IPR(132) .EQ. 1) THEN
            FOFC = 'CALC'
          ELSE IF (IPR(132) .EQ. 2) THEN
            FOFC = 'DELT'
          ELSE IF (IPR(132) .EQ. 3) THEN
            FOFC = 'DELG'
          ENDIF
          WRITE (LU6, 99998) FNLU16(1:KNM16), FOFC,
     1           ((TRMX(I, J), J = 1, 3), I = 1, 3)
          IF (IGBL(63) .GT. 0) THEN
            CALL PLA269 (4)
            WRITE (LU7, 99998) FNLU16(1:KNM16), FOFC,
     1             ((TRMX(I, J), J = 1, 3), I = 1, 3)
          ENDIF
          CALL GEN108 (LU16, 0)
          IF (IGBL(29) .GT. 0) THEN
            IF (JID(1:1) .EQ. ' ') THEN
              XDATA = JID(2:11)
            ELSE
              XDATA = JID(1:10)
            ENDIF
            I = INDEX (XDATA, ' ')
            IF (I .GT. 1) XDATA(I:10) = ' '
   50       READ (LU16, 99997, END = 60) IDM
            I = INDEX (IDM, 'data_')
            J = INDEX (IDM, CHAR(13))
            IF (I .EQ. 0) GOTO 50
            IF (J .EQ. 0) THEN
              J = I + 14
            ELSE
              J = J - 1
            ENDIF
            IF (I .GT. J) GOTO 60
            IF (IDM(I + 5:J) .EQ. XDATA) GOTO 70
            GOTO 50
   60       WRITE (LU6,  99990) JID(1:10)
            WRITE (LU22, 99990) JID(1:10)
            WRITE (LU20, 99997) '_900         1         1'
            CALL PLA015 (0, 51)
            GOTO 240
          ENDIF
   70     IF (IGBL(29) .EQ. 1) THEN
            NDEC  = 2
            ICALC = 0
            IOBS  = 0
            IDIF  = 0
   80       READ (LU16, 99997, END = 240, ERR = 240) IDM
            IF (PAR(101) .GT. 0.0) THEN
              N = INDEX (IDM, 'cell_')
              IF (N .NE. 0) THEN
                M = INDEX (IDM, '(')
                IF (M .NE. 0) IDM(M:) = '        '
                NB = INDEX (IDM, '_cell_length_a')
                IF (NB .NE. 0) THEN
                  READ (IDM(NB + 14:), *) PAR(455)
                  DLDS = MAX (0.01, PAR(107) * 2.0)
                  IF (ABS(PAR(455) - PAR(101)) .GT. DLDS)
     1              IDIF = IDIF + 1
                ELSE
                  NB = INDEX (IDM, '_cell_length_b')
                  IF (NB .NE. 0) THEN
                    READ (IDM(NB + 14:), *) PAR(456)
                    DLDS = MAX (0.01, PAR(108) * 2.0)
                    IF (ABS(PAR(456) - PAR(102)) .GT. DLDS)
     1                IDIF = IDIF + 1
                  ELSE
                    NB = INDEX (IDM, '_cell_length_c')
                    IF (NB .NE. 0) THEN
                      READ (IDM(NB + 14:), *) PAR(457)
                      DLDS = MAX (0.01, PAR(109) * 2.0)
                      IF (ABS(PAR(457) - PAR(103)) .GT. DLDS)
     1                  IDIF = IDIF + 1
                    ELSE
                      NB = INDEX (IDM, '_cell_angle_alpha')
                      IF (NB .NE. 0) THEN
                        READ (IDM(NB + 17:), *) PAR(458)
                        DLDS = MAX (0.01, PAR(110) * 2.0)
                        IF (ABS(PAR(458) - PAR(104)) .GT. DLDS)
     1                    IDIF = IDIF + 1
                      ELSE
                        NB = INDEX (IDM, '_cell_angle_beta')
                        IF (NB .NE. 0) THEN
                          READ (IDM(NB + 16:), *) PAR(459)
                          DLDS = MAX (0.01, PAR(111) * 2.0)
                          IF (ABS(PAR(459) - PAR(105)) .GT. DLDS)
     1                      IDIF = IDIF + 1
                        ELSE
                          NB = INDEX (IDM, '_cell_angle_gamma')
                          IF (NB .NE. 0) THEN
                            READ (IDM(NB + 17:), *) PAR(460)
                            DLDS = MAX (0.01, PAR(112) * 2.0)
                            IF (ABS(PAR(460) - PAR(106)) .GT. DLDS)
     1                        IDIF = IDIF + 1
                            IF (IDIF .GT. 0) GOTO 260
                          ENDIF
                        ENDIF
                      ENDIF
                    ENDIF
                  ENDIF
                ENDIF
                GOTO 80
              ENDIF
            ENDIF
            IF (INDEX (IDM, '_refln_F_squared_calc') .NE. 0)  THEN
              IF (IOBS .EQ. 1) THEN
                ICALC = 2
              ELSE
                ICALC = 1
              ENDIF
            ENDIF
            IF (INDEX (IDM, '_refln_F_squared_meas') .NE. 0) THEN
              IF (ICALC .EQ. 1) THEN
                IOBS = 2
              ELSE
                IOBS = 1
              ENDIF
            ENDIF
            IF (INDEX (IDM, '_shelx_F_squared_multiplier') .NE. 0) THEN
              READ (IDM(28:), '(F10.0)') SHXMP
            ENDIF
            IF (INDEX (IDM, '_refln_observed_status') .NE. 0) THEN
   85         READ (LU16, 99997, END = 240) IDM
              IF (INDEX (IDM, '_refln_sint/lambda') .NE. 0) GOTO 85
              BACKSPACE LU16
            ELSE
              GOTO 80
            ENDIF
            IF (IPR(132) .EQ. 0 .AND. IOBS .EQ. 0 .OR.
     1          IPR(132) .EQ. 1 .AND. ICALC .EQ. 0) GOTO 240
          ELSE IF (IGBL(29) .EQ. 2) THEN
   90       READ (LU16, 99997, END = 240) IDM
            IF (INDEX (IDM, '_refln_scale_group_code') .EQ. 0) GOTO 90
            NDEC = 3
          ELSE IF (IGBL(29) .EQ. 3) THEN
  100       READ (LU16, 99997, END = 240) IDM
            IF (INDEX (IDM, '_refln_F_squared_sigma') .EQ. 0) GOTO 100
            IOBS  = 1
            ICALC = 2
            NDEC  = 3
          ELSE IF (IGBL(29) .EQ. 4) THEN
  110       READ (LU16, 99997, END = 240) IDM
            IF (INDEX (IDM, '_refln_10*F_sigm') .EQ. 0 .AND.
     1          INDEX (IDM, '_refln_F_10*sigm') .EQ. 0) GOTO 110
            IOBS  = 1
            ICALC = 2
            NDEC  = 0
            FMOL  = '(I4,2I3,2F7.0,F6.0)'
  120       READ (LU16, 99997, END = 240) IDM
            NB = 1
            NE = 80
            CALL GEN039 (1, IDM, 1, 80, NB, NE)
            IF (NE .EQ. 0) THEN
              GOTO 120
            ELSE IF (NE .EQ. 31) THEN
              FMOL(3:3) = '5'
            ENDIF
            BACKSPACE LU16
          ELSE IF (IGBL(29) .EQ. 5 .OR. IGBL(29) .EQ. 8) THEN
  130       READ (LU16, 99997, END = 240) IDM
            IF (INDEX (IDM, '_refln_') .EQ. 0) GOTO 130
  135       READ (LU16, 99997, END = 240) IDM
            IF (INDEX (IDM, '_refln_') .NE. 0) GOTO 135
            IOBS  = 1
            ICALC = 2
            BACKSPACE LU16
          ELSE IF (IGBL(29) .EQ. 6 .OR. IGBL(29) .EQ. 10) THEN
  140       READ (LU16, 99997, END = 240) IDM
            IF (INDEX (IDM, '_refln_observed_status') .EQ. 0) GOTO 140
          ELSE IF (IGBL(29) .EQ. 7) THEN
  150       READ (LU16, 99997, END = 240) IDM
            IF (INDEX (IDM, '_refln_observed_status') .EQ. 0) GOTO 150
            IOBS  = 1
            ICALC = 2
            FMOL  = '(3I4,3F8.0)'
            BACKSPACE LU16
          ELSE IF (IGBL(29) .EQ. 9) THEN
  155       READ (LU16, 99997, END = 240) IDM
            IF (INDEX (IDM, '_refln_observed_status') .EQ. 0) GOTO 155
          ELSE IF (IGBL(29) .EQ. 21) THEN
  160       READ (LU16, 99997, END = 240) IDM
            IF (INDEX (IDM, '_refln_B_calc') .EQ. 0) GOTO 160
          ELSE IF (IGBL(29) .EQ. 22) THEN
  170       READ (LU16, 99997, END = 240) IDM
            IF (INDEX (IDM, '_refln_phase_calc') .EQ. 0) GOTO 170
          ELSE
            READ (LU16, 99997, END = 240) PRBUF(1:20)
            CALL GEN108 (LU16, 0)
            NDEC = INDEX (PRBUF(13:20), '.')
            IF (NDEC .GT. 0) NDEC = 8 - NDEC
            IF (IGBL(29) .EQ. -1) THEN
              IF (IPR(210) .EQ. -1) WRITE (LU6, 99999)
            ENDIF
          ENDIF
          PAR(230) = 10**NDEC
        ELSE
          HMAX = INT(2 * PAR(101) * PAR(287)) + 1
          KMAX = INT(2 * PAR(102) * PAR(287)) + 1
          LMAX = INT(2 * PAR(103) * PAR(287)) + 1
          IF (IPR(408) .EQ. 2) THEN
            IL0 = - LMAX - 1
          ELSE
            IL0 = -1
          ENDIF
          XI       = 100
          SIGI     = 10
          PAR(230) = 1
          GOTO 180
        ENDIF
      ENDIF
      GOTO 200
  180 IL0 = IL0 + 1
      IF (IL0 .GT. LMAX) GOTO 240
      IK0 = - KMAX - 1
  190 IK0 = IK0 + 1
      IF (IK0 .GT. KMAX) GOTO 180
      IH0 = - HMAX - 1
  200 IF (IPR(408) .LE. 0) THEN
        GOTO 220
  210   IF (INDEX(PRBUF, '<?') .NE. 0) GOTO 240
  220   READ (LU16, 99997, END = 240) PRBUF
        NCR = INDEX (PRBUF, CHAR(13))
        IF (NCR .NE. 0) PRBUF(NCR:NCR) = ' '
        IF (IGBL(29) .EQ. 0) THEN
          IF (IGBL(37) .EQ. 0) THEN
            READ (PRBUF, 99987, ERR = 210)
     1      IH, IK, IL, XI, SIGI, NBAT
          ELSE
            READ (PRBUF, 99987, ERR = 210)
     1      IH, IK, IL, XI, SIGI, NBAT, (V2(I), V3(I), I = 1, 3)
          ENDIF
          IF (NBAT .GT. 1) THEN
            IF (IPR(513) .GE. NBAT - 1 .AND. IPR(513) .GT. 0) THEN
              XI   = BASF(NBAT - 1) * XI
              SIGI = BASF(NBAT - 1) * SIGI
            ENDIF
          ENDIF
          CALI = XI
        ELSE IF (IGBL(29) .LT. 0) THEN
          READ (PRBUF, 99996, END = 220) IH, IK, IL, XI, SIGI,
     1      (V2(I), V3(I), I = 1, 3), UCINT, ACALS, BCALS, ACOR
        ELSE IF (IGBL(29) .EQ. 2) THEN
          READ (PRBUF, 99995, END = 220) IH, IK, IL, XFOBS, XFCAL,
     1                                   XSIGI
            XI   = XFOBS**2
            SIGI = 2.0 * SQRT(XI) * XSIGI
        ELSE IF (IGBL(29) .EQ. 3) THEN
          READ (PRBUF, 99994, ERR = 220) IH, IK, IL,
     1          (XINT(I), I = 1, 2), SIGI
          XI = XINT(IOBS)  * SHXMP
          YI = XINT(ICALC) * SHXMP
          IF (IPR(132) .EQ. 1) XI = YI
          SIGI = SIGI * SHXMP
        ELSE IF (IGBL(29) .EQ. 4 .OR. IGBL(29) .EQ. 7) THEN
          READ (PRBUF, FMOL, ERR = 220) IH, IK, IL,
     1      XFOBS, XFCAL, XSIGI
          IF (IABS(IH) + IABS(IK) + IABS(IL) .EQ. 0) GOTO 220
          XI   = XFOBS**2
          SIGI = 2.0 * SQRT(XI) * XSIGI
          CALI = XFCAL**2
        ELSE IF (IGBL(29) .EQ. 5) THEN
          READ (PRBUF, 99993, ERR = 220) IH, IK, IL,
     1          XFOBS, XFCAL, XSIGI
          XI   = SIGN(XFOBS**2, XFOBS)
          SIGI = 2.0 * ABS(XFOBS) * XSIGI
          CALI = XFCAL**2
        ELSE IF (IGBL(29) .EQ. 8) THEN
          READ (PRBUF, 99993, ERR = 220) IH, IK, IL,
     1          XI, CALI, SIGI
        ELSE IF (IGBL(29) .EQ. 9) THEN
          READ (PRBUF, *, ERR = 220, END = 240) IH, IK, IL,
     1          XI, CALI, SIGI
        ELSE IF (IGBL(29) .EQ. 6) THEN
          READ (PRBUF, 99992, ERR = 220) IH, IK, IL, XFOBS, XSIGI,
     1                                   XFCAL
          XI   = SIGN(XFOBS**2, XFOBS)
          IF (XFOBS .GT. XSIGI / 2.0) THEN
            SIGI = 2.0 * ABS(XFOBS) * XSIGI
          ELSE
            SIGI = 2.0 * ABS(XFCAL) * XSIGI
          ENDIF
          CALI = XFCAL**2
        ELSE IF (IGBL(29) .EQ. 10) THEN
          READ (PRBUF, 99985, END = 240, ERR = 240)
     1            IH, IK, IL, CALI, XI, SIGI
        ELSE IF (IGBL(29) .EQ. 21) THEN
          READ (PRBUF, 99989) IH, IK, IL, XFOBS, XSIGI, ACAL, BCAL
          XI   = XFOBS**2
          SIGI = 2.0 * SQRT(XI) * XSIGI
          YI   = ACAL**2 + BCAL**2
          CALI = YI
        ELSE IF (IGBL(29) .EQ. 22) THEN
          IH   = 0
          IK   = 0
          IL   = 0
          READ (PRBUF, *, END = 240, ERR = 240)
     1          IH, IK, IL, XI, SIGI, FC
          YI   = FC ** 2
          CALI = YI
        ELSE
          READ (PRBUF, *, END = 240, ERR = 240) IH, IK, IL,
     1                                   (XINT(I), I = 1, 2), SIGI
          XI   = XINT(IOBS)  * SHXMP
          YI   = XINT(ICALC) * SHXMP
          CALI = YI
          IF (IPR(132) .EQ. 1) THEN
            XI = YI
          ELSE IF (IPR(132) .EQ. 2) THEN
            XI = ABS (XI - YI)
          ELSE IF (IPR(132) .EQ. 3) THEN
            XI = MAX (XI - YI, 0.0)
          ELSE IF (IPR(132) .EQ. -1) THEN
            UCINT = YI
          ENDIF
          SIGI = SIGI * SHXMP
        ENDIF
      ELSE
  230   IH0 = IH0 + 1
        IF (IH0 .GT. HMAX) GOTO 190
        IF (IH0 .EQ. 0 .AND. IK0 .EQ. 0 .AND. IL0 .EQ. 0) GOTO 230
        IH = IH0
        IK = IK0
        IL = IL0
      ENDIF
      IEND = 0
      GOTO 250
  260 WRITE (LU6,  99986)
      WRITE (LU20, 99997) '_901         1         1'
      IF (IGBL(22) .EQ. -1) THEN
        WRITE (LU22, 99984) (PAR(M), M = 455, 460)
        WRITE (LU22, 99986)
      ENDIF
  240 IEND = 1
  250 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)', //, ':: TRMX = ', 9F7.2)
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)
99992 FORMAT (I4, 2I5, 3F11.2)
99990 FORMAT (/, ':: No Matching Reflection Data Entry found for ', A)
99989 FORMAT (3I4, 4F12.0)
99987 FORMAT (3I4, 2F8.0, I4, 6F8.5)
99986 FORMAT (/, ':: CIF & FCF CELL DIMENSIONS Inconsistent (ABORT!)')
99985 FORMAT (3I4, 2F12.2, F10.2)
99984 FORMAT ('Unit Cell (FCF)  : ', 3F9.4, 3F9.3)
      END
      SUBROUTINE PLA133 (IH, IK, IL, IHT, IKT, ILT, XI, SIGI,
     1 UCINT, ACALS, BCALS, ACOR, IEND)
      PARAMETER (NP12=600,NP13=500,NP17=99,NP38=125,NP39=30)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /PL130/ TRMX(3, 3), STHKM, ISKIP, ITSKP, IOBS, ICALC,
     1 NDEC, SHXMP
      COMMON /PLA22/ LGR(12), XSYST(8), IBVL(8), LAT(7)
      CHARACTER LGR*5, XSYST*12, IBVL*1, LAT*1
      IBVT  = IPR(241)
   10 CALL PLA132 (IH, IK, IL, XI, SIGI, CALI, UCINT, ACALS, BCALS,
     1             ACOR, IEND)
      IF (IEND .EQ. 1) GOTO 30
      IF (IH .EQ. 0 .AND. IK .EQ. 0 .AND. IL .EQ. 0) GOTO 30
      IF (GEN050 (TRMX, IH, IK, IL, IHT, IKT, ILT) .GT. 0.0) THEN
        IF (IBVT .GT. 1) THEN
          IF (GEN049 (LAT(IBVT), IHT, IKT, ILT) .GT. 0.0)  GOTO 20
        ELSE
          GOTO 20
        ENDIF
      ENDIF
      ISKIP = ISKIP + 1
      GOTO 10
   20 STHK  = GEN095 (PAR(191), IHT, IKT, ILT)
      IF (STHK .GT. STHKM) THEN
        ITSKP = ITSKP + 1
        GOTO 10
      ENDIF
      PAR(166) = MAX (PAR(166), STHK)
      GOTO 40
   30 IEND = 1
      IF (ISKIP .GT. 0 .AND. IPR(408) .LE. 0) THEN
        WRITE (LU6, 99999) ISKIP
        CALL PLA269 (3)
        WRITE (LU7, 99999) ISKIP
      ENDIF
      ISKIP = 0
      IF (ITSKP .GT. 0 .AND. IPR(408) .LE. 0) THEN
        WRITE (LU6, 99998) PAR(165), ITSKP
        CALL PLA269 (3)
        WRITE (LU7, 99998) PAR(165), ITSKP
      ENDIF
      ITSKP = 0
      GOTO 50
   40 XI   = XI   * PAR(230)
      SIGI = SIGI * PAR(230)
   50 RETURN
99999 FORMAT (/, ':: Nr. of Eliminated Reflections (Latt Ext. etc.)',
     1 ' =', I5, /)
99998 FORMAT (/, ':: Nr. of Eliminated Reflections (Theta Limit = ',
     1 F5.1, ' Deg) =', I5, /)
      END
      SUBROUTINE PLA134 (FFT, R3D, NATO, RHOMIN, MODE, NPK, IPOSNEG)
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16,
     1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP25=99,NP29=63,
     2 NP38=125,NP39=30,NP41=200,NP45=2048,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /Q/ ICL, IFL(NP17)
      CHARACTER ICL*(NP45), IFL*7
      DIMENSION FFT(*), R3D(*), XS(3), X1(3), IDF(19), B(19), DXMAX(3)
      NSYM = IPR(48)
      IF (MODE .NE. 0) THEN
        ISW  = 3
      ELSE
        IF (IPR(257) .EQ. 1) NSYM = NSYM * IPR(257)
        ISW  = -3
      ENDIF
      KUSER = NP1 - NATO
      DM    = 0.50
      NNX   = IPR(395)
      NNY   = IPR(396)
      NNZ   = IPR(397)
      NNXP2 = NNX + 2
      NXY   = NNXP2 * (NNY + 2)
      NXY3  = 3 * NXY
      DX    = 1.0 / FLOAT(NNX)
      DY    = 1.0 / FLOAT(NNY)
      DZ    = 1.0 / FLOAT(NNZ)
      NAT   = KUSER - 20
      NPIC  = KUSER - 20
      DO 10 I = 1, 3
        DXMAX(I) = DM * PAR(112 + I)
   10 CONTINUE
      DM = DM ** 2
      XLEVEL  = PAR(98) * RHOMIN
      LIMIT   = MIN (KUSER, 2 * NAT)
      IDF(1)  = - NXY   - 1
      IDF(2)  = - NXY   - NNXP2
      IDF(3)  = - NXY
      IDF(4)  = - NXY   + NNXP2
      IDF(5)  = - NXY   + 1
      IDF(6)  = - NNXP2 - 1
      IDF(7)  = - 1
      IDF(8)  =   NNXP2 - 1
      IDF(9)  = - NNXP2
      IDF(10) = 0
      DO 20 I = 1, 9
        IDF(20 - I) = - IDF(I)
   20 CONTINUE
      NO = 0
      IZ = -1
      NZ = 0
   30 N  = -1
      IF (IZ + 2 .EQ. NNZ) GOTO 40
      MAX = NXY
      N   = NNZ - 1
      CALL PLA135 (FFT, R3D, MAX, NNX, NNY, NXY3, N, IPOSNEG)
      N   = 0
      CALL PLA135 (FFT, R3D, MAX, NNX, NNY, NXY3, N, IPOSNEG)
   40 MX  = MAX - NXY + NNX + 1
      N   = N + 1
      CALL PLA135 (FFT, R3D, MAX, NNX, NNY, NXY3, N, IPOSNEG)
      IZ = IZ + 1
      NZ = MOD(NZ + 2, 3) - 1
      KK = ISIGN(NXY3, NZ)
      IF (NZ .LE. 0) THEN
        DO 50 I = 1, 5
          IDF(I) = IDF(I) - KK
   50   CONTINUE
        IF (NZ .EQ. 0) GOTO 70
      ENDIF
      DO 60 I = 15, 19
        IDF(I) = IDF(I) - KK
   60 CONTINUE
   70 DO 190 IY = 1, NNY
        MN = MX + 3
        MX = MX + NNXP2
        DO 180 IX = MN, MX
          IF (R3D(IX) .LT. XLEVEL) GOTO 180
          DO 80 I = 1, 9
            J = IDF(I) + IX
            IF (R3D(IX) .LE. R3D(J)) GOTO 180
   80     CONTINUE
          DO 90 I = 11, 19
            J = IDF(I) + IX
            IF (R3D(IX) .LT. R3D(J)) GOTO 180
   90     CONTINUE
          DO 100 I = 1, 19
            B(I) = R3D(IDF(I) + IX)
  100     CONTINUE
          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) .LE. 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) .LE. 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) .LE. 1.0) GOTO 110
            ENDIF
          ENDIF
          DELTAX = 0.0
          DELTAY = 0.0
          DELTAZ = 0.0
  110     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 .GT. 0) THEN
            IR = 0
            DO 120 K = 1, 3
              XJX(K)     = XXO(NATO + NOP1, K)
              XJX(K + 3) = 0.0
  120       CONTINUE
            DO 170 K = 1, NSYM
              KSYM = K
              CALL SGSM (ICL, KSYM, XJX, 6, ISW, IERR)
              XS(1) = XJX(7)
              XS(2) = XJX(8)
              XS(3) = XJX(9)
              DO 160 I = 1, NO
                DO 150 L = 1, 3
                  X1(L) = XXO(NATO + I, L) - XS(L)
  130             IF (ABS(X1(L)) .LE. 0.5) GOTO 140
                  X1(L) = X1(L) - SIGN(1.0, X1(L))
                  GOTO 130
  140             IF (ABS(X1(L)) .GT. DXMAX(L)) GOTO 160
  150           CONTINUE
                IF (GEN006 (X1, AA, X1) .GT. DM) GOTO 160
                IF (B(10) .LE. XXO(NATO + I, 4)) GOTO 180
                IF (IR .GT. 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
  160         CONTINUE
  170       CONTINUE
            IF (IR .GT. 0) GOTO 180
          ENDIF
          NO = NOP1
          IF (NO .GE. LIMIT) THEN
            CALL GEN091 (XXO, DUMA, NP1, 6, NATO, NO, 4)
            NO     = NPIC
            XLEVEL = XXO(NATO + NPIC, 4)
          ENDIF
  180   CONTINUE
  190 CONTINUE
      IF (IZ .LT. NNZ) THEN
        IF (IZ .EQ. (NNZ - 2)) THEN
          GOTO 30
        ELSE
          GOTO 40
        ENDIF
      ENDIF
      CALL GEN091 (XXO, DUMA, NP1, 6, NATO, NO, 4)
      NPK = NO
      IF (MODE .LT. 0) THEN
        N1 = NATO + 1
        N2 = NATO + NPK
        IF (MODE .EQ. -1) CALL PLA138 (1, 3.2, N1, N2, RHOMIN, IPOSNEG)
      ENDIF
      RETURN
      END
      SUBROUTINE PLA135 (FFT, R3D, MAX, NNX, NNY, NXY3, NZ, IPOSNEG)
      DIMENSION FFT(*), R3D(*)
      IF (MAX .GE. NXY3) MAX = 0
      MX  = MAX
      MAX = MAX - 2
      LOC = NNX * NNY * NZ
      DO 20 IY = 1, NNY
        MIN = MAX + 3
        MAX = MAX + NNX + 2
        DO 10 I = MIN, MAX
          LOC    = LOC + 1
          R3D(I) = FFT(2 * LOC - 1) * IPOSNEG
   10   CONTINUE
        R3D(MAX + 1) = R3D(MIN)
        R3D(MAX + 2) = R3D(MIN + 1)
   20 CONTINUE
      MIN = MAX + 3
      MAX = MAX + 2 * NNX + 6
      DO 30 IX = MIN, MAX
        MX      = MX + 1
        R3D(IX) = R3D(MX)
   30 CONTINUE
      RETURN
      END
      SUBROUTINE PLA136 (VOID, FFT, R3D, NREFA, FS000)
      PARAMETER (NP12=600,NP13=500,NP17=99,NP38=125,NP39=30)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /SFCLC/ NATO, NNG(3), NGRID
      DIMENSION VOID(*), FFT(*), R3D(*)
      M1 = NNG(1)
      M2 = NNG(2)
      M3 = NNG(3)
      NGRD2 = 2 * NGRID
      CALL GEN074 (FFT, 0.0, 1, NGRD2)
      FFT(1) = FS000
      N13 = 0
      DO 30 I = 1, NREFA
        ISN = 1
        AC = VOID(N13 + 7)
        BC = VOID(N13 + 8)
        DO 20 J = 1, 2
          IF (J .EQ. 2) ISN = -1
          IH = ISN * NINT(VOID(N13 + 9))
          IK = ISN * NINT(VOID(N13 + 10))
          IL = ISN * NINT(VOID(N13 + 11))
          IF (IH .LT. 0) IH = IH + M1
          IF (IK .LT. 0) IK = IK + M2
          IF (IL .LT. 0) IL = IL + M3
          LOC = 2 * ((IL * M2 + IK) * M1 + IH + 1)
          FFT(LOC - 1) = AC
          FFT(LOC)     = BC * ISN
   20   CONTINUE
        N13 = N13 + 13
   30 CONTINUE
      CALL GEN028 (FFT, NNG, 3, -1)
      RHOMIN = PAR(269)
      CALL PLA134 (FFT, R3D, NATO, RHOMIN, -1, NPK,  1)
      CALL PLA134 (FFT, R3D, NATO, RHOMIN, -1, NPK, -1)
      RETURN
      END
      SUBROUTINE PLA137 (HMAX, KMAX, LMAX, NREF, IADR, NREFA)
      PARAMETER (NP12=600,NP13=500,NP17=99,NPVD=40000000,NP23=18000,
     1 NP38=125,NP39=30)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON // JNSC(2, NP23), VOID(NPVD)
      COMMON /PL138/ IHKLS(5, 48), PHIS(48), NSYM, NSYMH, MHK, MPH,
     1  ICNTR, IND1, IND2, IND3
      COMMON /PLA22/ LGR(12), XSYST(8), IBVL(8), LAT(7)
      CHARACTER LGR*5, XSYST*12, IBVL*1, LAT*1
      INTEGER HMAX
      FCAL  = 0.0
      PCAL  = 0.0
      IRPK  = 100000
      IRPKS = 1
      IND1  = 1
      IND2  = 2
      IND3  = 3
   10 NR13  = 0
      NREFA = 0
      ICNTR = IPR(257)
      IBVT  = IPR(241)
      MPH   = 2 * HMAX + 1
      MPK   = 2 * KMAX + 1
      MPL   = 2 * LMAX + 1
      MHK   = MPH * MPK
      MHKL  = MPL * MHK
      MHKLH = (MHKL - 1) / 2
      IADR  = NPVD - MHKLH
      IF (IADR .LT. 1) THEN
        WRITE (LU6, 99998) NR13, IADR, NPVD
        NREFA = -1
        GOTO 100
      ENDIF
      DO 20 I = 1, MHKLH
        VOID(IADR + I) = 0.0
   20 CONTINUE
      NEXT  = 0
      CALL GEN108 (LU17, 0)
      DO 50 NR = 1, NREF
        READ (LU17, 99996) IHP, IKP, ILP, XI, SGI
        CALL PLA139 (IHP, IKP, ILP, IEXT, IASM)
        IF (IEXT .EQ. 0) THEN
          DO 40 I = 1, NSYMH
            N0 = IADR + IHKLS(4, I)
            IF (NINT(VOID(N0)) .EQ. 0) THEN
              IF (I .EQ. 1) THEN
                ACAL = 0.0
                BCAL = 0.0
                CALL PLA131 (IHKLS(1, 1), IHKLS(2, 1), IHKLS(3, 1),
     1                       ACAL, BCAL, ACALA, BCALA, SNTHA)
                FCAL = SQRT(ACAL**2 + BCAL**2)
                PCAL = ATAN2(BCAL, ACAL)
              ELSE
                PHAS = (PCAL * IHKLS(5, 1) + PHIS(I)) * IHKLS(5, I)
                ACAL = FCAL * COS(PHAS)
                BCAL = FCAL * SIN(PHAS)
              ENDIF
              SQRXI           = SQRT(MAX(0.0, XI))
              VOID(NR13 + 1)  = SQRXI
              VOID(NR13 + 2)  = SGI / MAX (0.001, 2.0 * SQRXI)
              VOID(NR13 + 3)  = ACAL
              VOID(NR13 + 4)  = BCAL
              VOID(NR13 + 5)  = 0.0
              VOID(NR13 + 6)  = 0.0
              VOID(NR13 + 7)  = 0.0
              VOID(NR13 + 8)  = 0.0
              VOID(NR13 + 9)  = IHKLS(1, I)
              VOID(NR13 + 10) = IHKLS(2, I)
              VOID(NR13 + 11) = IHKLS(3, I)
              VOID(NR13 + 12) = ACALA
              VOID(NR13 + 13) = BCALA
              NREFA           = NREFA + 1
              IF (NREFA .GE. IRPK) THEN
                IRPKS = IRPKS + 1
                IRPK  = IRPK  + IRPKS * 100000
                IF (IRPK .GT. 1000000) THEN
                  WRITE (LU6, 99997)
                  NREFA = -1
                  GOTO 100
                ELSE
                  WRITE (LU6,'(''NEW-IRPK ='', I10)') IRPK
                  GOTO 10
                ENDIF
              ENDIF
              VOID(N0) = NREFA + IRPK
              NR13                     = NR13  + 13
              IF (NR13 .GT. IADR) THEN
                WRITE (LU6, 99998) NR13, IADR, NPVD, CHAR(IPR(223))
                WRITE (LU7, 99998) NR13, IADR, NPVD, CHAR(IPR(223))
                NREFA = -1
                GOTO 100
              ENDIF
            ELSE
              N    = (MOD(NINT(VOID(N0)), IRPK) - 1) * 13 + 1
              YANK = VOID(N0) + IRPK
              IF (YANK .GT. 8300000) THEN
                GOTO 40
              ELSE
                VOID(N0) = YANK
              ENDIF
              IF (VOID(N0) .GT. NPVD - IRPK) THEN
                WRITE (LU6, 99995)
                WRITE (LU7, 99995)
                NREFA = -1
                GOTO 100
              ENDIF
              VOID(N) = VOID(N)  + SQRT(MAX(0.0, XI))
            ENDIF
   40     CONTINUE
        ELSE
          NEXT = NEXT + 1
        ENDIF
   50 CONTINUE
      NMIS = 0
      IADD = LMAX * MHK + KMAX * MPH + HMAX
      DO 60 I = 1, MHKLH
        K = NINT(VOID(IADR + I))
        IF (K .NE. 0) THEN
          K0 = MOD(K, IRPK)
          VOID(IADR + I) = K0
          K0 = (K0 - 1) * 13
          K1 = K / IRPK
          VOID(K0 + 1) = VOID(K0 + 1) / K1
        ELSE
          IH = I + IADD
          IL = IH / MHK
          IH = IH - IL * MHK
          IL = IL - LMAX
          IK = IH / MPH
          IH = IH - IK * MPH - HMAX
          IK = IK - KMAX
          STLK         = GEN095 (PAR(191), IH, IK, IL)
          IF (STLK .LT. 0.09) THEN
            IF (IBVT .GT. 1) THEN
              IF (GEN049 (LAT(IBVT), IH, IK, IL) .LT. 0) GOTO 60
            ENDIF
            CALL PLA139 (IH, IK, IL, IEXT, IASM)
            IF (IEXT .EQ. 0 .AND. IASM .NE. 0) THEN
              TH = ASIN (SQRT(STLK) * PAR(17)) * GL(5)
              NMIS = NMIS + 1
              IF (NMIS .EQ. 1) THEN
                CALL PLA269 (4)
                WRITE (LU7, 99993)
              ENDIF
              CALL PLA269 (1)
              WRITE (LU7, 99994) NMIS, IH, IK, IL, TH
            ENDIF
          ENDIF
        ENDIF
   60 CONTINUE
      WRITE (LU6, 99999) NEXT, NREF - NEXT, NMIS
      CALL PLA269 (4)
      WRITE (LU7, 99999) NEXT, NREF - NEXT, NMIS
  100 RETURN
99999 FORMAT (/,
     1        ':: Number of Removed Systematic Extinctions = ', I7, /,
     1        ':: Number of Non-extinction     Reflections = ', I7, /,
     2        ':: Number of Missing Low Order  Reflections = ', I7)
99998 FORMAT (/, 'F: Scratch Array Overrun (NR13,IADR,NPVD =)', 3I6, /,
     1        3X, 'Use larger program version i.e. recompile with ',
     2        'larger NPVD', A, /)
99997 FORMAT (/, 'F: 1000000 Reflection Number in Hemisphere Exceeded')
99996 FORMAT (3I4, 2F15.0)
99995 FORMAT (/, 'F: Scratch Array Overrun', /,
     1        3X, 'Use larger program version i.e. recompile with ',
     2        'larger NPVD', /)
99994 FORMAT (I4, 3I5,F10.2)
99993 FORMAT (/, 'Missing Reflections below sin(theta)/lambda=0.3', /,
     1        47('='), /, '   N    H    K    L     Theta', /, 29('='))
      END
      SUBROUTINE PLA138 (MODE, DMX, N1, N2, RHOMIN, IPOSNEG)
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16,
     1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP22=256,NP25=99,
     2 NP29=63,NP38=125,NP39=30,NP41=200,NP45=2048,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /Q/ ICL, IFL(NP17)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      CHARACTER TYP*1, AREA*2, TYPE*4, MAXMIN*6
      NSYM = IPR(48)
      NAT  = IPR(37)
      NPKV = 0
      V2(1) = DMX / (PAR(101) * SIN(PAR(105) / GL(5)) * PAR(121))
      V2(2) = DMX / (PAR(102) * SIN(PAR(106) / GL(5)) * PAR(119))
      V2(3) = DMX / (PAR(103) * SIN(PAR(104) / GL(5)) * PAR(120))
      IF (N2 .LT. N1) GOTO 140
      IF (MODE .EQ. 1) THEN
        IF (IPOSNEG .GT. 0) THEN
          MAXMIN   = 'Maxima'
          PAR(330) = 0.0
          CALL GEN108 (LU2, 0)
          WRITE (LU2, 99994) JID(1:74), (PAR(100 + I), I = 1, 6)
          IF (SPGRNM(1)(1:3) .EQ. '   ') THEN
            WRITE (LU2, 99978) SPGRNM(1)(13:13), SPGRNM(1)(14:14)
            ISW = 2
            DO 10 I = 2, IPR(255)
              CALL SGSM (ICL, I, XJX, 0, ISW, IERR)
              WRITE (LU2, 99977) ICL(1:60)
   10       CONTINUE
          ELSE
            IF (SPGRNM(1)(8:11) .EQ. '    ') THEN
              I = ICHAR(' ')
            ELSE
              I = ICHAR('.')
            ENDIF
            WRITE (LU2, 99976) SPGRNM(1)(1:7), CHAR(I), SPGRNM(1)(8:11)
            WRITE (LU2, 99974)
          ENDIF
        ELSE
          MAXMIN   = 'Minima'
          PAR(329) = 0.0
        ENDIF
        WRITE (LU6, 99999) MAXMIN, RHOMIN * IPOSNEG, DMX
        IF (IGBL(63) .GT. 0) THEN
          CALL PLA269 (4)
          WRITE (LU7, 99999) MAXMIN, RHOMIN * IPOSNEG, DMX
        ENDIF
      ELSE
        WRITE (PRBUF, 99996) DMX
        WRITE (LU6, 99975) PRBUF
        IF (IGBL(63) .GT. 0) THEN
          CALL PLA269 (3)
          WRITE (LU7, 99975) PRBUF
        ENDIF
      ENDIF
      DO 130 I = N1, N2
        NPK = 0
        DO 110 J = 1, NAT
          CALL GEN048 (-1, IFG(J), 7, IHAT)
          IF (IHAT .EQ. 0) THEN
            DO 100 N = 1, NSYM
              DO 20 K = 1, 3
                XJX(K) = XXO(J, K)
                XJX(K + 3) = 0.0
   20         CONTINUE
              NS = N
              CALL SGSM (LINE, NS, XJX, LU6, 3, IERR)
              K = 1
              GOTO 40
   30         XJX(6 + K) = XJX(6 + K) - 1.0
   40         IF ((XXO(I, K) - XJX(6 + K)) .LE. V2(K)) GOTO 30
              GOTO 60
   50         IF (ABS(XXO(I, K)  - XJX(6 + K)) .LE. V2(K)) GOTO 70
   60         XJX(6 + K) = XJX(6 + K) + 1.0
              IF ((XXO(I, K)  - XJX(6 + K)) .GE. - V2(K)) GOTO 50
              K = K - 1
              IF (K .EQ. 0) GOTO 100
              GOTO 60
   70         K = K + 1
              IF (K .GT. 3) THEN
                DO 80 L = 1, 3
                  V3(L) = XXO(I, L) - XJX(6 + L)
   80           CONTINUE
                CALL GEN002 (2, OR, V3, V4, DIST)
                IF (DIST .LT. DMX) THEN
                  IF (DIST .GT. 0.05) THEN
                    NPK       = NPK + 1
                    DATC(NPK) = DIST
                    IATC(NPK) = J
                  ENDIF
                ENDIF
                GOTO 90
              ENDIF
              GOTO 40
   90         K = K - 1
              GOTO 60
  100       CONTINUE
          ENDIF
  110   CONTINUE
        CALL GEN013 (DATC, IATC, 1, NPK)
        NPKM1 = MIN (NPK, MIN (9, NP4))
        DO 120 J = 1, NPKM1
          XL = - XLAB(IATC(J))
          CALL PLA047 (XL, NQ1, MN, IENR, 0, IGBL(55), 0, 0)
          NAMS(J, 1) = NQ1
  120   CONTINUE
        NPKM = MIN (NPK, 4)
        TYPE = '    '
        IF (MODE .EQ. 2) THEN
          WRITE (AREA, '(I2)') I + 1 - N1
        ELSE IF (MODE .EQ. 1) THEN
          XDENS = IPOSNEG * XXO(I, 4) / PAR(98)
          NPKV = NPKV + 1
          TYPE = 'void'
          IF (NPKM .GT. 0) THEN
            IF (DATC(1) .LT. 2.6) TYPE = '    '
            IF (DATC(1) .LT. 2.0) THEN
              IF (IPOSNEG .GT. 0) THEN
                PAR(330) = MAX (PAR(330), XDENS)
              ELSE
                PAR(329) = MIN (PAR(329), XDENS)
              ENDIF
            ENDIF
          ENDIF
        ENDIF
        IF (IGBL(63) .GT. 0) CALL PLA269 (1)
        IF (MODE .EQ. 1) THEN
          WRITE (LU6, 99997) NPKV, (XXO(I, J), J = 1, 3), XDENS,
     1            TYPE, (NAMS(J, 1)(1:5), DATC(J), J = 1, NPKM)
          IF (IGBL(63) .GT. 0) WRITE (LU7, 99997)
     1            NPKV, (XXO(I, J), J = 1, 3), XDENS,
     1            TYPE, (NAMS(J, 1)(1:5), DATC(J), J = 1, NPKM1)
          IF (IPOSNEG .GT. 0) THEN
            IF (TYPE .EQ. 'void') THEN
              TYP = 'C'
            ELSE
              TYP = 'Q'
            ENDIF
            WRITE (LU2, 99993)  TYP, 100 + NPKV,
     1        (XXO(I, J), J = 1, 3), XXO(I, 4) / PAR(98)
          ENDIF
        ELSE
          WRITE (LU6, 99995)
     1    AREA, (XXO(I, J), J = 1, 3), TYPE,
     2    (NAMS(J, 1)(1:5), DATC(J), J = 1, NPKM)
          IF (IGBL(63) .GT. 0) WRITE (LU7, 99995)
     1    AREA, (XXO(I, J), J = 1, 3), TYPE,
     2    (NAMS(J, 1)(1:5), DATC(J), J = 1, NPKM1)
        ENDIF
  130 CONTINUE
      WRITE (LU6, 99998)
      IF (IGBL(63) .GT. 0) THEN
        CALL PLA269 (1)
        WRITE (LU7, 99998)
      ENDIF
  140 RETURN
99999 FORMAT ('Unique Density ', A, ' in Enhanced  Difference ',
     1 'Map (CutOff level =', F6.2, ' eA-3)', /, 80('='), /, 6X, 'x',
     2 5X, 'y', 5X, 'z  (e/A^3)', 5X, 'Shortest Contacts within',
     3 F4.1, ' Angstrom (Excl. H)', /,  80('='))
99998 FORMAT (' ')
99997 FORMAT (I3, 3F6.3, F6.2, 1X, A, 1X, 9(A, F4.2, '; '))
99996 FORMAT (6X, 'x', 5X, 'y', 5X, 'z', 14X, 'Shortest ',
     1 'Contacts within', F4.1, ' Angstrom (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')
99978 FORMAT ('LATT ', A, 2X, A)
99977 FORMAT ('SYMM ', A)
99976 FORMAT ('SPGR ', 3A)
99975 FORMAT (/, A, /, 80('='))
99974 FORMAT ('# Note: Atoms in Void as Cxxx and Qxxx all others')
      END
      SUBROUTINE PLA139 (IHP, IKP, ILP, IEXT, IASM)
      PARAMETER (NP12=600,NP13=500,NP17=99,NP38=125,NP39=30,NP45=2048)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /Q/ ICL, IFL(NP17)
      CHARACTER ICL*(NP45), IFL*7
      COMMON /PL138/ IHKLS(5, 48), PHIS(48), NSYM, NSYMH, MHK, MPH,
     1  ICNTR, IND1, IND2, IND3
      DIMENSION XJX(12)
      IHKL0 = 0
      IHKLM = 0
      IEXT = 0
      IASM = 1
      DO 10 I = 1, NSYMH
        XJX(1) = IHP
        XJX(2) = IKP
        XJX(3) = ILP
        XJX(4) = 0.0
        NS = I
        CALL SGSM (ICL, NS, XJX, 0, 5, IERR)
        IH    = NINT(XJX(6 + IND1))
        IK    = NINT(XJX(6 + IND2))
        IL    = NINT(XJX(6 + IND3))
        IHKL  = IL * MHK + IK * MPH + IH
        IF (IHKL .LT. 0) THEN
          IH      = - IH
          IK      = - IK
          IL      = - IL
          IHKL    = - IHKL
          ISHKL   = - 1
        ELSE
          ISHKL   =   1
        ENDIF
        IF (IHKL .GT. IHKLM) THEN
          IHKLM = IHKL
          IF (I .GT. 1) IASM = 0
        ENDIF
        IHKLM       = MAX (IHKLM, IHKL)
        IHKLS(1, I) = IH
        IHKLS(2, I) = IK
        IHKLS(3, I) = IL
        IHKLS(4, I) = IHKL
        IHKLS(5, I) = ISHKL
        PHIS(I)     = XJX(10) / GL(5)
        IF (ICNTR .EQ. 2) THEN
          IHKLI = IABS(IHKL)
        ELSE
          IHKLI = IHKL * ISHKL
        ENDIF
        IF (I .GT. 1) THEN
          IF (IHKL0 .EQ. IHKLI) THEN
            IF (NINT(XJX(4) / GL(5)) .NE. NINT(XJX(10) / GL(5)))
     1       THEN
              IEXT = 1
              GOTO 20
            ENDIF
          ENDIF
        ELSE
          IHKL0 = IHKLI
        ENDIF
   10   CONTINUE
   20 CONTINUE
      RETURN
      END
      SUBROUTINE PLA140
C *********************************************************************
C * ASYM - PROGRAM FOR THE DISPLAY AND EXTRACTION OF A UNIQUE SET OF  *
C *        REFLECTIONS OUT OF A REDUNDANT SET.                        *
C *        A.L.SPEK, Utrecht University (1975-2006)                   *
C *********************************************************************
      PARAMETER (NP4=9,NP10=16,NP12=600,NP13=500,NP17=99,NPVD=40000000,
     1 NP22=256,NP23=18000,NP38=125,NP39=30,NP44=512,NP45=2048,
     2 NPY=NPVD+2*NP23-1114)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      CHARACTER AR(104)*60, CID*(NP44), ZONE(3)*1
      COMMON /CHAR0/ AR, CID, ZONE
      COMMON // IHM(6), IPL, SIG, ATHM, ATHMN, CALIM, ICNT(10, 2),
     1 XX(12), SM(2, 3), RA(50, 2), RB(50, 2), IRC(50, 2), IRD(50, 2),
     2 IT(200), IRAB(2, 2), IKS(3), IHKL(3), IHKLE(3), ID(252),
     3 STAT(20, 10), IAR(NPY)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /PL138/ IHKLS(5, 48), PHIS(48), NSYM, NSYMH, MHK, MPH,
     1 ICNTR, IND1, IND2, IND3
      COMMON /PL130/ TRMX(3, 3), STHKM, ISKIP, ITSKP, IOBS, ICALC,
     1 NDEC, SHXMP
      COMMON /PLA22/ LGR(12), XSYST(8), IBVL(8), LAT(7)
      CHARACTER LGR*5, XSYST*12, IBVL*1, LAT*1
      CHARACTER ICRD*80, AA*80, IUU*1, XAR*60
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0
      COMMON /PAGENM/ PAGET, PAGEIND(25)
      CHARACTER PAGET*8, PAGEIND*8
      COMMON /FNAME/ KNM(8), KXT, KNM16
      COMMON /NAMES/ NAME(8), EXTENS, PROGNM, FNLU1, FNLU16, RDTYPE
      CHARACTER NAME*80, EXTENS*9, PROGNM*28, FNLU1*80, FNLU16*80,
     1          RDTYPE*7
      CHARACTER FNLU18*80
      LOGICAL EXST, OPEND
      COMMON /CGGT/ IGGT
      CHARACTER IGGT*80
      COMMON /CGG11/ BCD, SBCD
      CHARACTER BCD*132, SBCD*132
      CHARACTER LIJN*80
      COMMON /Q/ ICL, IFL(NP17)
      CHARACTER ICL*(NP45), IFL*7
      PAGET = 'ASYM'
      N     = 0
      IF (IPR(220) .GT. 1) THEN
        DO 10 I = 2, IPR(220)
          IF (IFL(I)(1:6) .EQ. 'EXPAND') THEN
            IPR(408) = -1
          ELSE IF (IFL(I)(1:3) .EQ. 'GEN') THEN
            IF (IPR(37) .GT. 0) THEN
              IPR(408) = 1
            ELSE
              IPR(2) = 42
              GOTO 460
            ENDIF
          ELSE IF (IFL(I)(1:6) .EQ. 'EXPECT') THEN
            IPR(408) = 2
            PAGET    = 'EXPECT'
            IPR(392) = 0
            IPR(393) = 0
          ELSE IF (IFL(I)(1:5) .EQ. 'VALID') THEN
            IPR(408) = 0
            IGBL(22) = -1
            IPR(392) = 3
            PAR(165) = 90.0
            INQUIRE (FILE = NAME(1)(1:KNM(1))//'.fck',
     1               OPENED = OPEND)
            IF (.NOT. OPEND) THEN
              OPEN (UNIT = LU22, FILE = NAME(1)(1:KNM(1)) //'.fck',
     1                         STATUS = 'UNKNOWN')
            ENDIF
          ELSE IF (IFL(I)(2:4) .EQ. 'OBS') THEN
            IGBL(17) = 1
            IPR(511) = 1
            IPR(393) = 1
            IPR(408) = -1
          ELSE IF (IFL(I)(1:3) .EQ. 'AVF') THEN
            IPR(393) = 1
          ELSE IF (IFL(I)(1:4) .EQ. 'VIEW') THEN
            IGBL(22) = 1
          ELSE IF (IFL(I)(1:5) .EQ. 'ZONEH') THEN
            IPR(394) = 1
          ELSE IF (IFL(I)(1:5) .EQ. 'ZONEK') THEN
            IPR(394) = 2
          ELSE IF (IFL(I)(1:5) .EQ. 'ZONEL') THEN
            IPR(394) = 3
          ELSE IF (IFL(I)(1:4) .EQ. 'LIST') THEN
            N = N + 1
            IPR(392) = NINT(FN(N))
          ELSE IF (IFL(I)(1:3) .EQ. 'THM') THEN
            N = N + 1
            PAR(165) = FN(N)
          ENDIF
   10   CONTINUE
      ENDIF
      CALL PLA293 (PAR(17), 0)
      IF (IPR(408) .GT. 0) THEN
         PAR(165) = ASIN (MIN(1.0, PAR(287) * PAR(17))) * GL(5)
      ENDIF
      IF (IPR(408) .EQ. 1) THEN
        CALL PLA287 (1, 1, 0)
      ELSE
        IF (IPR(39) .EQ. 0) THEN
          CALL PLA080
          CALL PLA042 (1)
        ENDIF
      ENDIF
      CALL PLA269 (0)
      IF (IGBL(63) .GT. 0 .AND. IPR(408) .EQ. 2) THEN
        WRITE (LU7, 99978)
        CALL PLA269 (2)
      ENDIF
      ZONE(1)  = 'H'
      ZONE(2)  = 'K'
      ZONE(3)  = 'L'
      IPR(387) = 1
      IPR(388) = 1
      IPR(406) = 1
      PAR(284) = 2.0
      LUP17    = LU17
      LUP18    = LU18
      NOUTL    = 0
      SMOBS    = 0.0
      SMCAL    = 0.0
      NSMAL    = 0
      FNLU18 = NAME(1)(1:KNM(1)) //'.hks'
      OPEN (UNIT = LU18, FILE = FNLU18, STATUS = 'UNKNOWN')
      IF (IGBL(22) .EQ. -1) THEN
        IF (IPR(37) .NE. 0) CALL PLA287 (1, 0, 0)
        INQUIRE (FILE = FNLU16(1:KNM16), EXIST = EXST)
        IF (.NOT. EXST) THEN
          WRITE (6, 99963) FNLU16(1:KNM16-3)//'hkl or fcf'
          WRITE (LU22, 99963) FNLU16(1:KNM16-3)//'hkl or fcf'
          GOTO 450
        ENDIF
        IGBL(63) = 0
        WRITE (LU22, 99971) IGBL(9), JID(1:10),
     1    NAME(3)(1:KNM(3))//'.'//EXTENS(1:KXT), FNLU16(1:KNM16),
     2    RDTYPE, SPGRNM(1)(1:7), PAR(17), (PAR(100 + M), M = 1, 6)
        IF (PAR(227) .GT. 0.0) WRITE (LU22, 99952) PAR(227), PAR(228)
        IF (PAR(229) .LT. 999999.0) WRITE (LU22, 99951) PAR(229)
      ENDIF
      IF (PAR(101) .LT. 1.001) THEN
        IF (IGBL(22) .EQ. -1) THEN
          WRITE (LU22, 99954)
        ELSE
          WRITE (6, 99954)
        ENDIF
        GOTO 450
      ENDIF
      IF (IGBL(22) .NE. 0) THEN
        LUP17 = 0
        LUP18 = 0
      ENDIF
   20 NLEV = -2
      NID  = 0
      GOTO 60
   30 CALL PLA013 (0, 1)
      IF (LRET .EQ. 3) THEN
        GOTO 20
      ELSE IF (LRET .EQ. 2) THEN
        GOTO 450
      ELSE IF (LRET .EQ. 4) THEN
        IF (NLEV .EQ. -2) GOTO 60
      ENDIF
   40 IF (IPR(392) .NE. 3) GOTO 450
      NLEV = MAX (0, NLEV + IPR(389))
      IF (NLEV .GT. -1) THEN
        NHEAD = 0
   50   CALL PLA142 (NLEV, NHEAD)
        IF (IGBL(22) .LT. 0) THEN
          IF (IKS(IND3) .GT. NLEV) THEN
            GOTO 380
          ELSE
            NLEV = NLEV + 1
            GOTO 50
          ENDIF
        ELSE
          GOTO 30
        ENDIF
      ENDIF
   60 IND3 = IPR(394)
      IF (IPR(394) .EQ. 2) THEN
        IND1 = 1
        IND2 = 3
      ELSE IF (IPR(394) .EQ. 1) THEN
        IND1 = 2
        IND2 = 3
      ELSE
        IND1 = 1
        IND2 = 2
      ENDIF
      CALL GEN097 (IHM, 1, 6, 0)
      CALL GEN097 (IPR, 370, 386, 0)
      CALL GEN097 (ICNT, 1, 20, 0)
      CALL GEN097 (IT, 1, 200, 0)
      IF (IPR(408) .EQ. 2) THEN
        THM = 90.0
      ELSE
        THM = PAR(165)
      ENDIF
      STHKM = (SIN(THM / GL(5)) / PAR(17))**2
      ITEL  = 0
      NLEV  = -1
      IHT   = 0
      IKT   = 0
      ILT   = 0
      SIG   = PAR(284)
      XINTM = 0.0
      XSIGM = 0.0
      ATHM  = 0.0
      ATHMN = 999.0
      DOSAV = 0.0
      DOSAW = 0.0
      CALIM = 0.0
      NSYMH = IPR(255)
      ICNTR = IPR(257)
      IBVT  = IPR(241)
      IMAX  = NSYMH * 6 + 3
      IF (IPR(408) .EQ. 1) THEN
        PSCFA = 100.0
        PSCFB =  10.0
      ELSE
        PSCFA = 1.0
        PSCFB = 1.0
      ENDIF
      IEND  = -1
      CALL GEN108 (LU8, 0)
      DO 80 I = 1, 20
        DO 70 J = 1, 10
          STAT(I, J) = 0.0
   70   CONTINUE
   80 CONTINUE
      KIAR = 0
   90 CALL PLA132 (IH, IK, IL, A, B, CALI, UCINT,
     1               ACALS, BCALS, ACOR, IEND)
      IF (IEND .EQ. 1) GOTO 130
      IF (IH .EQ. 0 .AND. IK .EQ. 0 .AND. IL .EQ. 0) GOTO 90
      IF (GEN050 (TRMX, IH, IK, IL, IHT, IKT, ILT) .LT. 0.0)
     1  THEN
        IPR(371) = IPR(371) + 1
        IF (A .GT. 5.0 * B) THEN
          ITEL = ITEL + 1
          IF (IGBL(22) .NE. -1) THEN
            IF (ITEL .EQ. 1) WRITE (LU7, 99992)
            WRITE (LU7, 99991) IH, IK, IL, A, B
          ENDIF
        ENDIF
        GOTO 90
      ENDIF
      IF (IBVT .GT. 1) THEN
        IF (GEN049 (LAT(IBVT), IHT, IKT, ILT) .LT. 0) THEN
          IF (IPR(408) .LE. 0) THEN
            IPR(370) = IPR(370) + 1
            IF (A .GT. 5.0 * B) THEN
              ITEL = ITEL + 1
              IF (IGBL(22) .NE. -1) THEN
                IF (ITEL .EQ. 1) WRITE (LU7, 99992)
                WRITE (LU7, 99994) IHT, IKT, ILT, A, B
              ENDIF
            ENDIF
          ENDIF
          GOTO 90
        ENDIF
      ENDIF
      STHK = GEN095 (PAR(191), IHT, IKT, ILT)
      IF (STHK .GT. STHKM) THEN
        IF (IPR(408) .LE. 0) THEN
          IPR(372) = IPR(372) + 1
        ENDIF
        GOTO 90
      ENDIF
      TH = ASIN (SQRT (STHK) * PAR(17)) * GL(5)
      IF (STHK .LT. ATHMN) THEN
        ATHMN = STHK
        PAR(445) = ASIN(SQRT(ATHMN) * PAR(17)) * GL(5)
      ENDIF
      IF (STHK .GT. ATHM) THEN
        ATHM = STHK
        DO 100 I = 1, 3
          IHM(I) = MAX (IHM(I), INT(2 * PAR(100 + I) * SQRT(ATHM)))
  100   CONTINUE
      ENDIF
      IPR(373) = IPR(373) + 1
      IF (IGBL(22) .LT. 0) THEN
        CALIM = MAX (CALIM, CALI)
        SIG   = B
        IF (CALI .GT. 0.0) THEN
          IF (CALI .LT. 2 * B) THEN
            SMOBS = SMOBS + A
            SMCAL = SMCAL + CALI
            NSMAL = NSMAL + 1
          ENDIF
          IF (SIG .GT. 0.0) THEN
            DOS = (A - CALI) / SIG
            IF (PAR(227) .GT. 0.0) THEN
              P    = (MAX(A, 0.0) + 2.0 * CALI) / 3.0
              SIGW = SQRT (SIG**2.0 + (PAR(227) * P)**2 + PAR(228) * P)
              SIG  = SIGW
              DOSW = (A - CALI) / SIGW
              IF (ABS(DOSW) .GT. 2.5) THEN
                NOUTL = NOUTL + 1
                DOSAW = DOSAW + DOSW
                DOSAV = DOSAV + DOS
                IF (NOUTL .EQ. 1) WRITE (LU22, 99950)
                WRITE (LU22, 99966) NOUTL, IH, IK, IL, TH, A,
     1                            CALI, B, DOS, SIGW, DOSW
              ENDIF
            ELSE
              IF (ABS (DOS) .GT. 10.0) THEN
                NOUTL = NOUTL + 1
                DOSAV = DOSAV + DOS
                IF (NOUTL .EQ. 1) WRITE (LU22, 99967)
                  WRITE (LU22, 99966) NOUTL, IH, IK, IL, TH, A,
     1                              CALI, B, DOS
              ENDIF
            ENDIF
          ENDIF
        ENDIF
        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, INT(SQRT(STHK) * 20.0) + 1))
        AAA        = MAX (0.0, A)
        BBB        = MAX (0.0, SIG)
        SIGK       = BBB**2
        STAT(N, 1) = STAT(N, 1) + AAA
        STAT(N, 2) = STAT(N, 2) + MAX(0.0, CALI)
        STAT(N, 3) = STAT(N, 3) + 1.0
        STAT(N, 4) = STAT(N, 4) + SQRT(AAA)
        STAT(N, 5) = STAT(N, 5) + ABS(SQRT(AAA) - SQRT(MAX(0.0, CALI)))
        STAT(N, 9) = STAT(N, 9) + AAA
        IF (BBB. GT. 0.0) THEN
          STAT(N, 6)  = STAT(N, 6)  + (AAA - MAX(0.0, CALI)) ** 2 / SIGK
          STAT(N, 7)  = STAT(N, 7)  + AAA ** 2 / SIGK
          STAT(N, 8)  = STAT(N, 8)  + AAA / BBB
          STAT(N, 10) = STAT(N, 10) + BBB
        ENDIF
      ENDIF
      IF (IPR(408) .EQ. 1) THEN
        ACAL = 0
        BCAL = 0
        CALL PLA131 (IHT, IKT, ILT, ACAL, BCAL, ACALA, BCALA, SNTHA)
        ACAL = ACAL + ACALA
        BCAL = BCAL + BCALA
        A    = (ACAL ** 2 + BCAL ** 2)
        B    = SQRT (A)
      ELSE IF (IPR(408) .EQ. 2) THEN
        A    = 100000.0
        B    = 1.0
      ELSE
        IF (IPR(373) .EQ. 1) THEN
          IF (FLOAT(NINT(B)) .NE. B) THEN
              PSCFA = 100.0
            IF (IPR(408) .EQ. 1) THEN
              PSCFB = 10.0
            ELSE
              PSCFB = 100.0
            ENDIF
          ENDIF
        ENDIF
      ENDIF
      XX(1) = IHT
      XX(2) = IKT
      XX(3) = ILT
      XX(4) = 0.0
      IF (KIAR + IMAX .GT. NPY) THEN
        WRITE (LU6, 99990)
        WRITE (LU20, 99956) '_810', 1, 1
        GOTO 450
      ENDIF
      DO 120 J = 1, NSYMH
        CALL SGSM (ICRD, J, XX, LU7, 5, IERR)
        DO 110 I = 1, 3
          L             = NINT(XX(I + 6))
          IAR(KIAR + I) = L
          IHM(I)        = MAX (IHM(I), IABS(L))
  110   CONTINUE
        IAR(KIAR + 4) = NINT(XX(10))
        KIAR = KIAR + 6
  120 CONTINUE
      IAR(KIAR + 1) = NINT(A * PSCFA)
      IAR(KIAR + 2) = NINT(B * PSCFB)
      IAR(KIAR + 3) = 10000
      KIAR          = KIAR + 3
      GOTO 90
  130 IDR = 0
      IF (NOUTL .GT. 0) THEN
        IF (PAR(227) .GT. 0.0) THEN
          WRITE (LU22, 99949) DOSAV / NOUTL, DOSAW / NOUTL
        ELSE
          WRITE (LU22, 99962) DOSAV / NOUTL
        ENDIF
      ENDIF
      IF (NSMAL .GT. 0) THEN
        WRITE (LU22, 99960) SMOBS / NSMAL, SMCAL / NSMAL
      ENDIF
      IF (IPR(392) .GT. 1) THEN
        IF (IHM(IND1) .GT. IHM(IND2)) THEN
          CALL GEN014 (IND1, IND2)
        ENDIF
        IPR(394) = IND3
      ENDIF
      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)
      IF (IGBL(22) .NE. -1) THEN
        WRITE (LU6, 99996) (IHM(MM), MM = 1, 3),
     1                     ZONE(IND1), ZONE(IND2), ZONE(IND3)
        IF (IGBL(63) .GT. 0) WRITE (LU7, 99996) (IHM(MM), MM = 1, 3),
     1                     ZONE(IND1), ZONE(IND2), ZONE(IND3)
      ENDIF
      IF (IPR(373) .EQ. 0) THEN
        IF (IGBL(22) .NE. -1) THEN
          WRITE (LU6, 99995) JID(1:10)
          WRITE (LU7, 99995) JID(1:10)
        ENDIF
        WRITE (LU22, 99995) JID(1:10)
        WRITE (LU20, 99956) '_902', 1, 1
        GOTO 450
      ENDIF
      I0 = - IMAX
      DO 190 N = 1, IPR(373)
        NORI = 0
        I0 = I0 + IMAX
        M  = I0
        K  = I0 - 6
        DO 140 J = 1, NSYMH
          K          = K + 6
          IAR(K + 5) = 1
          IAR(K + 6) = IHM(5) * IAR(K + IND3)
     1               + IHM(4) * IAR(K + IND2) + IAR(K + IND1)
          IF (IABS(IAR(K + 6)) .GE. NPZ) THEN
            WRITE (LU6, 99999) IAR(K + 6), IHM(6), NPZ
            GOTO 450
          ENDIF
          JUNK = IABS(IAR(K + 6)) - IABS(IAR(M + 6))
          IF (JUNK .GE. 0) THEN
            IF (JUNK .EQ. 0) THEN
              IF (IAR(K + 6) .LE. 0) GOTO 140
            ENDIF
            M = K
          ENDIF
  140   CONTINUE
        IOB4 = IAR(I0 + 6)
        DO 150 J = 1, 6
          CALL GEN014 (IAR(I0 + J), IAR(J + M))
  150   CONTINUE
        L0 = IAR(I0 + 4)
        K  = I0 - 6
        DO 160 J = 1, NSYMH
          K = K + 6
          IAR(K + 4) = MOD(IAR(K + 4) - IAR(K + 5) * L0, 360)
          IF (IAR(K + 4) .LT. 0) IAR(K + 4) = 360 + IAR(K + 4)
  160   CONTINUE
        CONTINUE
        J = 1
        K = I0
  170   J = J + 1
        IF (J .LE. NSYMH) THEN
          K   = K + 6
          IT1 = IAR(K + 6)
          IT2 = IAR(I0 + 6)
          IF (ICNTR .EQ. 2) THEN
            IT1 = IABS(IT1)
            IT2 = IABS(IT2)
          ENDIF
          IF (IT1 .NE. IT2) GOTO 170
          IF (IAR(K + 4) .EQ. IAR(I0 + 4)) GOTO 170
          NORI = 1
        ENDIF
        IF (IAR(I0 + 6) .NE. 0) THEN
          DO 180 II = 1, NSYMH
            IOB1 = IAR(I0 + IND3 + II * 6 - 6)
            IOB2 = IAR(I0 + II * 6)
            IOB3 = 0
            IF (II .EQ. 1) IOB3 = IOB4
            IF (NORI .NE. 0) THEN
              IF (IOB3 .EQ. 0) GOTO 180
              IPR(381) = IPR(381) + 1
              IOBUF1   = -1
            ELSE
              IOBUF1   = IABS(IOB1)
            ENDIF
            IA    = IAR(I0 + IMAX - 2)
            IASIG = IAR(I0 + IMAX - 1)
            XINTM = MAX (XINTM, FLOAT(IA))
            XSIGM = MAX (XSIGM, FLOAT(IASIG))
            NID         = NID + 1
            ID(IDR + 1) = IOBUF1
            ID(IDR + 2) = IOB2
            ID(IDR + 3) = IOB3
            ID(IDR + 4) = IA
            ID(IDR + 5) = IASIG
            ID(IDR + 6) = IAR(I0 + IMAX)
            IDR         = IDR + 6
            IF (IDR .GE. 252) THEN
              WRITE (LU8) ID
              IDR = 0
            ENDIF
  180     CONTINUE
        ENDIF
  190 CONTINUE
      WRITE (LU8) ID
      CALL GEN108 (LU8, 0)
      SCFHKL   = 9999999 / XINTM
      IF (SCFHKL .GT. 1.0)    SCFHKL = 1.0
      IF (IGBL(63) .GT. 0 .AND. IPR(408) .NE. 2) THEN
        IF (IGBL(22) .NE. -1) THEN
          WRITE (LU7, 99998) SCFHKL
          WRITE (LU7, 99993) SIG
        ENDIF
      ENDIF
      IF (IPR(393) .EQ. 1 .AND. IGBL(22) .NE. -1) WRITE (LU7, 99997)
      PAR(446) = ASIN(SQRT(ATHM)  * PAR(17)) * GL(5)
      WRITE (LU6, 99989) PAR(446), THM
      IF (IGBL(63) .GT. 0 .AND. IGBL(22) .NE. -1) THEN
        WRITE (LU7, 99989) PAR(446), THM
        CALL SGSM (ICRD, 0, XX, LU7, 4, IERR)
      ENDIF
      CALL GEN108 (LU14, 0)
      IPL = 1
      CR1 = 0.0
      CR2 = 0.0
      CR3 = 0.0
      CALL GEN074 (SM, 0.0, 1, 6)
      IKS(IND3) = -1
      IF (IPR(381) .GT. 0) IKS(IND3) = - 2
  200 CALL GEN108 (LU8, 0)
      IKS(IND3) = IKS(IND3) + 1
      IF (IKS(IND3) .GT. IHM(IND3)) GOTO 320
      N   = 0
      KKK = 0
      IDR = 252
      DO 210 I = 1, NID
        IDR = IDR + 6
        IF (IDR .GE. 252) THEN
          IDR = 0
          READ (LU8) ID
        ENDIF
        IF (ID(IDR + 1) .EQ. IKS(IND3)) THEN
          IKK = NPY - KKK * 6
          IF (ID(IDR + 3) .EQ. 0) THEN
            IOB2 = 0
          ELSE
            KKK  = KKK  + 1
            IOB2 = KKK
            IKK          = NPY - KKK * 6
            IAR(IKK + 1) = ID(IDR + 2)
            IAR(IKK + 2) = MAX (0, ID(IDR + 4))
            IAR(IKK + 3) = ID(IDR + 6)
            IAR(IKK + 4) = ID(IDR + 3)
            IAR(IKK + 5) = ID(IDR + 5)
            IAR(IKK + 6) = I
          ENDIF
          N2 = N + N
          IF (N2 + 2 .GT. IKK) THEN
            WRITE (LU7, 99979)
            GOTO 450
          ENDIF
          IAR(N2 + 1) = IABS(ID(IDR + 2))
          IAR(N2 + 2) = IOB2
          N = N + 1
        ENDIF
  210 CONTINUE
      IF (N .GT. 0 .OR. IGBL(22) .NE. 0) THEN
        IF (N .GT. 1) THEN
          N2 = N * 2
          CALL GEN124 (IAR, 1, N2)
          NB = 2
          CALL GEN014 (IAR(1), IAR(2))
          DO 220 I = 4, N2, 2
            CALL GEN014 (IAR(I - 1), IAR(I))
            IF (IAR(I) .NE. IAR(NB)) THEN
              CALL GEN124 (IAR, NB - 1, I - 2)
              NB = I
            ENDIF
  220     CONTINUE
          CALL GEN124 (IAR, NB - 1, N2)
          N01 = IAR(2)
          N02 = IAR(1)
          J   = 0
          DO 230 I = 2, N
            N11 = IAR((I - 1) * 2 + 2)
            N12 = IAR((I - 1) * 2 + 1)
            IF (N11 .NE. N01 .OR. N12 .NE. N02) THEN
              IF (N11 .EQ. N01 .AND. N02 .EQ. 0) THEN
                N02 = N12
              ELSE
                IAR(J * 2 + 1) = N01
                IAR(J * 2 + 2) = N02
                J              = J + 1
                N01            = N11
                N02            = N12
              ENDIF
            ENDIF
  230     CONTINUE
          IAR(J * 2 + 1) = N01
          IAR(J * 2 + 2) = N02
          N              = J + 1
        ENDIF
        IKS(IND2) = - IHM(IND2)
        CALL PLA143
        IJKM = IHM(IND1) + 1
        DO 240 IJK = 1, IJKM
          IUU      = CHAR(ICHAR('0') + MOD(IJK - 1, 10))
          I        = 2 * (IHM(IND1) + IJK)
          IF (I .LE. NP44) CID(I:I) = IUU
          J        = 2 * (IHM(IND1) - IJK + 2)
          IF (J .LE. NP44) CID(J:J) = IUU
  240   CONTINUE
        IF (IPR(392) .GT. 1 .AND. IKS(IND3) .NE. -1) THEN
         WRITE (LU14, 99977) ZONE(IND3), IKS(IND3), ZONE(IND1),
     1                       CID(1:150), ZONE(IND2)
        ENDIF
        CALL PLA143
        IF (IABS(IPR(392) - 2) .EQ. 1 .OR. IKS(IND3) .EQ. -1) THEN
          IF (IPL .GT. 98) THEN
            IF (IPL .LE. 102) THEN
              DO 250 I = IPL, 102
                CALL GEN038 (AR(I), 1, 60)
  250         CONTINUE
            ENDIF
            IPL   = 1
            IF (IGBL(22) .NE. -1) THEN
              CALL PLA269 (0)
              WRITE (LU7, 99973)
              DO 260 I = 1, 51
                WRITE (LU7, 99972) AR(I), AR(I + 51)
  260         CONTINUE
            ENDIF
          ENDIF
          DO 270 I = 1, 3
            CALL GEN038 (AR(IPL + I - 1), 1, 60)
  270     CONTINUE
          IF (IPR(408) .NE. 2) THEN
            IF (IKS(IND3) .EQ. -1) THEN
              WRITE (XAR, 99975)
            ELSE
              WRITE (XAR, 99976) ZONE(IND3), IKS(IND3)
            ENDIF
          ENDIF
          AR(IPL + 1) = XAR
          IPL         = IPL + 3
        ENDIF
        JP             = 0
        JM             = 0
        IHKA           = - NPZ
        IAR(N * 2 + 1) = 2100000000
        IAR(N * 2 + 2) = 0
        NN             = N + 1
        DO 300 III = 1, NN
          IHKB = IAR((III - 1) * 2 + 1)
          I    = IAR((III - 1) * 2 + 2)
          I6   = NPY - I * 6
          IF (I .GT. 0) IHKB = IAR(I6 + 1)
          IF (IABS(IHKB) .NE. IABS(IHKA)) THEN
            IF (IHKA  .GT. - 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 280 MM = 1, 3
                IHKLE(MM) = IHKL(MM)
  280         CONTINUE
              IF (IKS(IND3) .NE. -1) THEN
                IF (IPR(392) .GT. 1) THEN
  290             IF (IHKL(IND2) .GT. IKS(IND2)) THEN
                    WRITE (LU14, 99974) IKS(IND2),
     1                 CID(1:(4 * IHM(IND1) + 2))
                    IKS(IND2) = IKS(IND2) + 1
                    CALL PLA143
                    GOTO 290
                  ENDIF
                ENDIF
              ENDIF
              CALL PLA141 (JP, 1, LUP17, IRM1)
              IF (ICNTR .NE. 2 .AND. IPR(393) .NE. 1) THEN
                IGBL(18) = 1
                CALL PLA141 (JM, 2, LUP18, IRM2)
                IF ( JP .NE. 0 .AND. JM .NE. 0) THEN
                  SM(1, 3) = ABS(IRM1 - IRM2) + SM(1, 3)
                  SM(2, 3) = SM(2, 3) + IRM1 + IRM2
                  IF (IKS(IND3) .NE. -1) IPR(380) = IPR(380) + 1
                ENDIF
              ENDIF
              JP  = 0
              JM  = 0
              IF (ICNTR .EQ. 2) THEN
                IHKA = IABS(IHKB)
              ELSE
                IHKA = IHKB
              ENDIF
            ELSE
              IF (ICNTR .EQ. 2) IHKB = IABS(IHKB)
              IHKA = IHKB
            ENDIF
          ENDIF
          IF (I .GT. 0 .AND. I .LT. NN) THEN
            REFA   = IAR(I6 + 2) * SCFHKL
            REFB   = IAR(I6 + 5) * SCFHKL
            IF (REFB .LE. 0) REFB = 0.001
            IVGNR  = IAR(I6 + 6)
            IHKL2  = IAR(I6 + 4)
            IF (ICNTR .NE. 2 .AND. IPR(393) .NE. 1 .AND. IHKB .LT. 0)
     1        THEN
              IF (JM .LT. 49) JM = JM + 1
              RA(JM,  2) = REFA
              RB(JM,  2) = REFB
              IRC(JM, 2) = IVGNR
              IRD(JM, 2) = IHKL2
            ELSE
              IF (JP .LT. 49) JP = JP + 1
              RA(JP,  1) = REFA
              RB(JP,  1) = REFB
              IRC(JP, 1) = IVGNR
              IRD(JP, 1) = IHKL2
            ENDIF
          ENDIF
  300   CONTINUE
        IF (IPR(392) .GT. 1 .AND. IKS(IND3) .GT. -1) THEN
  310     WRITE (LU14, 99974) IKS(IND2), CID(1:(4 * IHM(IND1) + 2))
          IKS(IND2) = IKS(IND2) + 1
          CALL PLA143
          IF (IKS(IND2) .LE. IHM(IND2)) GOTO 310
        ENDIF
      ENDIF
      GOTO 200
  320 IF (IPL .GT. 1 .AND. IPR(408) .NE. 2) THEN
        IF (IPL .LE. 102) THEN
          DO 330 I = IPL, 102
            CALL GEN038 (AR(I), 1, 60)
  330     CONTINUE
        ENDIF
        IPL   = 1
        IF (IGBL(22) .NE. -1) THEN
          CALL PLA269 (0)
          WRITE (LU7, 99973)
          DO 340 I = 1, 51
            WRITE (LU7, 99972) AR(I), AR(I + 51)
  340     CONTINUE
        ENDIF
      ENDIF
      IF (IPR(392) .GT. 1 .AND. IGBL(22) .NE. -1) THEN
        CALL GEN108 (LU14, 0)
  350   READ (LU14, 99959, END = 360) PRBUF
        IF (PRBUF(8:8) .EQ. ZONE(IND3)) THEN
          CALL PLA269 (0)
        ENDIF
        WRITE (LU7, 99959) PRBUF
        GOTO 350
      ENDIF
  360 IF (IGBL(22) .NE. -1) THEN
        IF (IPR(408) .NE. 2) THEN
          CALL PLA269 (0)
        ELSE
          CALL PLA269 (2)
        ENDIF
        IF (IPR(408) .LE. 0) THEN
          WRITE (LU6, 99982) IPR(372), IPR(371), IPR(370)
          WRITE (LU7, 99982) IPR(372), IPR(371), IPR(370)
        ENDIF
        IF (IPR(408) .LT. 2) THEN
          WRITE (LU6, 99984) IPR(373), IPR(375)
          WRITE (LU7, 99984) IPR(373), IPR(375)
          IF (IPR(376) .GT. 0 .AND. IPR(408) .LT. 1) THEN
            WRITE (LU6, 99983) IPR(376)
            WRITE (LU7, 99983) IPR(376)
          ENDIF
        ENDIF
      ENDIF
      IPR(379) = IPR(377)
      IF (IPR(408) .LT. 1 .AND. IGBL(22) .EQ. 0) THEN
        IF (IPR(378) .GT. 0) THEN
          CALL GEN108 (LUP18 , 1)
          DO 370 I = 1, IPR(478)
            READ  (LUP18, 99959) AA
            WRITE (LUP17, 99959) AA
  370     CONTINUE
          IPR(379) = IPR(379) + IPR(378)
        ENDIF
        WRITE (LUP17, 99958)
      ENDIF
      IF (IGBL(22) .NE. -1) THEN
        WRITE (LU6, 99988) IPR(377)
        IF (IGBL(63) .GT. 0) WRITE (LU7, 99988) IPR(377)
        IF (IPR(378) .GT. 0 .AND. IPR(408) .NE. 1) THEN
          WRITE (LU6, 99987) IPR(378)
          WRITE (LU6, 99986) IPR(377) - IPR(378)
          IF (IGBL(63) .GT. 0) THEN
            WRITE (LU7, 99987) IPR(378)
            WRITE (LU7, 99986) IPR(377) - IPR(378)
          ENDIF
        ENDIF
        IF (IPR(408) .EQ. 2) IPR(379) = IPR(377) + IPR(378)
        IF (IPR(380) .GT. 0) THEN
          IF (IPR(408) .LT. 1) THEN
            WRITE (LU6, 99985) IPR(380)
            IF (IGBL(63) .GT. 0)  WRITE (LU7, 99985) IPR(380)
          ENDIF
        ENDIF
      ENDIF
      IF (SM(2, 1) .GT. 0.0) THEN
        CR1 = SQRT(ABS(SM(1, 1) / SM(2, 1))) * 100.0
      ENDIF
      IF (SM(2, 2) .GT. 0.0) THEN
        CR2 = SQRT(ABS(SM(1, 2) / SM(2, 2))) * 100.0
        IF (IPR(380) .GT. 0) CR3 = 200.0 * SM(1, 3) / SM(2, 3)
      ENDIF
      IF (IPR(408) .LT. 1) THEN
        IF (IGBL(22) .NE. -1) THEN
          WRITE (LU6, 99981) CR1
          WRITE (LU7, 99981) CR1
          IF (IPR(378) .GT. 0) THEN
            WRITE (LU6, 99980) CR2, CR3
            WRITE (LU7, 99980) CR2, CR3
          ENDIF
        ENDIF
      ENDIF
      IF (IGBL(22) .NE. 0) GOTO 40
  380 IF (IGBL(22) .LT. 0) THEN
        WRITE (LU22, 99970)
        STLMX = SIN(PAR(446) / GL(5)) / PAR(17)
        JMAX  = MIN (19, INT(STLMX / 0.05) + 1)
        STL = 0.45
        DO 390 I = 10, JMAX
          STL = STL + 0.05
          STH = MIN (1.0, STL * PAR(17), STLMX * PAR(17))
          IF (STH .LE. 1.0) THEN
            TH  = ASIN (STH) * GL(5)
            IF (ICNT(I - 9, 1) .NE. 0) THEN
              YDUM = FLOAT(ICNT(I - 9, 2)) / ICNT(I - 9, 1)
            ELSE
              YDUM = 0.0
            ENDIF
            WRITE (LU22, 99969) TH, STH / PAR(17), YDUM,
     1      (ICNT(I - 9, J), J = 1, 2), ICNT(I - 9, 1) - ICNT(I - 9, 2)
            IF (I .EQ. 12) WRITE (LU22, 99957)
          ENDIF
  390   CONTINUE
        IF (PAR(227) .GT. 0.0) THEN
          WRITE (LU22, 99948)
        ELSE
          WRITE (LU22, 99965)
        ENDIF
        DO 400 I = 1, 20
          N = NINT(STAT(I, 3))
          IF (N .GT. 10) THEN
            R1 = 0.0
            R2 = 0.0
            IF (NINT(STAT(I, 4)) .NE. 0) R1 = STAT(I, 5) / STAT(I, 4)
            IF (STAT(I, 7) .GT. 0.0) R2 = SQRT(STAT(I, 6) / STAT(I, 7))
            S   = SQRT(STAT(I, 6) / N)
            R   = STAT(I, 8)  / N
            AI  = STAT(I, 9)  / N
            SA  = STAT(I, 10) / N
            STH = MIN (1.0, PAR(17) * I / 20.0, STLMX * PAR(17))
            TH  = ASIN(STH) * GL(5)
            WRITE (LU22, 99964) TH, STH / PAR(17), N, R1, R2, S, R,
     1             AI, SA
          ENDIF
  400   CONTINUE
        YUNK = MIN (STLMX, 0.6)
        WRITE (LU22, 99968)
     1    IPR(373),  (IPR(M), M = 585, 587), PAR(446),
     2    (IHM(M), M = 1, 3), PAR(445),  IPR(384) + IPR(390), IPR(384),
     3    IPR(390), IPR(379),  IPR(377), IPR(378),
     4    IPR(383) + IPR(362), IPR(383), IPR(362),
     5    IPR(375) + IPR(376), IPR(375), IPR(376),
     6    IPR(386) + IPR(391), IPR(386), IPR(391),
     7    IPR(553), YUNK, IPR(555), YUNK, IPR(557),
     8    IPR(584), IPR(385)
        IF (IPR(553) .GT. 0)
     1    WRITE (LU20, 99956) '_910', IPR(553), IPR(553)
        WRITE (LIJN(1:7), 99953) YUNK
        IF (IPR(555) .GT. 0)
     1    WRITE (LU20, 99956) '_911', IPR(555), IPR(555), LIJN(1:7)
        IF (IPR(557) .GT. 0 .AND. STLMX .GT. 0.6)
     1    WRITE (LU20, 99956) '_912', IPR(557), IPR(557)
        IF (IPR(584) .GT. 0)
     1    WRITE (LU20, 99956) '_913', IPR(584), IPR(584)
        IF (IPR(380) .GT. 0) WRITE (LU22, 99961) IPR(380)
        DIFF = ABS(PAR(446) - PAR(168))
        IF (DIFF .GT. 0.01) WRITE (LU20, 99955) '_920', DIFF, DIFF
        CALL PLA119 (2)
        IF (IPR(123) .EQ. 0 .AND. IGBL(3) .NE. 1 .AND. IGBL(3) .NE. 33
     1      .AND. IGBL(3) .NE. 34) THEN
          CALL GEN108 (LU22, 1)
          N   = 0
  410     VRT = 19.4
          BCD = 'FCF-VALIDATION'//CHAR(0)
          CALL GGIP (HORS, VERT, 0.0, 1)
          N   = N + 1
          IF (N .EQ. 1) THEN
            LIJN = 'VALIDATION REPORT FOR CURRENT FCF'
            CALL GGIP20 (0.0, LIJN, 33, 0.375, 5 + IGBL(68), 2, 7.0,
     1                   VRT - 0.6)
            VRT = VRT - 0.6
          ENDIF
  420     READ (LU22, 99959, END = 440) LIJN
          VRT = VRT - 0.5
          CALL GGIP20 (0.0, LIJN, 80, 0.35, 1, 2, 1.0, VRT)
          IF (VRT .GT. 0.6) GOTO 420
  430     CALL PLA013 (1, 1)
          IF (IGGT(1:4) .EQ. 'PLOT') GOTO 430
          IF (IGGT(1:4) .EQ. 'CALC' .OR. IGGT(1:1) .EQ. 'Y') GOTO 410
          IF (IGGT(1:4) .EQ. 'EXIT') GOTO 450
          IF (IGGT(1:1) .NE. ' ' .AND. IGGT(1:1) .NE. '!') THEN
            IF (IGGT(1:1) .EQ. 'N') GOTO 450
            IF (LRET .EQ. 2) THEN
              CALL GEN108 (LU22, 0)
              GOTO 410
            ENDIF
            LINE = IGGT
            CALL GEN038 (IGGT, 1, 80)
          ENDIF
          GOTO 410
  440     CALL PLA297 (0)
        ENDIF
      ENDIF
  450 IF (IGBL(18) .EQ. 0 .OR.  IGBL(22) .EQ. -1 .OR.
     1   (IGBL(18) .EQ. 1 .AND. IPR(408) .GT. 0)) THEN
        CLOSE (LU18, STATUS = 'DELETE', ERR = 460)
      ELSE
        CLOSE (LU18, ERR = 460)
      ENDIF
  460 CONTINUE
      RETURN
99999 FORMAT (/, ':: Packing Problem (NPZ)', 3I10)
99998 FORMAT (/, ':: Post Scale Factor Applied to I and ',
     1           '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 NPVD of array VOID)', /)
99989 FORMAT (/, ':: Actual Theta-Max:', F7.2, ' Deg.',
     1        ' -- Applied Theta Limit:', F7.2, /)
99988 FORMAT (/,
     1 'Number of Independent   Type  H, K, L Reflections    =', I7)
99987 FORMAT (
     1 'Number of Independent   Type -H,-K,-L Reflections    =', I7)
99986 FORMAT (
     1 'Number of Independent Centrosymmetric Reflections    =', I7)
99985 FORMAT ('Number of Bijvoet Pairs', 30X, '=', I7)
99984 FORMAT (/,'Total Number of Reflections Encountered on INPUT', 5X,
     1 '=', I7, //, 'Number of Less-Thans of Type  H, K, L', 16X, '=',
     2 I7)
99983 FORMAT ('Number of Less-Thans of Type -H,-K,-L', 16X, '=', I7)
99982 FORMAT (':: Number of Deleted > TH(Max) Reflections =', I7, /,
     1        ':: Number of Deleted Non-Int.  Reflections =', I7, /,
     2        ':: Number of Deleted Bravais   Reflections =', I7, /)
99981 FORMAT (//, 'CONSISTENCY +HKL:', F11.2, ' PERCENT')
99980 FORMAT ('CONSISTENCY -HKL:', F11.2,
     1         /, 'FRIEDEL CONSIST.:', F11.2)
99979 FORMAT (':: Too Many Reflections in this Zone', /,
     1 'Try Again with Zones Perp to the Longest Axis', //)
99978 FORMAT (/, 'Report Expected Number of Independent Reflections',
     1        ' for given Symmetry and Resolution.')
99977 FORMAT ('ZONE - ', A, ' =', I5, 63X,
     1 ': + = +HKL, - = -HKL, L = ILT = 2, N = I/SIG(I)+.5  ',
     2 /, 131('-'), /, 4X, A, '--->', A, /, 3X, A, /)
99976 FORMAT (20('*'), ' ZONE  ', A, ' = ', I4, 1X, 24('*'))
99975 FORMAT (20('*'), ' Spacegroup Extinctions ', 16('*'))
99974 FORMAT (I4, 5X, A)
99973 FORMAT (
     12('   H  K  L     <I>   <SIG> ILT     I  &  SIG       I  &  SIG',
     2 10X), /, 130('-'))
99972 FORMAT (A, 10X, A)
99971 FORMAT (80('='), /, 'PLATON/ASYM-(Version', I8,
     1 ') FCF-File Validation for:', A, /, 80('='), /,
     2 'Crystal Data From: ', A, /,
     3 'Fo/Fc   Data From: ', A, 1X, 'FCF-TYPE=', A, /,
     4 'Space Group      : ', A, /,
     5 'Wavelength (Ang) : ', F10.5, /,
     6 'Unit Cell (CIF)  : ', 3F9.4, 3F9.3)
99970 FORMAT (/, 80('='), /, 'Resolution & Completeness Statistics',
     1 9X, '(Cumulative)', /, 80('='),
     2 /, 'Theta sin(th)/Lambda Complete  Expected Measured  Missing',
     3 /, 80('-'))
99969 FORMAT (F6.2, 2F10.3, 4X, 3I9)
99968 FORMAT (/, 80('='), /, 'Summary of Reflection Data in FCF', /,
     1  80('='), /, 'Total  (in FCF) ..............', I7, 2X,
     2 '(Hmax =', I3, ', Kmax =', I3, ', Lmax =', I3, ') Obs', /,
     3 'Actual Theta(Max) (Deg.) .....', F7.2, 2X,
     4 '(Hmax =', I3, ', Kmax =', I3, ', Lmax =', I3, ') Exp', /,
     5 'Actual Theta(Min) (Deg.) .....', F7.2, //,
     6 'Unique (Expected) ............', I7, 2X,
     7 '(HKL', I6, ', -H-K-L', I6, ')', /,
     8 'Unique (in FCF) ..............', I7, 2X,
     9 '(HKL', I6, ', -H-K-L', I6, ')', /,
     * 'Observed [I .gt. 2 Sig(I)] ...', I7, 2X,
     1 '(HKL', I6, ', -H-K-L', I6, ')', /,
     2 'Less-Thans ...................', I7, 2X,
     3 '(HKL', I6, ', -H-K-L', I6, ')', /,
     4 'Missing (Total) ..............', I7, 2X,
     5 '(HKL', I6, ', -H-K-L', I6, ')', //,
     6 'Missing Below Th(Min) ........', I7, /,
     7 'Missing Th(Min) to STh/L=', F5.3, I7, /,
     8 'Missing STh/L=', F5.3, ' to Th(Max)', I7, /,
     9 'Missing Very Strong Refl. ....', I7, //,
     * 'Space Group Extinctions ......', I7)
99967 FORMAT (/, 80('='), /, 'Reflections with Large Ratio:',
     1 ' abs((I(obs) - I(calc)) / Sigma(I)) .GT. 10.0', /, 80('='),
     2 /, '   Nr   H   K   L  Theta', 5X,
     3 'I(obs)', 4X, 'I(calc) Sigma(I)    Ratio', /, 80('-'))
99966 FORMAT (I5, 3I4, F7.2, 2F11.2, F9.2, F9.2, F8.2, F8.2)
99965 FORMAT (/, 80('='), /,
     1 'R-Value Statistics as a Function of Resolution',
     2 ' (in Resolution Shell)', /, 80('='), /,
     3 'Theta sin(Th)/Lambda  #     R1    wR2      S av(I/Sigma)',
     4 3X, 'av(I) av(Sigma)', /, 80('-'))
99964 FORMAT (F6.2, F10.3, I7, 3F7.3, F8.2, F12.2, F8.2)
99963 FORMAT ('Requested FCF-FILE not Found:', A)
99962 FORMAT (55X, 9('-'), /, 46X, 'Average =', F9.2)
99961 FORMAT ('Number of Bijvoet Pairs ......', I7)
99960 FORMAT (/, 'For I(calc) < 2 Sigma(I): <I(obs)> = ', F10.2,
     1        ' and <I(calc)> = ', F10.2)
99959 FORMAT (A)
99958 FORMAT (1X)
99957 FORMAT (60('-'), ' ACTA Min. Res. ----')
99956 FORMAT (A, 2I10, A)
99955 FORMAT (A, 2F10.2)
99954 FORMAT (/, '>> No CELL DATA Found !! - Abort')
99953 FORMAT (F7.3)
99952 FORMAT ('SHELX WGHT Pars. : ', 2F9.4)
99951 FORMAT ('Extinction Par.  : ',  F9.4)
99950 FORMAT (/, 80('='), /, 'Reflections with Large Ratio:',
     1 ' abs((I(obs) - I(calc)) / SigW(I)) .GT. 2.5 ', /, 80('='),
     2 /, '   Nr   H   K   L  Theta', 5X,
     3 'I(obs)', 4X, 'I(calc) Sigma(I)    Ratio SigW(I)  RatioW',
     4 /, 80('-'))
99949 FORMAT (55X, 9('-'), 8X, 8('-'),/, 46X,
     1        'Average =', F9.2, 8X, F8.2)
99948 FORMAT (/, 80('='), /,
     1 'R-Value Statistics as a Function of Resolution',
     2 ' (in Resolution Shell)', /, 80('='), /,
     3 'Theta sin(Th)/Lambda  #     R1    wR2      S  av(I/SigW)',
     4 3X, 'av(I) av(SigW)', /, 80('-'))
      END
      SUBROUTINE PLA141 (JP, IND, LPUN, IRM)
      PARAMETER (NP12=600,NP13=500,NP17=99,NPVD=40000000,NP23=18000,
     1 NP38=125,NP39=30, NP44=512,NPY = NPVD + 2 * NP23 - 1114)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      CHARACTER AR(104)*60, CID*(NP44), ZONE(3)*1
      COMMON /CHAR0/ AR, CID, ZONE
      CHARACTER XAR*60, ICRD*80
      COMMON /PL138/ IHKLS(5, 48), PHIS(48), NSYM, NSYMH, MHK, MPH,
     1 ICNTR, IND1, IND2, IND3
      COMMON // IHM(6), IPL, SIG, ATHM, ATHMN, CALIM, ICNT(10, 2),
     1 XX(12), SM(2, 3), RA(50, 2), RB(50, 2), IRC(50, 2), IRD(50, 2),
     2 IT(200), IRAB(2, 2), IKS(3), IHKL(3), IHKLE(3), ID(252),
     3 STAT(20, 10), IAR(NPY)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      CHARACTER IDSM*1
      NSYMH = IPR(255)
      IHU  = 2 * (IHKL(IND1) + IHM(IND1) + 1) + 1 - IND
      IF (IND .EQ. 1) THEN
        IDSM = '+'
      ELSE
        IDSM = '-'
      ENDIF
      IF (JP .GT. 0) THEN
        SA = 0.0
        SB = 0.0
        DO 10 K = 1, JP
          SY = RB(K, IND)
          SZ = 1.0 / (SY**2)
          SA = SA + RA(K, IND) * SZ
          SB = SB + SZ
   10   CONTINUE
        RM  = SA  / SB
        SM0 = 1.0 / SQRT(SB)
        IRM = NINT(RM)
        ISM = NINT(SM0)
        SMA = 0.0
        SMB = 0.0
        DO 20 K = 1, JP
          DEL = ABS(RA(K, IND)) - ABS(RM)
          IF (JP .NE. 1 .AND. DEL .LE. 0.0) DEL = ABS(DEL)
          SMA = SMA + (DEL        / RB(K, IND))**2
          SMB = SMB + (RA(K, IND) / RB(K, IND))**2
   20   CONTINUE
        SM(1, IND) = SM(1, IND) + SMA * JP
        SM(2, IND) = SM(2, IND) + SMB * (JP - 1)
        IF (IND .NE. 1) THEN
          DO 30 MM = 1, 3
            IHKLE(MM) = - IHKL(MM)
   30     CONTINUE
        ENDIF
        ILT = 1
        IF (RM .LT. SIG * SM0) ILT = 2
        IF (IKS(IND3) .NE. -1) THEN
          IDSM = '*'
          IF (IPR(468) .EQ. 0) THEN
            NDC = NINT(RM / SM0)
          ELSE
            NDC = JP
          ENDIF
          IF (NDC .LT. 10) IDSM = CHAR(ICHAR('0') + NDC)
          IF (ILT .EQ. 2) THEN
            IDSM           = 'L'
            IPR(374 + IND) = IPR(374 + IND) + 1
          ENDIF
        ENDIF
        JPA = - 1
        IF (IABS(IPR(392) - 2) .EQ. 1 .OR. IKS(IND3) .EQ. -1) THEN
   40     JPA = JPA + 2
          IF (JPA .LE. JP) THEN
            JPB = JPA + 1
            IF (JPB .GT. JP) JPB = JP
            LPAB = 0
            DO 50 K = JPA, JPB
              LPAB = LPAB + 1
              IRAB(LPAB, 1) = NINT(RA(K, IND))
              IRAB(LPAB, 2) = NINT(RB(K, IND))
   50       CONTINUE
            IF (IPR(408) .NE. 2) THEN
              WRITE (XAR, 99999) (IRAB(K, 1), IRAB(K, 2), K = 1, LPAB)
              AR(IPL) = XAR
              IF (JPA .EQ. 1) WRITE (XAR, 99997)
     1          (IHKLE(MM), MM = 1, 3), IRM, ISM, ILT
              AR(IPL)(1:30) = XAR(1:30)
              IPL = IPL + 1
              IF (IPL .GT. 102) THEN
                IPL   = 1
                IF (IGBL(22) .NE. -1) THEN
                  CALL PLA269 (0)
                  WRITE (LU7, 99998)
                  DO 60 I = 1, 51
                    WRITE (LU7, 99995) AR(I), AR(I + 51)
   60             CONTINUE
                ENDIF
              ENDIF
            ENDIF
            GOTO 40
          ENDIF
        ENDIF
        IF (IKS(IND3) .NE. -1) THEN
          IPR(376 + IND) = IPR(376 + IND) + 1
          IF (ILT .EQ. 1) THEN
            IF (IND .EQ. 1) THEN
              IPR(383) = IPR(383) + 1
            ELSE
              IPR(362) = IPR(362) + 1
            ENDIF
          ENDIF
          IF (IPR(408) .LT. 2) THEN
            IF (LPUN .GT. 0) WRITE (LPUN, 99996)
     1         (IHKLE(MM), MM = 1, 3), IRM, ISM
            IF (IPR(408) .LT. 0) THEN
              IF (NSYMH .GT. 1) THEN
                DO 70 I = 1, 3
                  XX(I)       = IHKLE(I)
                  IHKLS(I, 1) = IHKLE(I)
   70           CONTINUE
                XX(4) = 0.0
                N     = 1
                DO 100 I = 2, NSYMH
                  CALL SGSM (ICRD, I, XX, LU7, 5, IERR)
                  DO 80 J = 1, 3
                    IHKLS(J, N + 1) = NINT(XX(J + 6))
   80             CONTINUE
                  DO 90 K = 1, N
                    IF (IHKLS(1, K) .EQ. IHKLS(1, N + 1)) THEN
                      IF (IHKLS(2, K) .EQ. IHKLS(2, N + 1)) THEN
                        IF (IHKLS(3, K) .EQ. IHKLS(3, N + 1)) GOTO 100
                      ENDIF
                    ENDIF
                    IF (IHKLS(1, K) .EQ. - IHKLS(1, N + 1)) THEN
                      IF (IHKLS(2, K) .EQ. - IHKLS(2, N + 1)) THEN
                        IF (IHKLS(3, K) .EQ. - IHKLS(3, N + 1))
     1                    GOTO 100
                      ENDIF
                    ENDIF
   90             CONTINUE
                  N        = N + 1
                  IF (LPUN .GT. 0) WRITE (LPUN, 99996)
     1                (IHKLS(J, N), J = 1, 3), IRM, ISM
  100           CONTINUE
              ENDIF
            ENDIF
          ENDIF
        ENDIF
      ENDIF
      IF (IHU .GT. 0 .AND. IHU .LE. NP44) THEN
        CID(IHU:IHU) = IDSM
        IF (IDSM .NE. '+' .AND. IDSM .NE. '-') THEN
          STHK = GEN095 (PAR(191), IHKLE(1), IHKLE(2), IHKLE(3))
          IF (STHK .LT. 0.09) IPR(512) = IPR(512) - 1
        ENDIF
      ENDIF
      RETURN
99999 FORMAT (28X, 2(I10, I6))
99998 FORMAT (
     12('   H  K  L     <I>   <SIG> ILT     I  &  SIG       I  &  SIG',
     2 10X), /, 130('-'))
99997 FORMAT (1X, 3I3, 1X, I9, I6, I2)
99996 FORMAT (3I4, 2I8)
99995 FORMAT (A, 10X, A)
      END
      SUBROUTINE PLA142 (LEV, NHEAD)
      PARAMETER (NP4=9,NP10=16,NP12=600,NP13=500,NP17=99,NPVD=40000000,
     1 NP22=256,NP23=18000,NP38=125,NP39=30,NP44=512,
     2 NPY=NPVD+2*NP23-1114)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON // IHM(6), IPL, SIG, ATHM, ATHMN, CALIM, ICNT(10, 2),
     1 XX(12), SM(2, 3), RA(50, 2), RB(50, 2), IRC(50, 2), IRD(50, 2),
     2 IT(200), IRAB(2, 2), IKS(3), IHKL(3), IHKLE(3), ID(252),
     3 STAT(20, 10), IAR(NPY)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0
      COMMON /PL138/ IHKLS(5, 48), PHIS(48), NSYM, NSYMH, MHK, MPH,
     1 ICNTR, IND1, IND2, IND3
      COMMON /FNAME/ KNM(8), KXT, KNM16
      COMMON /NAMES/ NAME(8), EXTENS, PROGNM, FNLU1, FNLU16, RDTYPE
      CHARACTER NAME*80, EXTENS*9, PROGNM*28, FNLU1*80, FNLU16*80,
     1          RDTYPE*7
      CHARACTER AR(104)*60, CID*(NP44), ZONE(3)*1
      COMMON /CHAR0/ AR, CID, ZONE
      CHARACTER THFL*1
      SHOR = 0.0
      STEP = 0.0
      STPA = 0.0
      STPB = 0.0
      SVER = 0.0
      CHOR = 0.0
      SCAL = 0.0
      JMAX = 0
      IF (IGBL(22) .GT. 0) THEN
        IGBL(23) = 14
        CALL GGIP (HORS, VERT, 0.0, 1)
        CALL GGIP (0.0, 1.0, 0.0, 0)
        CALL PLA117 (HORS, VERT, -1)
        IF (IPR(406) .EQ. 1) THEN
          KNMXT = KNM(3) + KXT + 1
          WRITE (PRBUF, 99989) FNLU1(1:KNMXT),
     1           DTYPE(IABS(IGBL(8)))
          CALL GGIP20 (0.0,  PRBUF, KNMXT + 8, 0.3, -1, 2, 17.0, 1.0)
          IF (IPR(408) .LE. 0) THEN
            WRITE (PRBUF, 99989) FNLU16(1:KNM16), RDTYPE
            CALL GGIP20 (0.0,  PRBUF, KNM16 + 8, 0.3, -1, 2, 17.0, 0.2)
          ELSE
            WRITE (PRBUF, 99988)
            CALL GGIP20 (0.0, PRBUF, 14, 0.3, -1, 2, 17.0, 0.2)
          ENDIF
          THOR = VERT + 2.5
          IF (IPR(257) .EQ. 1) THEN
            IF (IPR(393) .EQ. 1) THEN
              WRITE (PRBUF, 99991)
            ELSE
              WRITE (PRBUF, 99990)
            ENDIF
            CALL GGIP20 (0.0, PRBUF, 18, 0.3, 2, 2, VERT + 1.9,
     1                   VERT - 0.8)
          ENDIF
          WRITE (PRBUF, 99987) 'SpaceGr ', SPGRNM(1)(1:7)
          CALL GGIP20 (0.0, PRBUF, 15, 0.3, 1, 2, THOR, VERT - 1.5)
          WRITE (PRBUF, 99996) 'a      ', PAR(101)
          CALL GGIP20 (0.0, PRBUF, 13, 0.3, 1, 2, THOR, VERT - 2.1)
          WRITE (PRBUF, 99996) 'b      ', PAR(102)
          CALL GGIP20 (0.0, PRBUF, 13, 0.3, 1, 2, THOR, VERT - 2.7)
          WRITE (PRBUF, 99996) 'c      ', PAR(103)
          CALL GGIP20 (0.0, PRBUF, 13, 0.3, 1, 2, THOR, VERT - 3.3)
          WRITE (PRBUF, 99996) 'alpha  ', PAR(104)
          CALL GGIP20 (0.0, PRBUF, 13, 0.3, 1, 2, THOR, VERT - 3.9)
          WRITE (PRBUF, 99996) 'beta   ', PAR(105)
          CALL GGIP20 (0.0, PRBUF, 13, 0.3, 1, 2, THOR, VERT - 4.5)
          WRITE (PRBUF, 99996) 'gamma  ', PAR(106)
          CALL GGIP20 (0.0, PRBUF, 13, 0.3, 1, 2, THOR, VERT - 5.1)
          WRITE (PRBUF, 99984) 'lambda ', PAR(17)
          CALL GGIP20 (0.0, PRBUF, 13, 0.3, 1, 2, THOR, VERT - 5.7)
          WRITE (PRBUF, 99996) 'Th(max)', PAR(446)
          CALL GGIP20 (0.0, PRBUF, 13, 0.3, 1, 2, THOR, VERT - 6.3)
          WRITE (PRBUF, 99996) 'SigOmit', SIG
          CALL GGIP20 (0.0, PRBUF, 13, 0.3, 1, 2, THOR, VERT - 6.9)
          WRITE (PRBUF, 99995)   'Total  ', IPR(373)
          CALL GGIP20 (0.0, PRBUF, 13, 0.3, 1, 2, THOR, VERT - 7.5)
          WRITE (PRBUF, 99995)   'Unique ', IPR(377)
          CALL GGIP20 (0.0, PRBUF, 13, 0.3, 1, 2, THOR, VERT - 8.1)
          WRITE (PRBUF, 99995)   'Obsd   ', IPR(383)
          CALL GGIP20 (0.0, PRBUF, 13, 0.3, 1, 2, THOR, VERT - 8.7)
        ENDIF
        ANG1 = ACOS(PAR(115 + IND1))
        ANG2 = ACOS(PAR(115 + IND2))
        ANG3 = ACOS(PAR(115 + IND3))
        SHOR = PAR(112 + IND1)
        STEP = 1.0 / PAR(100 + IND3)
        STPA = PAR(112 + IND3) * COS(ANG2)
        STPB = PAR(112 + IND3) * (COS(ANG1) - COS(ANG2) * COS(ANG3)) /
     1                            SIN(ANG3)
        SVER = PAR(112 + IND2) * SIN(ANG3)
        CHOR = PAR(112 + IND2) * COS(ANG3)
        SHFT = 0.8
        SCA1 = (VERT - 1.0) /
     1         (PAR(112 + IND2) * SIN (ANG3) * (IHM(IND2) * 2 + 4))
        SCA2 = (VERT - SHFT) /
     1         (PAR(112 + IND1) * (IHM(IND1) * 2 + 1))
        SCAL = MIN (SCA1, SCA2)
        SVER = SVER * SCAL
        SHOR = SHOR * SCAL
        CHOR = CHOR * SCAL
        STEP = STEP * SCAL
        STPA = STPA * SCAL
        STPB = STPB * SCAL
      ENDIF
      CALL GEN108 (LU14, 0)
   10 READ (LU14, 99997, END = 80) CID
      IF (CID(1:4) .NE. 'ZONE') GOTO 10
      READ (CID(11:15), 99994) NL
      IF (NL .NE. LEV) GOTO 10
      IKS(IND3) = NL
      IPR(382)  = MAX (IPR(382), NL)
      WRITE (CID(16:29), 99993) IHM(IND3)
      IF (IGBL(22) .GE. 0) THEN
        HRT = SHFT
        VRT = VERT - 0.4
        CALL GGIP20 (0.0, CID, 29, 0.2, -1, 1, HRT, VRT)
      ENDIF
      READ (LU14, 99997, END = 80) CID
      NS = - IHM(IND2)
      READ (LU14, 99997, END = 80) CID
      IF (IGBL(22) .GE. 0) THEN
        VRT = VRT - SVER
        CALL GGIP20 (0.0, CID(1:5), 5, 0.2, -1, 1, HRT, VRT)
        HRT = HRT + 1.45 + SHOR + NS * CHOR
        DO 20 I = 11, NP44, 2
          IF (HRT .GT. (SHFT + 1.0)) THEN
            CALL GGIP20 (0.0, CID(I:I), 1, 0.2, -1, 1, HRT, VRT)
          ENDIF
          HRT = HRT + SHOR
   20   CONTINUE
      ENDIF
      READ (LU14, 99997, END = 80) CID
      IF (IGBL(22) .GE. 0) THEN
        VRT = VRT - SVER
        CALL GGIP20 (0.0, CID, 15, 0.2, -1, 2, SHFT, VRT)
        CX  = SHFT + 1.5 +
     1        (IHM(IND1) + 1) * SHOR + (NS + IHM(IND2) + 1) * CHOR
        CY  = VRT - (IHM(IND2) + 1) * SVER
        IF (IPR(387) .EQ. 1) THEN
          CXS = CX - LEV * STPA
          CYS = CY + LEV * STPB
          JMAX = NINT(SIN(PAR(446) / GL(5)) / (PAR(17) * 0.05))
          DO 40 J = 10, JMAX
            STL = J * 0.05
            IF (J .EQ. 12) THEN
              CALL GGIP (0.0, 2.0, 0.0, 0)
            ELSE
              CALL GGIP (0.0, 1.0, 0.0, 0)
            ENDIF
            CR = SCAL * 2.0 * STL
            CR = SQRT (MAX(0.0, CR**2 - (NL * STEP)**2))
            CALL PLA289 (CXS, CYS, CR, 120)
   40     CONTINUE
        ENDIF
        IF (IPR(388) .EQ. 1) THEN
          CALL GGIP (0.0, 5.0 + IGBL(68), 0.0, 0)
          CXV  = CX + IHM(IND2) * CHOR
          CYV  = CY - IHM(IND2) * SVER
          CXH  = CX + IHM(IND1) * SHOR
          CALL GGIP (CXV, CYV, 0.0, 3)
          CALL GGIP (CX,  CY,  0.0, 2)
          CALL GGIP (CXH, CY,  0.0, 2)
          CALL GGIP (CX,  CY,  0.0, 3)
          CALL GGIP (0.0, 1.0, 0.0, 0)
          CXV  = CX - IHM(IND2) * CHOR
          CYV  = CY + IHM(IND2) * SVER
          CXH  = CX - IHM(IND1) * SHOR
          CALL GGIP (CXV, CYV, 0.0, 3)
          CALL GGIP (CX,  CY,  0.0, 2)
          CALL GGIP (CXH, CY,  0.0, 2)
          CALL GGIP (CX,  CY,  0.0, 3)
        ENDIF
      ENDIF
      READ (LU14, 99997, END = 80) CID
   50 READ (LU14, 99997, END = 80) CID
      IF (CID(1:4) .NE. 'ZONE') THEN
        NS = NS + 1
        IF (IGBL(22) .GE. 0) THEN
          VRT = VRT - SVER
          CALL GGIP (0.0, 1.0, 0.0, 0)
        ENDIF
        READ (CID(1:4), 99992) NK
        IKS(IND2) = NK
        IF (IGBL(22) .GE. 0) THEN
          CALL GGIP20 (0.0, CID(1:5), 5 + IGBL(68), 0.2, -1, 1, SHFT,
     1                 VRT)
          HRT = SHFT + 1.5 + SHOR + NS * CHOR
        ENDIF
        IKS(IND1) = - IHM(IND1) - 1
        DO 70 I = 11, NP44, 2
          IF (IT(NL + 1) .EQ. 0) THEN
            IKS(IND1) = IKS(IND1) + 1
            IF (CID(I:I) .EQ. 'E') THEN
              CID(I:I) = ' '
              IPR(385) = IPR(385) + 1
            ENDIF
            IF (CID(I+1:I+1) .NE. ' ' .AND. CID(I+1:I+1) .NE. '-'
     1          .AND. CID(I+1:I+1) .NE. '#') THEN
              IPR(390) = IPR(390) + 1
              IF (CID(I+1:I+1) .EQ. '?') THEN
                IPR(391) = IPR(391) + 1
              ENDIF
            ENDIF
            IF (CID(I:I) .NE. ' ' .AND. CID(I:I) .NE. '+'
     1          .AND. CID(I:I) .NE. '#') THEN
              STHK = GEN095 (PAR(191), IKS(1), IKS(2), IKS(3))
              STHL = SQRT (STHK)
              IF (CID(I:I) .EQ. '?') THEN
                IPR(386) = IPR(386) + 1
                IF (IGBL(22) .NE. -1) THEN
                  IF (IPR(386) .EQ. 1) THEN
                    CALL PLA269 (0)
                    WRITE (LU7,  99999)
                    CALL PLA269 (3)
                  ENDIF
                  CALL PLA269 (1)
                  WRITE (LU7, 99998) IPR(386), IKS(1), IKS(2), IKS(3),
     1                               STHL
                ENDIF
                TH   = ASIN (STHL * PAR(17)) * GL(5)
                TH25 = MIN (ASIN  (0.6 * PAR(17)) * GL(5), PAR(446))
                IF (TH .LT. PAR(445)) THEN
                  IPR(553) = IPR(553) + 1
                ELSE IF (TH .GT. TH25) THEN
                  IPR(557) = IPR(557) + 1
                ELSE
                  IPR(555) = IPR(555) + 1
                ENDIF
                IF (STHL .LE. 0.5) THEN
                  ACAL = 0.0
                  BCAL = 0.0
                  CALL PLA131 (IKS(1), IKS(2), IKS(3), ACAL, BCAL,
     1                         ACALA, BCALA, SNTHA)
                  CALC = (ACAL + ACALA) ** 2 + (BCAL + BCALA) ** 2
                  IF (IGBL(22) .LT. 0) THEN
                  NHEAD = NHEAD + 1
                  IF (NHEAD .EQ. 1) WRITE (LU22, 99999)
                  IF (TH .LT. PAR(445)) THEN
                    THFL = '*'
                  ELSE
                    THFL = ' '
                  ENDIF
                  IF (CALC / CALIM .GT. 1.0) IPR(584) = IPR(584) + 1
                  WRITE (LU22, 99998) NHEAD, IKS(1), IKS(2), IKS(3),
     1                             STHL, TH, THFL, CALC, CALC / CALIM
                  ENDIF
                ENDIF
              ENDIF
              IPR(384) = IPR(384) + 1
              ISTH     = INT(STHL * 20.0) - 8
              DO 60 J = 1, 10
                IF (ISTH .LE. J) THEN
                  ICNT(J, 1) = ICNT(J, 1) + 1
                  IF (CID(I:I) .NE. '?') ICNT(J, 2) = ICNT(J, 2) + 1
                ENDIF
   60         CONTINUE
            ENDIF
          ENDIF
          IF (IGBL(22) .GE. 0) THEN
            IF (CID(I:I) .EQ. '*') THEN
              NCOL = 2
            ELSE IF (CID(I:I) .EQ. 'L') THEN
              NCOL = 4
            ELSE IF (CID(I:I) .EQ. 'E') THEN
              NCOL = 4
            ELSE IF (CID(I:I) .EQ. '+') THEN
              NCOL = 1
            ELSE IF (CID(I:I) .EQ. '?') THEN
              NCOL = 5 + IGBL(68)
            ELSE IF (CID(I:I) .EQ. '#') THEN
              NCOL = 5 + IGBL(68)
            ELSE
              IF (IPR(468) .EQ. 0 .OR. CID(I:I) .EQ. '1') THEN
                NCOL = 3
              ELSE
                NCOL = 2
              ENDIF
            ENDIF
            IF (IPR(369) .NE. 0) THEN
              IF (CID(I:I) .NE. '?' .AND. CID(I:I) .NE. '#'
     1            .AND. CID(I:I) .NE. ' ') THEN
                NCOL = 4
                CID(I:I) = '.'
              ENDIF
            ENDIF
            CALL GGIP20 (0.0, CID(I:I), 1, 0.2, NCOL, 1, HRT - 0.1,
     1                   VRT - 0.1)
            HRT = HRT + SHOR
          ENDIF
   70   CONTINUE
        GOTO 50
      ENDIF
      GOTO 90
   80 IF (NHEAD .GT. 0) THEN
        WRITE (LU22, 99983) MAX (0.0, PAR(445))
        IF (PAR(167) .GT. 0.0) WRITE (LU22, 99982) PAR(167)
      ENDIF
      CALL GEN108 (LU14, 0)
      LEV = -1
   90 IT (NL + 1) = 1
      IF (IPR(406) .EQ. 1) THEN
        IF (IGBL(22) .GE. 0) THEN
          PRBUF = 'Resol Perc'
          CALL GGIP20 (0.0, PRBUF(1:10), 10, 0.3, 2, 2, THOR, 0.1)
        ENDIF
        DO 100 I = 10, JMAX
          IF (I .LT. 20) THEN
            IF (I .EQ. 12) THEN
              NCOL = 2
            ELSE
              NCOL = 1
            ENDIF
            IF (ICNT(I - 9, 1) .NE. 0) THEN
              YDUM = ICNT(I - 9, 2) * 100.0 / ICNT(I - 9, 1)
            ELSE
              YDUM = 0.0
            ENDIF
            IF (IGBL(22) .GE. 0) THEN
              WRITE (PRBUF, 99986) I * 0.05, YDUM
              CALL GGIP20 (0.0, PRBUF(1:10), 10, 0.3, NCOL, 2, THOR,
     1                    (I - 9) * 0.6)
            ENDIF
          ENDIF
  100   CONTINUE
        IF (IGBL(22) .GE. 0) THEN
          JMX = MIN (JMAX, 20) + 1
          WRITE (PRBUF, 99985)   'Layer 0 -', IPR(382)
          CALL GGIP20 (0.0, PRBUF, 13, 0.3, 2, 2, THOR, (JMX - 5) * 0.6)
          WRITE (PRBUF, 99995)   'SpGrExt', IPR(385)
          CALL GGIP20 (0.0, PRBUF, 13, 0.3, 4, 2, THOR, (JMX - 6) * 0.6)
          WRITE (PRBUF, 99995)   'MaxUniq', IPR(384)
          CALL GGIP20 (0.0, PRBUF, 13, 0.3, 1, 2, THOR, (JMX - 7) * 0.6)
          WRITE (PRBUF, 99995)   'Missing', IPR(386)
          CALL GGIP20 (0.0, PRBUF, 13, 0.3, 5 + IGBL(68), 2, THOR,
     1                 (JMX - 8) * 0.6)
          CALL GGIP (0.0, 1.0, 0.0, 0)
        ENDIF
      ENDIF
      RETURN
99999 FORMAT (/, 80('='), /,
     1 'Missing Reflections (Asymmetric Reflection Unit)',
     2 ' below sin(th)/lambda = 0.5', /, 80('='), /,
     3 '   Nr       H    K    L    sin(th)/lambda', 3X,
     4 'Theta', 6X, 'I(calc)', 2X, 'I(calc)/I(max)', /, 80('-'))
99998 FORMAT (I5, 3X, 3I5, 3X, F10.3, 6X, F7.2, A, F12.2, F13.5)
99997 FORMAT (A)
99996 FORMAT (A, F6.2)
99995 FORMAT (A, I6)
99994 FORMAT (I5)
99993 FORMAT (3X, '(Max =', I4, ')')
99992 FORMAT (I4)
99991 FORMAT ('Friedels Averaged ')
99990 FORMAT ('No Friedel Average')
99989 FORMAT (A, '-', A)
99988 FORMAT ('Generated Data')
99987 FORMAT (2A)
99986 FORMAT (F4.2, F6.1)
99985 FORMAT (A, I4)
99984 FORMAT (A, F6.4)
99983 FORMAT (/, '  ** Note: I(max) is the maximum I(obs) ',
     1        'encountered in the fcf-file **', //, 6X,
     2 'Starred Reflections have a Theta below Theta(Min) =', F6.2, /)
99982 FORMAT (35X, 'From CIF: Theta(Min) =', F6.2, /)
      END
      SUBROUTINE PLA143
      PARAMETER (NP12=600,NP13=500,NP17=99,NPVD=40000000,NP23=18000,
     1 NP38=125,NP39=30, NP44=512,NPY = NPVD + 2 * NP23 - 1114)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON // IHM(6), IPL, SIG, ATHM, ATHMN, CALIM, ICNT(10, 2),
     1 XX(12), SM(2, 3), RA(50, 2), RB(50, 2), IRC(50, 2), IRD(50, 2),
     2 IT(200), IRAB(2, 2), IKS(3), IHKL(3), IHKLE(3), ID(252),
     3 STAT(20, 10), IAR(NPY)
      COMMON /PLA22/ LGR(12), XSYST(8), IBVL(8), LAT(7)
      CHARACTER LGR*5, XSYST*12, IBVL*1, LAT*1
      CHARACTER AR(104)*60, CID*(NP44), ZONE(3)*1
      COMMON /CHAR0/ AR, CID, ZONE
      COMMON /PL138/ IHKLS(5, 48), PHIS(48), NSYM, NSYMH, MHK, MPH,
     1 ICNTR, IND1, IND2, IND3
      CALL GEN038 (CID, 1, NP44)
      LTNR = IPR(241)
      IMX  = 2 * IHM(IND1) + 1
      J    = -1
      DO 10 I = 1, IMX
        IKS(IND1) = - IHM(IND1) - 1 + I
        J = J + 2
        IF (IKS(IND3) .EQ. 0) THEN
          IF (IKS(IND2) .LT. 0) THEN
            GOTO 10
          ELSE IF (IKS(IND2) .EQ. 0) THEN
            IF (IKS(IND1) .LE. 0) GOTO 10
          ENDIF
        ENDIF
        STHK = GEN095 (PAR(191), IKS(1), IKS(2), IKS(3))
        IF (STHK .LT. ATHM) THEN
          IF (LTNR .GT. 1) THEN
            IF (GEN049 (LAT(LTNR), IKS(1), IKS(2), IKS(3)) .LT. 0.0)
     1        GOTO 10
          ENDIF
          CALL PLA139 (IKS(1), IKS(2), IKS(3), IEXT, IASM)
          IF (J .GT. 0 .AND. J .LT. NP44) THEN
            IF (IEXT .EQ. 0) THEN
              IF (IASM .EQ. 1) THEN
                CID(J:) = ' ?'
                IF (STHK .LT. 0.09) IPR(512) = IPR(512) + 1
              ELSE
                CID(J:) = ' #'
              ENDIF
            ELSE
              IF (IASM .EQ. 1) CID(J:) = ' E'
            ENDIF
          ENDIF
        ENDIF
   10 CONTINUE
      RETURN
      END
      SUBROUTINE PLA144
      PARAMETER (NP4=9,NP10=16,NP12=600,NP13=500,NP17=99,NPVD=40000000,
     1 NP22=256,NP23=18000,NP38=125,NP39=30,NP45=2048)
      COMMON // JNSC(2, NP23), VOID(NPVD)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /PLA22/ LGR(12), XSYST(8), IBVL(8), LAT(7)
      CHARACTER LGR*5, XSYST*12, IBVL*1, LAT*1
      COMMON /Q/ ICL, IFL(NP17)
      CHARACTER ICL*(NP45), IFL*7
      COMMON /CGG11/ BCD, SBCD
      CHARACTER BCD*132, SBCD*132
      COMMON /CGGT/ IGGT
      CHARACTER IGGT*80
      COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0
      INTEGER HMAX
      COMMON /TODAY/ DATIJD
      COMMON /FNAME/ KNM(8), KXT, KNM16
      COMMON /NAMES/ NAME(8), EXTENS, PROGNM, FNLU1, FNLU16, RDTYPE
      CHARACTER NAME*80, EXTENS*9, PROGNM*28, FNLU1*80, FNLU16*80,
     1          RDTYPE*7
      CHARACTER DATIJD*25
      CHARACTER FNLU18*80
      IGBL(1) = 2
      IF (IPR(30) .EQ. 0) THEN
        IGBL(23) = 21
        IPR(500) = NINT (FN(1))
        IPR(511) = 0
        IF (IPR(220) .GT. 1 .AND. IFL(2)(2:4) .EQ. 'OBS') CALL PLA140
        FNLU18 = NAME(1)(1:KNM(1)) //'.cpi'
        OPEN (UNIT = LU18, FILE = FNLU18, STATUS = 'UNKNOWN')
        IGBL(18) = 2
        IF (IPR(511) .EQ. 1) THEN
          CALL PLA293 (PAR(17), 0)
        ELSE
          CALL PLA293 (1.5418, 0)
          IF (IPR(37) .EQ. 0) GOTO 140
          CALL PLA287 (1, 1, 0)
        ENDIF
   10   IF (IPR(500) .LE. 0 .OR. IPR(500) .GT. 5) THEN
          IF (PAR(17) .GT. 1.0) THEN
            IPR(500) = 2
            PAR(371) = 0.1
          ELSE
            IPR(500) = 1
            PAR(371) = 1
          ENDIF
        ENDIF
        STHKM = PAR(287)**2
        NREFL = 0
        NREFS = 0
        AMX   = 0.0
        IF (IPR(511) .EQ. 0) THEN
          HMAX  = INT(2 * PAR(101) * PAR(287)) + 1
          KMAX  = INT(2 * PAR(102) * PAR(287)) + 1
          LMAX  = INT(2 * PAR(103) * PAR(287)) + 1
          IBVT  = IPR(241)
          IL =  - 1
   20     IL = IL + 1
          IF (IL .GT. LMAX) GOTO 55
          IF (IL .GT. 0) THEN
            IK = - KMAX - 1
          ELSE
            IK = -1
          ENDIF
   30     IK = IK + 1
          IF (IK .GT. KMAX) GOTO 20
          IF (IL .EQ. 0 .AND. IK .EQ. 0) THEN
            IH = 0
          ELSE
            IH = - HMAX - 1
          ENDIF
   40     IH = IH + 1
          IF (IH .GT. HMAX) GOTO 30
          IF (IH .EQ. 0 .AND. IK .EQ. 0 .AND. IL .EQ. 0) GOTO 40
          IF (IBVT .GT. 1) THEN
            IF (GEN049 (LAT(IBVT), IH, IK, IL) .LT. 0) GOTO 40
          ENDIF
          STHK = GEN095 (PAR(191), IH, IK, IL)
          IF (STHK .LE. STHKM) THEN
            ACAL = 0.0
            BCAL = 0.0
            CALL PLA131 (IH, IK, IL, ACAL, BCAL, ACALA, BCALA, SNTHA)
            A    = (ACAL + ACALA) ** 2 + (BCAL + BCALA) ** 2
            IF (SNTHA .LT. 1.0) THEN
              TH = ASIN(SNTHA)
              A  = A * (1.0 + COS(2 * TH) ** 2) /
     1             (SIN(TH) **2 * COS(TH))
              NREFL = NREFL + 1
              VOID(18000 + NREFL * 5 - 4) = IH
              VOID(18000 + NREFL * 5 - 3) = IK
              VOID(18000 + NREFL * 5 - 2) = IL
              VOID(18000 + NREFL * 5 - 1) = TH
              VOID(18000 + NREFL * 5)     = A
              AMX            = MAX (AMX, A)
              TH             = TH * GL(5)
              IF (TH .LT. 20.0) THEN
                NREFS          = NREFS + 1
                JNSC(1, NREFS) = NINT(TH * 1000.0)
                JNSC(2, NREFS) = NREFL
              ENDIF
            ENDIF
          ENDIF
          GOTO 40
        ELSE
          CALL GEN108 (LU17, 0)
   50     READ (LU17, 99993, END = 55) IH, IK, IL, A
          IF (IH .EQ. 0 .AND. IK .EQ. 0 .AND. IL .EQ. 0) GOTO 55
          STHK = GEN095 (PAR(191), IH, IK, IL)
          IF (STHK .LE. STHKM) THEN
            TH    = ASIN(SQRT(STHK) * PAR(17))
            A     = A * (1.0 + COS(2 * TH) ** 2) /
     1              (SIN(TH) **2 * COS(TH))
            NREFL = NREFL + 1
            VOID(18000 + NREFL * 5 - 4) = IH
            VOID(18000 + NREFL * 5 - 3) = IK
            VOID(18000 + NREFL * 5 - 2) = IL
            VOID(18000 + NREFL * 5 - 1) = TH
            VOID(18000 + NREFL * 5)     = A
            AMX            = MAX (AMX, A)
            TH             = TH * GL(5)
            IF (TH .LT. 20.0) THEN
              NREFS          = NREFS + 1
              JNSC(1, NREFS) = NINT(TH * 1000.0)
              JNSC(2, NREFS) = NREFL
            ENDIF
          ENDIF
          GOTO 50
        ENDIF
   55   CALL GEN037 (JNSC, 1, NREFS)
        CALL PLA269 (0)
        WRITE (LU7, 99987)
        CALL PLA269(5)
        DO 56 I = 1, NREFS
          TTH = 0.002 * JNSC(1, I)
          J   = JNSC(2, I)
          IH  = NINT(VOID(18000 + J * 5 - 4))
          IK  = NINT(VOID(18000 + J * 5 - 3))
          IL  = NINT(VOID(18000 + J * 5 - 2))
          IR  = NINT(VOID(18000 + J * 5))
          CALL PLA269 (1)
          D = PAR(17) / (2.0 * SIN (TTH / (2.0 * GL(5))))
          WRITE (LU7, 99988) IH, IK, IL, TTH, IR, D
   56   CONTINUE
   60   CALL GEN074 (VOID, 0.0, 1, 18000)
        AMN = AMX / 2500.0
        IF (IPR(500) .EQ. 5) THEN
          FIN = 180.0
        ELSE
          FIN = 20.0 * IPR(500)
        ENDIF
        IFN = NINT (FIN / PAR(411))
        SRT = PAR(411)
        AL  = PAR(371)
        SCL = PAR(372)
        N   = 0
        NP  = 0
   70   N   = N + 1
        IF (N .GT. NREFL) GOTO 90
        TH = VOID(18000 + N * 5 - 1)
        A  = VOID(18000 + N * 5)
        IP = NINT (2.0 * TH * GL(5) / PAR(411))
        IF (IP .GT. IFN) GOTO 70
        VOID(IP) = VOID(IP) + A
        NP = NP + 1
        I  = 0
   80   I  = I + 1
        FACT = A / (1 + AL * I * I)
        IF (IP + I .LE. IFN) VOID(IP + I) = VOID(IP + I) + FACT
        IF ((IP - I) .GT. 0) VOID(IP - I) = VOID(IP - I) + FACT
        IF (FACT .GT. AMN) GOTO 80
        GOTO 70
   90   VM = 0.0
        DO 100 I = 1, IFN
          VM = MAX (VOID(I), VM)
  100   CONTINUE
        VM = VM / (VERT - 4.0)
  110   BCD(1:25) = 'Simulated Powder Pattern'//CHAR(0)
        CALL GGIP (HORS, VERT, 0.0, 1)
        CALL GGIP20 (0.0,  BCD, 25, 1.2, 4, 8, 0.6, VERT - 1.8)
        CALL GGIP20 (0.0,  BCD, 25, 1.2, 2, 8, 0.5, VERT - 1.9)
        VRT = VERT - 3.0
        WRITE (LINE, 99989) PAR(17)
        CALL GGIP20 (0.0, LINE, 17, 0.35, 1, 1, HORS - 5.0, VRT)
        VRT = VRT - 0.7
        WRITE (LINE, 99990) SPGRNM(1)(1:7)
        CALL GGIP20 (0.0, LINE, 17, 0.35, 1, 1, HORS - 5.0, VRT)
        WRITE (LINE, '(''a    '', F7.2)') PAR(101)
        VRT = VRT - 0.7
        CALL GGIP20 (0.0, LINE, 12, 0.35, 1, 1, HORS - 4.0, VRT)
        WRITE (LINE, '(''b    '', F7.2)') PAR(102)
        VRT = VRT - 0.7
        CALL GGIP20 (0.0, LINE, 12, 0.35, 1, 1, HORS - 4.0, VRT)
        WRITE (LINE, '(''c    '', F7.2)') PAR(103)
        VRT = VRT - 0.7
        CALL GGIP20 (0.0, LINE, 12, 0.35, 1, 1, HORS - 4.0, VRT)
        WRITE (LINE, '(''alpha'', F7.2)') PAR(104)
        VRT = VRT - 0.7
        CALL GGIP20 (0.0, LINE, 12, 0.35, 1, 1, HORS - 4.0, VRT)
        WRITE (LINE, '(''beta '', F7.2)') PAR(105)
        VRT = VRT - 0.7
        CALL GGIP20 (0.0, LINE, 12, 0.35, 1, 1, HORS - 4.0, VRT)
        WRITE (LINE, '(''gamma'', F7.2)') PAR(106)
        VRT = VRT - 0.7
        CALL GGIP20 (0.0, LINE, 14, 0.35, 1, 1, HORS - 4.0, VRT)
        IF (IPR(511) * IPR(512) .NE. 0) THEN
          WRITE (LINE, 99991) IPR(512)
          CALL GGIP20 (90.0, LINE, 35, 0.45, 2, 2, 3.0, 2.5)
        ENDIF
        IF (IPR(511) .EQ. 0) THEN
          LINE = 'I(cal)'
        ELSE
          LINE = 'I(obs)'
        ENDIF
        CALL GGIP20 (90.0, LINE, 6, 0.5, 1, 2, 1.75, VERT - 5.0)
        CALL PLA117 (HORS, VERT, -1)
        IF (IPR(55) .NE. -1) CALL GGIP20
     1       (0.0, JID(75:80), 6, 0.45, 1, 2, 10.5, 24.25)
        CALL GGIP (0.0, 0.0, 0.0, 6)
        XSTEP = (HORS - 2.0) / IFN
        IF (NP .GT. 0) THEN
          CALL GEN108 (LU18, 0)
          WRITE (LU18, 99999)
          WRITE (LINE, 99998) SRT
          CALL GEN039 (-1, LINE, 1, 10, NB, NE)
          WRITE (LU18, 99997) LINE(NB:NE)
          WRITE (LINE, 99998) FIN
          CALL GEN039 (-1, LINE, 1, 10, NB, NE)
          WRITE (LU18, 99997) LINE(NB:NE)
          WRITE (LINE, 99998) PAR(411)
          CALL GEN039 (-1, LINE, 1, 10, NB, NE)
          WRITE (LU18, 99997) LINE(NB:NE)
          WRITE (LU18, 99995) KRAD(1:2), PAR(17), DATIJD(5:24)
          CALL GEN039 (-1, JID, 1, 50, NB, NE)
          WRITE (LU18, 99997) JID(NB:50)
          WRITE (LU18, 99994)
          XP = 1.0
          NB = 1
          NE = 1
          CALL GGIP (XP, 1.5, 0.0, 3)
          DO 120 I = 1, IFN
            XP = XP + XSTEP
            YP = MIN (VERT - 4.0, 1.5 + VOID(I) * SCL / VM)
            CALL GGIP (XP, YP, 0.0, 2)
            IF (IPR(569) .EQ. 1 .OR. IPR(570) .EQ. 1) THEN
              IF (I .GT. 1 .AND. I .LT. IFN .AND. YP .GT. 3.0) THEN
                IF (VOID(I - 1) .LT. VOID(I) .AND.
     1              VOID(I + 1) .LT. VOID(I)) THEN
                  THETA = I * PAR(411) / 2
                  D = PAR(17) / (2 * SIN(THETA / GL(5)))
                  IF (IPR(569) .EQ. 1) THEN
                    WRITE (NQ1, 99996) D
                  ELSE
                    WRITE (NQ1, 99996) THETA
                  ENDIF
                  XPP = XP + 0.0875
                  YPP = YP
                  CALL GGIP20 (90.0, NQ1, 7, 0.175, 2, 1, XPP, YPP)
                  CALL GGIP (XP, YP, 0.0, 3)
                ENDIF
              ENDIF
            ENDIF
            WRITE (LINE, 99992) NINT(VOID(I) * 10000.0 / VM)
            CALL GEN039 (-1, LINE, 1, 10, NB, NE)
            WRITE (LU18, 99997) LINE(NB:NE)
  120     CONTINUE
        ENDIF
        IF (FIN .GT. 40.0) THEN
          IS = 5
        ELSE
          IS = 1
        ENDIF
        XP  = 1.0
        XST = IS * XSTEP / PAR(411)
        N   = 0
  130   CALL GGIP (XP, 0.8, 0.0, 3)
        CALL GGIP (XP, 1.2, 0.0, 2)
        CALL GEN040 (N, NQ1, IP)
        CALL GGIP20 (0.0, NQ1, IP, 0.2, 1, 1, XP + 0.1, 1.1)
        IF (N .GT. 0 .AND. IPR(569) .EQ. 1) THEN
          NN = NINT(50.0 * PAR(17) / SIN(N / (GL(5) * 2.0)))
          CALL GEN040 (NN, NQ1, IP)
          CALL GGIP20 (0.0, NQ1, IP, 0.175, 2, 1, XP + 0.01, 0.6)
        ENDIF
        XP = XP + XST
        N  = N  + IS
        IF (N .LE. NINT (FIN)) GOTO 130
        CALL GGIP20 (0.0, '2-Theta Deg. / d * 100 Ang.',
     1       12 + 15 * IPR(569), 0.35, 1, 1, HORS - 8.0, 0.1)
          CALL PLA013 (0, 1)
        CALL GEN072 (IGGT, IFL, FN, KL, KN, 0, LU6, 1,
     1                   1, 80, 7, NP17)
        IF (IFL(1)(1:4) .EQ. 'RADN') THEN
          WL = FN(1)
          CALL PLA293 (WL, 0)
          IPR(549) = 0
          GOTO 10
        ELSE IF (IFL(1)(1:4) .NE. 'EXIT') THEN
          IF (LRET .EQ. 1) THEN
            GOTO 110
          ELSE IF (LRET .EQ. 2) THEN
            GOTO 140
          ELSE IF (LRET .EQ. 3) THEN
            GOTO 60
          ELSE IF (LRET .EQ. 4) THEN
            GOTO 10
          ENDIF
        ENDIF
  140   CLOSE (LU18, ERR = 150)
      ENDIF
  150 RETURN
99999 FORMAT ('SIETRONICS XRD SCAN')
99998 FORMAT (F10.3)
99997 FORMAT (A)
99996 FORMAT (F6.2)
99995 FORMAT (A, /, F7.5, /, A, /, '1')
99994 FORMAT ('SCANDATA')
99993 FORMAT (3I4, F8.0)
99992 FORMAT (I10)
99991 FORMAT ('Missing Low Order Reflections =', I4)
99990 FORMAT ('SpGroup ', A)
99989 FORMAT ('Lambda ', F8.5)
99988 FORMAT (3I5, F8.2, I10, F10.3)
99987 FORMAT ('2-Theta Sorted Reflection Listing', /, 80('='), //, 4X,
     1        'H    K    L 2-Theta Intensity',5X, 'd Ang', /, 80('='))
      END
      SUBROUTINE PLA150 (MODE)
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118,
     1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NPVD=40000000,
     2 NP22=256,NP23=18000,NP25=99,NP29=63,NP38=125,NP39=30,NP41=200,
     3 NP45=2048,NP47=9,MP3=1000,MP1=NPVD + 2 * NP23 - 1836 - 87 * MP3)
      COMMON // SFC(1616), F(84), PEAK(MP3, 46), ICON(MP3, 40),
     1          NCON(MP3), G(52), E(84), C(MP1)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9),
     1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10),
     2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10),
     3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770)
      CHARACTER LABI*4, ATTP*2
      DIMENSION DA(NP10), IA(NP10)
      COMMON /CGG11/ BCD, SBCD
      CHARACTER BCD*132, SBCD*132
      COMMON /CGGT/ IGGT
      CHARACTER IGGT*80
      COMMON /FNAME/ KNM(8), KXT, KNM16
      COMMON /NAMES/ NAME(8), EXTENS, PROGNM, FNLU1, FNLU16, RDTYPE
      CHARACTER NAME*80, EXTENS*9, PROGNM*28, FNLU1*80, FNLU16*80,
     1          RDTYPE*7
      COMMON /PL130/ TRMX(3, 3), STHKM, ISKIP, ITSKP, IOBS, ICALC,
     1 NDEC, SHXMP
      COMMON /PLA22/ LGR(12), XSYST(8), IBVL(8), LAT(7)
      CHARACTER LGR*5, XSYST*12, IBVL*1, LAT*1
      COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0
      CHARACTER STAR*50
      COMMON /Q/ ICL, IFL(NP17)
      CHARACTER ICL*(NP45), IFL*7
      DIMENSION MCONT(NP10)
      S     = 0
      NSYM  = IPR(48)
      NSYMH = IPR(255)
      CENT  = 2 - IPR(257)
      IBVT  = IPR(241)
      LATTS = IPR(256) * IPR(257)
      IGBL(25) = 1
      IF (IPR(220) .GT. 1) THEN
        IF (IFL(2)(1:4) .EQ. 'AUTO') IGBL(25) = 0
      ENDIF
C * SETUP-MODE PARAMETERS
      IF (MODE .EQ. 0) THEN
        IPR(525) = 0
        IF (IPR(220) .GT. 1) THEN
          DO 10 I = 2, IPR(220)
            IF (IFL(I)(1:4) .EQ. 'PATT') THEN
              IPR(525) = 1
            ELSE IF (IFL(I)(1:4) .EQ. 'PATR') THEN
              IPR(525) = -1
            ENDIF
   10     CONTINUE
        ENDIF
      ELSE
C * EXOR-MODE PARAMETERS
        IF (FN(1) .GT. 0.0) PAR(284) = FN(1)
        IF (FN(2) .GE. 0.0) PAR(281) = FN(2)
        IF (FN(3) .GT. 0.0) PAR(282) = FN(3)
        IF (FN(4) .GT. 0.0) PAR(283) = FN(4)
        IF (FN(5) .GT. 0.0) IPR(482) = NINT(FN(5))
        IF (FN(6) .NE. 0.0) IPR(467) = NINT(FN(6))
        IGBL(31) = 6
        CALL PLA021
      ENDIF
      IF (IGBL(25) * IGBL(32) .EQ. 1 .AND. IGBL(50) .EQ. 0) THEN
        IGBL(23)   = 27
        IGGT(2:21) = NAME(1)(1:20)
        PAR1       = -999.0
        PAR2       = FLOAT(-KNM(1))
        CALL GGIP (PAR1, PAR2, 0.0, 5)
        IF (MODE .EQ. 0) THEN
          IF (IPR(525) .NE. 0) THEN
            CALL GGIP (HORS, VERT, 0.0, 1)
            BCD = 'PATTERSON'//CHAR(0)
            CALL GGIP20 (0.0,  BCD, 10, 1.0, 4, 6, 10.1, VERT - 1.5)
            CALL GGIP20 (0.0,  BCD, 10, 1.0, 2, 6,  9.9, VERT - 1.6)
            CALL GGIP (0.0, 0.0, 0.0, 6)
            VRT = VERT - 1.8
          ENDIF
        ELSE
          CALL GGIP (HORS, VERT, 0.0, 1)
          BCD = 'E.X.O.R'//CHAR(0)
          CALL GGIP20 (0.0,  BCD, 7, 1.8, 4, 15, 1.7, VERT - 2.3)
          CALL GGIP20 (0.0,  BCD, 7, 1.8, 2, 15, 1.5, VERT - 2.4)
        ENDIF
      ENDIF
      IGBL(70) = 0
      CALL PLA080
      ICNT3 = 3
      IF (IABS(IGBL(8)) .NE. 2 .AND. IPR(30) .EQ. 0) THEN
        CALL PLA069
        CALL PLA073 (1)
        ICNT3 = 2
      ENDIF
      Z = 0.004 / PAR(17)**2
      L = 1
      DO 50 I = 1, IAN
        N = IEN(I)
        L = L - 1
        W = 0.0
        DO 40 N0 = 1, 51
          X = 0.0
          Y = 0.0
          DO 30 K = 1, 6
            M = L + K
            SFC(M) = SFAC((N - 1) * 15 + 9)
            DO 20 J = 1, 7, 2
              V      = - SFAC((N - 1) * 15 + J + 1) * (W + X)
              SFC(M) = SFC(M) + SFAC((N - 1) * 15 + J) * EXP(V)
   20       CONTINUE
            X = X + Z
            Y = Y + SFC(M)
   30     CONTINUE
          SFC(L + 2) = 1.25 * Y - 3.75 * (SFC(L + 1) + SFC(L + 6))
          L = L + 2
          W = W + 5.0 * Z
   40   CONTINUE
   50 CONTINUE
      IF (IGBL(16) .EQ. 0) THEN
        CALL GEN108 (LU21, 0)
        MF    = 1
        DO 70 J = 1, 51
          G(J) = 0.0
          F(J) = 0.0
          M = 2 * J - 1
          DO 60 K = 1, IAN
            Y = SFC(M) * SFC(M) * CONT(K, ICNT3)
            G(J) = G(J) + Y
            F(J) = F(J) + Y * SFC(M)
            M    = M + 101
   60     CONTINUE
   70   CONTINUE
        WRITE (LU7, 99967) PAR(17)
        CALL GEN074 (C,  999.0, 4, 6)
        CALL GEN074 (C, -999.0, 7, 9)
        IHMIN =  999
        IKMIN =  999
        ILMIN =  999
        IHMAX = -999
        IKMAX = -999
        ILMAX = -999
        THMAX =  0.0
        THMIN =  1.0
        IEND  = -1
        MR    = 0
        MN    = 0
        IH    = 0
        IK    = 0
        IL    = 0
   90   CALL PLA132 (NI, NJ, NK, T, W, CALI, UCINT,
     1             ACALS, BCALS, ACOR, IEND)
        K = 0
        IF (IEND .EQ. 0 .AND. ABS(NI) + ABS(NJ) + ABS(NK) .NE. 0) THEN
          IF (W .LE. 0.0) THEN
            IF (T .LE. 0.0) GOTO 90
            W = SQRT(ABS(T))
          ENDIF
          MN = MN + 1
          IF (GEN050 (TRMX, NI, NJ, NK, IH, IK, IL) .LT. 0.0) GOTO 110
          IF (IBVT .GT. 1) THEN
            IF (GEN049 (LAT(IBVT), IH, IK, IL) .LT. 0) GOTO 110
          ENDIF
          U      = -9999999.0
          U1     = U
          P      = 0.0
          R      = 0.0
          XJX(1) = IH
          XJX(2) = IK
          XJX(3) = IL
          XJX(4) = 0.0
          DO 100 N = 1, NSYMH
            CALL SGSM (LINE, N, XJX, 0, 5, IERR)
            IF (MAX(ABS(XJX(7)), ABS(XJX(8))) .GE. 99.5) GOTO 110
            Q1 = XJX(7) + 200.0 * (XJX(8) + 200.0 * XJX(9))
            Q  = ABS(Q1)
            IF (CENT .EQ. 0) Q1 = Q
            IF (NINT(Q1) .GE. NINT(U1)) THEN
              O = XJX(10) / GL(5)
              O = COS(O) + 21.42 * SIN(O) * CENT
              R = R + O
              IF (NINT(Q1) .GT. NINT(U1)) THEN
                R  = O
                U1 = Q1
              ENDIF
            ENDIF
            IF (NINT(Q) .GE. NINT(U)) THEN
              P = P + 1.0
              IF (NINT(Q) .GT. NINT(U)) THEN
                P = 1.0
                U = Q
              ENDIF
            ENDIF
  100     CONTINUE
          IF (ABS(R) .GE. 0.1) GOTO 120
  110     MR = MR + 1
          IF (MR .EQ. 1) WRITE (LU7, 99983)
          IF (K .GT. 50) THEN
            WRITE (LU7, 99980) NI, NJ, NK, T, W, S
          ELSE
            WRITE (LU7, 99980) NI, NJ, NK, T, W
          ENDIF
          GOTO 90
  120     QS = GEN095 (PAR(191), IH, IK, IL)
          CALL GEN046 (U, X1, Y1, Z1)
          IHMAX = MAX (IHMAX, IH)
          IKMAX = MAX (IKMAX, IK)
          ILMAX = MAX (ILMAX, IL)
          IHMIN = MIN (IHMIN, IH)
          IKMIN = MIN (IKMIN, IK)
          ILMIN = MIN (ILMIN, IL)
          C(7)  = MAX (C(7), X1)
          C(8)  = MAX (C(8), Y1)
          C(9)  = MAX (C(9), Z1)
          C(4)  = MIN (C(4), X1)
          C(5)  = MIN (C(5), Y1)
          C(6)  = MIN (C(6), Z1)
          S     = QS * PAR(17)**2
          O     = S * 50.0
          K     = INT(O)
          IF (K .GT. 50) GOTO 110
          THMAX = MAX (THMAX, S)
          THMIN = MIN (THMIN, S)
          O     = MOD (O, 1.0)
          EE    = SQRT ((O * (G(K + 2) - G(K + 1)) + G(K + 1)) * P)
          IF (EE. NE. 0.0) EE = EXP (3.94784 * QS) / EE
          V = T * 100.0
          W = W * 100.0
          IF (V .LT. W) V = 0.5 * W
          V = SQRT(V)
          W = W / (2.0 * V)
          F(MF)     = U
          F(MF + 1) = V
          IF (ABS(W) .GT. 0.00001) THEN
            F(MF + 2) = W**2
          ELSE
            F(MF + 2) = 1.E-10
          ENDIF
          F(MF + 3) = GL(8) * QS
          F(MF + 4) = MIN (EE * V, 900.0)
          F(MF + 5) = 0.0
          MF        = MF + 6
          IF (MF .GT. 79) THEN
            WRITE (LU21) F
            MF = 1
          ENDIF
          GOTO 90
        ENDIF
        WRITE (LU7, 99994) MN, MR
        IF (MN .EQ. 0) GOTO 1020
        CLOSE (LU16)
        THMIN = NINT(ASIN(SQRT(THMIN)) * 572.9578) / 10.0
        IF (THMAX .GT. 1.0) THEN
          THMAX = 90.0
        ELSE
          THMAX = NINT(ASIN(SQRT(THMAX)) * 572.9578) / 10.0
        ENDIF
        WRITE (LU7, 99991) IHMIN, IHMAX, IKMIN, IKMAX, ILMIN, ILMAX,
     1   THMIN, THMAX
        F(MF) = 0.0
        WRITE  (LU21) F
        CALL GEN108 (LU21, 1)
        HB = C(7) - C(4) + 1.0
        GD = C(8) - C(5) + 1.0
        GA = 1.0  - C(4) - HB * (C(5) + GD * C(6))
        NE = -5
        R  = 0.0
        S  = 0.0
        NM = 0
        CALL GEN074 (C, 0.0, 1, MP1)
        NT = 0
        M  = MP1
  130   READ (LU21) F
        DO 170 I = 1, 79, 6
          IF (0.5 .GT. ABS(F(I))) THEN
            CALL GEN108 (LU21, 0)
            IF (M .EQ. MP1) THEN
              DO 140 K = 1, NT
                IF (K + 10 .GT. M) GOTO 150
                IF (C(K) .GE. 1.0) THEN
                  M    = M - 8
                  C(K) = M + 1
                ENDIF
  140         CONTINUE
  150         CALL GEN074 (C, 0.0, NT + 1, MP1)
              M = NT
              GOTO 130
            ENDIF
            GOTO 180
          ENDIF
          CALL GEN046 (F(I), X, Y, Z)
          N = NINT(GA + X + HB * (Y + GD * Z))
          IF (N .GT. 0 .AND. N .LE. M) THEN
            IF (M .NE. MP1) THEN
              N        = NINT(C(N))
              V        = F(I + 1)
              W        = 1.0 / F(I + 2)
              C(N + 1) = C(N + 1) + V * W
              C(N + 2) = C(N + 2) + W
              C(N + 3) = F(I + 3)
              C(N + 4) = C(N + 4) + F(I + 4) * W
              C(N + 6) = C(N + 6) + V * V * W
              C(N + 7) = F(I)
            ELSE
              NT = MAX (N, NT)
            ENDIF
            C(N) = C(N) + 1.0
          ENDIF
  170   CONTINUE
        GOTO 130
  180   DO 190 J = 1, NT
          M = NINT(C(J))
          IF (M .NE. 0) THEN
            NE        = NE + 6
            E(NE)     = C(M + 7)
            W         = 1.0 / C(M + 2)
            E(NE + 1) = C(M + 1) * W
            E(NE + 2) = W
            E(NE + 3) = C(M + 3)
            E(NE + 4) = MIN (900.0, C(M + 4) * W)
            E(NE + 5) = 0.0
            IF (NE .GE. 79) THEN
              WRITE (LU9) E
              NE = - 5
            ENDIF
            NM = NM + 1
            IF (C(M) .GT. 1.0 .AND. C(M + 1) .GE. 1.E-8) THEN
              X = C(M + 2) * C(M + 6)
              Y = C(M + 1) **2
              S = S + W * X * (C(M) - 1.0)
              R = R + W * C(M) * (X - Y)
              IF (1.04 * Y .LE. X) THEN
                U = 1.0 / (SQRT(W) * C(M + 1))
                W = SQRT(ABS(X / Y - 1.0))
                N = NINT(C(M))
                CALL GEN046 (C(M + 7), X, Y, Z)
              ENDIF
            ENDIF
          ENDIF
  190   CONTINUE
        E(NE + 6) = 0.0
        WRITE (LU9) E
        T = 0.0
        IF (S .NE. 0.0) T = SQRT(ABS(R / S))
        WRITE (LU7, 99985) NM, T
        CALL GEN108 (LU9, 1)
        L = 0
        CALL GEN074 (C, 0.0, 1, 64)
        CALL GEN074 (E, 0.0, 1, 64)
        DO 250 M = 1, 2
  200     READ (LU9) F
          I = -5
  210     I = I + 6
          IF (0.5 .LE. ABS(F(I))) THEN
            X = 1.0 + SQRT(2.584724 * F(I + 3))
            K = MIN (14, INT(X))
            T = MIN (X - FLOAT(K), 1.0)
            W = F(I + 4)
            P = 1.0 - T
            IF (M .EQ. 1) THEN
              C(K)      = C(K)      + P * W**2
              C(K + 1)  = C(K + 1)  + T * W**2
              C(K + 15) = C(K + 15) + P
              C(K + 16) = C(K + 16) + T
            ELSE
              W        = W * (P * C(K + 30) + T * C(K + 31))
              F(I + 4) = MIN (W, 9.0)
              F(I + 1) = F(I + 1) * Q
              F(I + 2) = F(I + 2) * Q**2
              V        = ABS(1.0 - W**2)
              C(K)     = C(K) + P * V / MAX (C(K + 15), 0.01)
              C(K + 1) = C(K + 1) + T * V / MAX (C(K + 16), 0.01)
              CALL GEN046 (F(I), X, Y, Z)
              IF (L .GE. 4) L = 0
              L = L + 1
              C(L + 45) = F(I + 1)
              C(L + 49) = SQRT(F(I + 2))
            ENDIF
            IF (I .LT. 79) GOTO 210
            IF (M .EQ. 2) WRITE (LU21) F
            GOTO 200
          ENDIF
          IF (M .EQ. 1) THEN
            Q = 1.0
            U = 0.0
            DO 230 J = 1, 10
              CALL GEN074 (E, 0.0, 1, 8)
              DO 220 I = 1, 15
                X    = E(8)**2
                P    = EXP(X * U) * C(I)
                V    = P / MAX (1.E-5, C(I + 15))
                W    = P * Q
                Z    = C(I + 15) - W
                E(1) = E(1) + V * P
                W    = W * X
                E(2) = E(2) + V * W
                P    = Q * X
                E(3) = E(3) + V * W * P
                E(4) = E(4) + Z * V
                E(5) = E(5) + Z * V * P
                E(6) = E(6) + C(I)
                E(7) = E(7) + C(I + 15)
                E(8) = E(8) + 0.622004
  220         CONTINUE
              X = 1.0 / (0.1 + E(1))
              W = - X * E(2)
              Z = 1.0 / (0.1 + E(3) + W * E(2))
              Y = Z * W
              X = X + W * Y
              U = U + E(4) * Y + E(5) * Z
              IF (ABS(U) .GE. 0.1) THEN
                U = SIGN (0.09999, U)
                X = 0.0
                Y = 1.0 / (0.1 + E(3))
              ENDIF
              Q = Q + E(4) * X + E(5) * Y
  230       CONTINUE
            Q = SQRT(MAX(Q, 0.0)) * SQRT(FLOAT(LATTS)) * 0.96
            U = 0.05 - 0.5 * U
            DO 240 I = 1, 15
              C(I + 30) = SQRT((C(I + 15) + 0.01 * E(7))
     1                  / (C(I) + 0.01 * E(6)))
  240       CONTINUE
          ENDIF
          CALL GEN108 (LU9, 0)
  250   CONTINUE
        WRITE  (LU21) F
        WRITE (LU7, 99984) Q, U
        IF (IPR(525) .LE. 0) THEN
          CALL GEN108 (LU21, 1)
          CALL GEN108 (LU17, 0)
          EKW = 0.0
          NEK = 0
  260     READ (LU21) F
          DO 270 I = 1, 79, 6
            IF (0.5 .GT. ABS(F(I))) GOTO 280
            CALL GEN046 (F(I), C(1), C(2), C(3))
            V = F(I + 1) * 100.0
            W = SQRT(F(I + 2)) * 100.0
            WRITE (LU17, 99982) NINT(C(1)), NINT(C(2)),
     1                          NINT(C(3)), NINT(V), NINT(W)
            EKW = EKW + ABS(F(I+4)**2 - 1.0)
            NEK = NEK + 1
  270     CONTINUE
          GOTO 260
  280     WRITE (LU17, 99981)
          WRITE (LU7, 99979) EKW / NEK
          IGBL(16) = 1
        ENDIF
      ENDIF
C * EXOR (MODE > 0)
      IF (MODE .GT. 0) THEN
        KNOWN = 0
        DO 285 I = 2, IAN
          IF (LMT(I, 1) .NE. ' Q') THEN
            IF (CONT(I, 3) .NE. CONT(1, 3)) KNOWN = 1
          ENDIF
  285   CONTINUE
        UT = 2.0 * (GL(6) / PAR(17))**2
        SS = PAR(284)**2
        N  = 0
        M  = 0
        CALL GEN108 (LU21, 0)
        CALL GEN108 (LU4, 0)
        IF (SS .LE. 1.E9) THEN
  290     READ  (LU21) F
          WRITE (LU4)  F
          DO 320 I = 1, 79, 6
            IF (NINT(F(I)) .EQ. 0) THEN
              CALL GEN108 (LU21, 0)
              CALL GEN108 (LU4, 1)
  300         READ (LU4) F
              DO 310 J = 1, 79, 6
                IF (NINT(F(J)) .EQ. 0) THEN
                  WRITE (LU21) F
                  CALL GEN108 (LU21, 1)
                  CALL GEN108 (LU4, 0)
                  WRITE (LU7, 99999) SQRT(SS), M, N
                  GOTO 330
                ENDIF
                X = 0.0
                IF (SS * F(J + 2) .GT. F(J + 1)**2) THEN
                  X = 1.0
                  M = M + 1
                ENDIF
                F(J + 3) = MOD(F(J + 3), UT) + UT * X
  310         CONTINUE
              WRITE (LU21) F
              GOTO 300
            ENDIF
            N = N + 1
  320     CONTINUE
          GOTO 290
        ENDIF
  330   EXPMX  = PAR(98) / (12.0 * NSYM)
        CRIT0  = 0.33
        PICKUP = 1.0
        IAN0 = IAN
        IF (LMT(IAN, 1) .EQ. ' Q') IAN0 = IAN - 1
        DO 340 I = 1, IAN0
          DA(I) = 1000.0 - IATNR(IEN(I))
          IA(I) = I
  340   CONTINUE
        CALL GEN013 (DA, IA, 1, IAN0)
        IRMIN = IAN0
        DO 350 I = 1, IAN0
          DA(I)  = 1000.0 - DA(I)
          IF (NINT(DA(I)) .LE. 1) IRMIN = IRMIN - 1
  350   CONTINUE
        RATIO = DA(1) / DA(IRMIN)
        CRIT = CRIT0 / RATIO
        DO 360 I = 1, 3
          V2(I) = 2.0 * PAR(112 + I)
  360   CONTINUE
        IF (IPR(37) .GT. MP3) STOP 'MEMORY (MP3) PROBLEM'
        NPK  = 0
        LOOP = 0
        VRT  = VERT - 3.0
  380   LOOP = LOOP + 1
        NAT  = MIN (MP3, IPR(37) + NPK)
        IF (LOOP .EQ. 1) THEN
          DO 420 J = 1, NAT
            DO 390 I = 1, 3
              XJX(I)     = CON(J, I + 2)
              PEAK(J, I) = XJX(I)
  390       CONTINUE
            PEAK(J, 5) = 100.0
            XJX(10)    = 0.0
            CALL SGSM (LINE, 0, XJX, LU6, 19, IERR)
            PEAK(J, 6) = XJX(10)
            ATTP = LMT(NINT(CON(J, NP4 - 1)), 1)
            DO 400 I = 1, IAN0
              IF (ATTP .EQ. LMT(IA(I), 1)) GOTO 410
  400       CONTINUE
  410       PEAK(J, 4) = XJX(10) * DA(I) / DA(1)
  420     CONTINUE
        ELSE
          DO 450 I = 1, NAT
            IF (I .LE. IPR(37)) THEN
              DO 430 J = 1, 3
                XJX(J)     = CON(I, J + 2)
                PEAK(I, J) = XJX(J)
  430         CONTINUE
              PEAK(I, 4) = CON(I, NP4)
              PEAK(I, 5) = 0.0
            ELSE
              DO 440 J = 1, 3
                XJX(J)     = XXO(I - IPR(37), J)
                PEAK(I, J) = XJX(J)
  440         CONTINUE
              PEAK(I, 4) = PEAK(I, 6) * CRIT
              PEAK(I, 5) = XXO(I - IPR(37), 4) / PAR(98)
              IF (PEAK(I, 5) .LT. PICKUP) PEAK(I, 4) = 0.0
            ENDIF
            XJX(10) = 0.0
            CALL SGSM (LINE, 0, XJX, 6, 19, IERR)
            PEAK(I, 6) = XJX(10)
  450     CONTINUE
        ENDIF
        CALL GEN097 (NCON, 1, NAT, 0)
        DO 560 I = 1, NAT
          DO 550 J = I, NAT
            DO 540 N = 1, NSYM
              IF (J .NE. I .OR. N .NE. 1) THEN
                DO 460 K = 1, 3
                  XJX(K)     = PEAK(J, K)
                  XJX(K + 3) = 0.0
  460           CONTINUE
                NS = N
                CALL SGSM (LINE, NS, XJX, LU6, 3, IERR)
                K = 1
                GOTO 480
  470           XJX(6 + K) = XJX(6 + K) - 1.0
  480           IF ((PEAK(I, K) - XJX(6 + K)) .LE. V2(K)) GOTO 470
                GOTO 500
  490           IF (ABS(PEAK(I, K)  - XJX(6 + K)) .LE. V2(K)) GOTO 510
  500           XJX(6 + K) = XJX(6 + K) + 1.0
                IF ((PEAK(I, K)  - XJX(6 + K)) .GE. - V2(K)) GOTO 490
                K = K - 1
                IF (K .EQ. 0) GOTO 540
                GOTO 500
  510           K = K + 1
                IF (K .GT. 3) THEN
                  DO 520 L = 1, 3
                    V3(L) = PEAK(I, L) - XJX(6 + L)
  520             CONTINUE
                  CALL GEN002 (2, OR, V3, V4, DIST)
                  IF (DIST .LT. 2.0) THEN
                    IF (I .NE. J .OR. DIST .GT. 0.05) THEN
                      IF (NCON(I) .LT. 40) THEN
                        NCON(I)              = NCON(I) + 1
                        PEAK(I, 6 + NCON(I)) = DIST
                        ICON(I, NCON(I))     = J
                      ENDIF
                      IF (NCON(J) .LT. 40) THEN
                        NCON(J)              = NCON(J) + 1
                        PEAK(J, 6 + NCON(J)) = DIST
                        ICON(J, NCON(J))     = I
                      ENDIF
                    ENDIF
                  ENDIF
                  GOTO 530
                ENDIF
                GOTO 480
  530           K = K - 1
                GOTO 500
              ENDIF
  540       CONTINUE
  550     CONTINUE
  560   CONTINUE
        NRNEW = 0
        NRSH = 0
        RSHN = 0.0
        DO 590 I = 1, NAT
          IF (PEAK(I, 4) / PEAK(I, 6) .GE. CRIT) THEN
            JMAX = NCON(I)
            DO 570 J = 1, JMAX
              BONDIJ = PEAK(I, J + 6)
              IF (BONDIJ .LT. 1.3) THEN
                K = ICON(I, J)
                IF (BONDIJ .LT. 0.9 .OR.
     1            PEAK(I, 4) .GT. PEAK(K, 4) * 3) THEN
                  PEAK(K, 4) = 0.0
                ENDIF
              ENDIF
              IF (PEAK(I, 5) .GT. 0.0 .AND. PEAK(I, 5) .LT. 2.0) THEN
                IF (BONDIJ .GT. 1.6) GOTO 590
              ENDIF
              IF (LOOP .EQ. 1) THEN
                PHMIN = 2.0
              ELSE
                PHMIN = 1.0
              ENDIF
              IF (BONDIJ .LT. 1.8 .AND. PEAK(I, 5) .GT. 0.0
     1           .AND. PEAK(I, 5) .LT. PHMIN) GOTO 590
  570       CONTINUE
            IF (RSHN .LT. EXPMX) THEN
              NRSH  = NRSH + 1
              RSHN  = RSHN + PEAK(I, 6)
              NCONM = MIN (NCON(I), 6)
              WRITE (LU7, 99978) NRSH, I, (PEAK(I, J), J = 1, 6 + NCONM)
              WRITE (LU7, 99977) (ICON(I, J), J = 1, NCONM)
              DO 580 J = 1, 3
                CON(NRSH, J + 2) = PEAK(I, J)
  580         CONTINUE
              CON(NRSH, NP4 - 1) = IA(1)
              CON(NRSH, NP4)     = PEAK(I, 4)
              IF (PEAK(I, 5) .GT. 0.0) NRNEW = NRNEW + 1
              DATC(NRSH) = 1000.0 - PEAK(I, 4) / PEAK(I, 6)
              IATC(NRSH) = I
            ENDIF
          ENDIF
  590   CONTINUE
        IF (NRSH .EQ. 0) WRITE( LU6, 99969)
        IPR(37) = NRSH
        IF (NRNEW .EQ. 0 .AND. LOOP .GT. 2) GOTO 600
        IF (LOOP .LT. IABS(IPR(467))) THEN
          CALL PLA151 (LOOP)
          IF (IPR(2) .EQ. 0) CALL PLA152 (-2, NPK)
          GOTO 380
        ENDIF
  600   CALL GEN108 (LU2, 0)
        HRT = 0.57 * HORS
        VRT = VERT - 3.4
        WRITE (LU2, 99990) JID(1:6), PAR(17), (PAR(100  + I), I = 1, 12)
        WRITE (LU2, 99989) IPR(242)
        DO 610 I = 2, IPR(255)
          NUMS = I
          CALL SGSM (LINE, NUMS, XJX, 0, 17, IERR)
          WRITE (LU2, 99988) LINE(1:60)
  610   CONTINUE
        WRITE (LU2, 99987) (LMT(I, 1), I = 1, IAN0)
        WRITE (LU2, 99986) (NINT(CONT(I, 3)), I = 1, IAN0)
        WRITE (LU2, 99995) PAR(74)
        FACT  = 0.5
        XPEAK = 999.0
        N     = 0
        DELTA = 1.0
        CALL GEN097 (MCONT, 1, NP10, 0)
        CALL GEN013 (DATC, IATC, 1, NRSH)
        DO 615 I = 1, NRSH
          DATC(I) = (1000.0 - DATC(I)) * DA(1)
          IF (XPEAK - DATC(I) .GT. DELTA) THEN
            IF (N .LT. IRMIN) THEN
              N = N + 1
              IF (N .LT. IRMIN) THEN
                DELT = DA(N) - DA(N + 1)
              ELSE
                DELT = 999.0
              ENDIF
            ENDIF
          ENDIF
          XPEAK    = DATC(I)
          DELTA    = DELT * FACT * XPEAK / DA(N)
          MCONT(N) = MCONT(N) + 1
  615   CONTINUE
        N    = 0
        NEL0 = 1
        L    = 0
        NATR = 0
        DO 620 I = 1, NRSH
          K    = IATC(I)
          NATR = NATR + 1
          N    = N + 1
          L    = L + NINT(NSYM * PEAK(K, 6))
          IF (NEL0 .LT. IAN0 .AND. NINT(DA(NEL0 + 1)) .NE. 1) THEN
            IF ((KNOWN .EQ. 0 .AND. N .GT. MCONT(NEL0)) .OR.
     1        (KNOWN .EQ. 1 .AND. L .GT. NINT(CONT(IA(NEL0), 3)))) THEN
              L    = NINT(NSYM * PEAK(K, 6))
              NEL0 = NEL0 + 1
              N    = 1
            ENDIF
          ENDIF
          LABI(1:4) = LMT(IA(NEL0), 1)(1:2)//'  '
          IF (LABI(1:1) .NE. ' ') THEN
            L0 = 1
            NO = 50 + N
          ELSE
            LABI(1:4) = LMT(IA(NEL0), 1)(2:2)//'   '
            L0 = 0
            NO = 500 + N
          ENDIF
          IF (NO .LT. 100) THEN
            WRITE (LABI(2 + L0 : 3 + L0), 99971) NO
          ELSE
            WRITE (LABI(2:4), 99972) NO
          ENDIF
          WRITE (LU2, 99993) LABI, IA(NEL0), (PEAK(K, J), J = 1, 3),
     1                   10 + PEAK(K, 6), RP(2)
          IF (IGBL(25) * IGBL(32) .EQ. 1 .AND. IGBL(50) .EQ. 0) THEN
            IF (I .EQ. 1) THEN
              WRITE (IDM, 99975)
              VRT = VERT - 0.5
              CALL GGIP20 (0.0, IDM, 38, 0.3, 5 + IGBL(68), 2, HRT, VRT)
            ENDIF
            IF (I .LE. 42) THEN
              WRITE (IDM, 99976) I, LABI, (PEAK(K, J), J = 1, 3),
     1          DATC(I)
              VRT = VRT - 0.45
              CALL GGIP20 (0.0, IDM, 38, 0.3, 1, 2, HRT, VRT)
            ENDIF
          ENDIF
  620   CONTINUE
        WRITE (LU2, 99996) (PAR(I), I = 231, 239)
        WRITE (IDM, 99992) PAR(281), PAR(282), NATR
        WRITE (LU6, 99970) IDM
        IF (IGBL(25) * IGBL(32) .EQ. 1 .AND. IGBL(50) .EQ. 0)
     1      CALL GGIP20 (0.0, IDM, 56, 0.3, 5 + IGBL(68), 2, 0.2, 0.2)
      ELSE
        IF (IABS(IPR(525)) .EQ. 1) THEN
          NPK  = 30
          MDIP = 0
          CALL PLA152 (0, NPK)
          IF (XXO(1, 4) .GT. 0.0) THEN
            PMAX = 999.0 / XXO(1, 4)
          ELSE
            PMAX = 1.0
          ENDIF
          DO 800 I = 1, NPK
            DO 810 J = 1, 3
              XXO(I, J) = MOD (XXO(I, J), 1.0)
  810       CONTINUE
            XXO(I, 4) = XXO(I, 4) * PMAX
  800     CONTINUE
          NPKM = MIN (35, NPK)
          NPRV = 50
          DO 1000 I = 1, NPKM
            NSTAR = NINT(XXO(I, 4) * 50 / 999.0)
            STAR  = ' '
            IF (NSTAR .GT. 0) THEN
              DO 900 J = 1, NSTAR
                STAR(J:J) = '*'
  900         CONTINUE
            ENDIF
            NDIF = NPRV - NSTAR
            NPRV = NSTAR
            IF (NDIF .GT. 0) THEN
              IF (I .GT. 2) MDIP = MAX (MDIP, NDIF)
              DO 950 J = 1, NDIF
                STAR(51-J:51-J) = '<'
  950         CONTINUE
            ENDIF
            WRITE (LINE, 99998) I, (XXO(I, J), J = 1, 4), STAR
            WRITE (LU7, 99968) LINE
            IF (IGBL(25) * IGBL(32) .EQ. 1 .AND. IGBL(50) .EQ. 0) THEN
              VRT = VRT - 0.5
              CALL GGIP20 (0.0, LINE, 80, 0.3, 1, 2, 2.2, VRT)
            ENDIF
 1000     CONTINUE
          WRITE (LU7, 99974) MDIP
          IF (MDIP .LT. IGBL(89)) THEN
            LINE = 'EQUAL ATOM TYPE PATTERSON'
          ELSE
            LINE = 'HEAVY ATOM TYPE PATTERSON'
          ENDIF
          CALL GGIP20 (0.0, LINE, 80, 0.4, 5 + IGBL(68), 2, 12.0, 2.0)
        ENDIF
      ENDIF
      IF (IGBL(25) * IGBL(32) .EQ. 1 .AND. IGBL(50) .EQ. 0) THEN
        IF (MODE .NE. 0 .OR. IPR(525) .NE. 0) THEN
 1010     IF (IPR(467) .GT. 0) THEN
            WRITE (SBCD, 99997) CHAR(0)
          ELSE
            WRITE (SBCD, 99973) CHAR(0)
          ENDIF
          CALL PLA013 (0, 1)
          IF (IGGT(1:4) .EQ. 'PLOT') GOTO 1010
          OPEN (LU61, FILE = 'NEXT', STATUS = 'UNKNOWN')
          WRITE (LU61, 99968) IGGT
          CLOSE (LU61)
        ENDIF
      ENDIF
 1020 IF (MODE .EQ. 0 .AND. IPR(2) .EQ. 0) IPR(2) = -13
      RETURN
99999 FORMAT (':: Omit = ', F5.1, ' => ', I6,
     1' Reflections Suppressed out of', I6, /)
99998 FORMAT (I3, 3F6.3, F6.0, 2X, A)
99997 FORMAT ('[END]', A)
99996 FORMAT ('HKLF 4 1', 9F8.4, /, 'END')
99995 FORMAT ('FVAR', F10.3)
99994 FORMAT (/, I7,' Reflections Read, of Which', I5, ' Rejected', /)
99993 FORMAT (A, I4, 5F10.4)
99992 FORMAT ('Sin(Th)/Lam =', F5.2, '-', F4.2,
     1        ' - Number of Remaining Atoms:', I3)
99991 FORMAT ('IHMIN, IHMAX =', 2I5, /,
     1        'IKMIN, IKMAX =', 2I5, /,
     2        'ILMIN, ILMAX =', 2I5, /,
     3        'THMIN, THMAX =', 2F5.1)
99990 FORMAT ('TITL ', A, ' - EXOR', /,
     1        'CELL ', F7.5, 6F10.4, /,
     2        'ZERR 1', 6X, 6F10.4)
99989 FORMAT ('LATT ', I3)
99988 FORMAT ('SYMM ', A)
99987 FORMAT ('SFAC ', 16(1X, A))
99986 FORMAT ('UNIT ', 2I5, 14I4)
99985 FORMAT (I5, ' Unique Reflections R =', F8.4)
99984 FORMAT ('Overall Scale', F12.5, 10X, 'Estimated U =', F6.3)
99983 FORMAT (/, 'Excluded Reflections')
99982 FORMAT (3I4, 2I8)
99981 FORMAT (1X)
99980 FORMAT (3I4, 2F12.2, F10.2)
99979 FORMAT ('AVER ABS(E**2-1) =', F5.2)
99978 FORMAT (2I4, 3F7.3, F6.3, F7.2, F6.3, 6F5.2, 4(/, 44X, 6F5.2))
99977 FORMAT (48X, 7I5)
99976 FORMAT (I2, 1X, A, 3F7.3, F6.1)
99975 FORMAT ('Nr Label     x      y      z    PP')
99974 FORMAT ('PATT DIP', I3)
99973 FORMAT ('[REF-XYZU]', A)
99972 FORMAT (I3)
99971 FORMAT (I2)
99970 FORMAT (/, A, /)
99969 FORMAT ('No Atoms')
99968 FORMAT (A)
99967 FORMAT (/, 'Wavelength =', F8.5, /)
      END
      SUBROUTINE PLA151 (LOOP)
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118,
     1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NPVD=40000000,
     2 NP22=256,NP23=18000,NP25=99,NP29=63,NP38=125,NP39=30,NP41=200,
     3 NP47=9,MP2=1700,MP5=MP2*5,MP6=2000,MP3=1000,
     4 MP1=NPVD+2*NP23-MP2-87*MP3-3*MP5-2*MP6-1700)
      COMMON // SFC(1616), F(84), PEAK(MP3, 46), ICON(MP3, 40),
     1 NCON(MP3), CT(MP5), D1(MP5), D2(MP5), IN(MP2), A(MP6), E(MP6),
     3 B(MP1)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9),
     1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10),
     2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10),
     3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770)
      COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0
      COMMON /COM3/ NGRID, STHM, ITOP
      DIMENSION ENB(16)
      N = 0
      NSYMH = IPR(255)
      CENT  = 2 - IPR(257)
      LATTS = IPR(256) * IPR(257)
      NAT   = IPR(37)
      NV    = IPR(482)
      TPI   = GL(6)
      STHMN = GL(8) * PAR(281)**2
      STHM  = GL(8) * PAR(282)**2
      VMAX  = 0.0
      VMEAN = 0.0
      IF (LOOP .GT. 1) THEN
        CT(1) = MIN (0.08, MAX (0.03, RP(2)))
      ELSE
        CT(1) = 0.05
      ENDIF
      L = 1
      DO 20 I = 1, NAT
        IN(I) = NINT(CON(I, NP4 - 1))
        DO 10 J = 1, 3
          CT(L + J) = CON(I, J + 2)
   10   CONTINUE
        CT(L + 4) = CON(I, NP4)
        CT(L + 5) = CT(1)
        L         = L + 5
   20 CONTINUE
      WRITE (IDM, 99999)
      WRITE (LU6, 99997) IDM
      IF (IGBL(25) * IGBL(32) .EQ. 1 .AND. IGBL(50) .EQ. 0) THEN
        VRT = VRT - 0.5
        CALL GGIP20 (0.0, IDM, 80, 0.3, 5 + IGBL(68), 2, 0.2, VRT)
      ENDIF
      NC    = 0
      NISO  = 0
   30 NC    = NC + 1
      IF (NC .GT. 1) NISO = 1
      R  = 0.0
      NN = NISO + NAT
      K  = 1
      DO 40 I = 1, NAT
        IF (NV .EQ. 0) THEN
          CON(I, NP4) = CT(K + 4)
          RP(2)       = CT(1)
        ENDIF
        K = K + 5
        CT(K) = CT(1)
   40 CONTINUE
      IF (NV .LT. 0) THEN
        GOTO 170
      ELSE IF (NV .GT. 0) THEN
        I = ((NN * (NN + 3)) / 2) + 10
        CALL GEN074 (B, 0.0, 1, I)
      ENDIF
      NR = 0
      CALL GEN074 (A,  0.0, 1, MP6)
      CALL GEN074 (E,  0.0, 1, MP6)
      CALL GEN074 (D1, 0.0, 1, MP5)
      CALL GEN074 (D2, 0.0, 1, MP5)
      CR1 = 0.0
      CR2 = 0.0
      CR3 = 0.0
      CR4 = 0.0
      XVL = 100.0 * (PAR(17)**2) / GL(8)
   50 READ (LU21) F
      DO 140 I = 1, 79, 6
        IF (NINT(F(I)) .EQ. 0) GOTO 150
        IF (F(I + 3) .GT. STHM) GOTO 140
        NR = NR + 1
        V  = XVL * F(I + 3)
        U  = MOD (V, 2.0)
        M  = INT (V - U) - 100
        U  = 0.5 * U
        DO 60 K = 1, IAN
          M = M + 101
          ENB(K) = SFC(M) + U * (SFC(M + 2)
     1           - SFC(M) + SFC(M + 1) - U * SFC(M + 1))
   60   CONTINUE
        CALL GEN046 (F(I), XJX(1), XJX(2), XJX(3))
        U = 0.0
        V = 0.0
        J = 1
        DO 70 K = 1, NAT
          J    = J + 5
          E(K) = EXP( - CT(J) * F(I + 3)) * ENB(IN(K)) * LATTS
   70   CONTINUE
        DO 90 NSM = 1, NSYMH
          XJX(4) = 0.0
          CALL SGSM (LINE, NSM, XJX, LU6, 5, IERR)
          XJX10 = XJX(10) / 360.0
          K  = 1
          N  = 0
          DO 80 NI = 1, NAT
            W  = CT(K + 4)
            R  = E(NI) * W
            S  = TPI * (CT(K + 1) * XJX(7) + CT(K + 2) * XJX(8)
     1         + CT(K + 3) * XJX(9) + XJX10)
            P  = R * COS(S)
            R  = R * SIN(S)
            U  = U + P
            V  = V + R * CENT
            K  = K + 5
            IF (NV .GT. 0) THEN
              IF (F(I + 3) .GT. STHMN) THEN
                E5    = 1.0 / MAX (W, 0.0001)
                N     = N + 1
                D1(N) = D1(N) + E5 * P
                D2(N) = D2(N) + E5 * R
                N     = N + 1
                D1(N) = D1(N) - F(I + 3) * P
                D2(N) = D2(N) - F(I + 3) * R
              ENDIF
            ENDIF
   80     CONTINUE
   90   CONTINUE
        F(I + 4) = U
        F(I + 5) = V
        FCK    = U ** 2 + V ** 2
        FC     = SQRT(FCK)
        FO     = F(I + 1)
        FOK    = FO ** 2
        DELTA  = FO - FC
        DELTA2 = FOK - FCK
        W      = 1.0 / (F(I + 2) * (4.0 * FOK) + (0.01 * FOK) ** 2)
        CR3    = CR3 + W * DELTA2**2
        CR4    = CR4 + W * FOK**2
        W      = SQRT(W)
        CR1    = CR1 + ABS(DELTA)
        CR2    = CR2 + FO
        IF (NV .GT. 0) THEN
          IF (F(I + 3) .GT. STHMN) THEN
          Y = DELTA2
          Q = W
          CALL GEN074 (E, 0.0, 1, NN)
          U = U * Q
          V = V * Q
          DO 110 J = 2, N, 2
            K = J / 2 + NISO
            E(K) = E(K) + 2 * (U * D1(J - 1) + V * D2(J - 1))
            IF (NISO .EQ. 1) THEN
              E(1) = E(1) + 2 * (U * D1(J) + V * D2(J))
            ENDIF
            D1(J - 1) = 0.0
            D2(J - 1) = 0.0
            D1(J)     = 0.0
            D2(J)     = 0.0
  110     CONTINUE
          W = W * Y
          M = NN + 1
          DO 130 N = 1, NN
            Y = E(N)
            L = M
            M = L + NN - N + 1
            IF (Y .NE. 0.0) THEN
              A(N) = W * Y + A(N)
              B(N) = B(N) + Y ** 2
              DO 120 K = N, NN
                B(L) = Y * E(K) + B(L)
                L    = L + 1
  120         CONTINUE
            ENDIF
  130     CONTINUE
        ENDIF
        ENDIF
  140 CONTINUE
      WRITE (LU4) F
      GOTO 50
  150 R = CR3 / FLOAT(NR - NN)
      WRITE (LU4) F
      CALL GEN108 (LU4, 1)
      CALL GEN108 (LU21, 0)
      U   = CR1 / CR2
      W   = SQRT(CR3 / CR4)
      RNC = LOOP + FLOAT (NC) / 10.0
      WRITE (IDM, 99998) RNC, U, W, NR, NN, VMEAN, VMAX, CT(1)
      WRITE (LU6, '(A)') IDM
      IF (IGBL(25) * IGBL(32) .EQ. 1 .AND. IGBL(50) .EQ. 0) THEN
        VRT = VRT - 0.5
        CALL GGIP20 (0.0, IDM, 80, 0.3, 1, 2, 0.2, VRT)
        CALL GGIP (0.0, 0.0, 0.0, 6)
      ENDIF
      IF (NV .EQ. 0) WRITE (LU7, 99996) U, W, NR, NN
      NV = NV - 1
      IF (NV .LT. 0) GOTO 30
      CALL GEN012 (B, A, NN, 0.0, 0.0, R)
      IF (NISO .EQ. 1) CT(1) = MAX (CT(1) + B(1), 0.02)
      VMAX  = 0.0
      VMEAN = 0.0
      K     = 0
      DO 160 N = 1 + NISO, NN
        K     = K + 5
        WRITE(6,'(I5,3F10.4)') N,CT(K),B(N),CT(K)+B(N)
        CT(K) = CT(K) + B(N)
        V     = B(N)  / A(N)
        VMEAN = VMEAN + ABS(V)
        VMAX  = MAX (VMAX, ABS(V))
  160 CONTINUE
      VMEAN = VMEAN / NN
      IF (VMEAN .LT. PAR(283)) NV = 0
      GOTO 30
  170 RETURN
99999 FORMAT ('Cyc      R    wR2  Nref Npar',
     1        1X, 'Mean(s/u) Max(s/u) U(iso)')
99998 FORMAT (F3.1, 2F7.3, I6, I5, F8.4, F9.4, F7.2)
99997 FORMAT (/, A, /)
99996 FORMAT (':: RVAL=', 2F10.3, 2I10)
      END
      SUBROUTINE PLA152 (MODE, NPK)
      PARAMETER (NP12=600,NP13=500,NP17=99,NPVD=40000000,NP23=18000,
     1 NP38=125,NP39=30,MP3=1000,MP1=NPVD+2*NP23-1700-87*MP3)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /COM3/ NGRID, STHM, ITOP
      COMMON // SFC(1616), F(84), PEAK(MP3, 46), ICON(MP3, 40),
     1 NCON(MP3), VOID(MP1)
      DO 20 I = 1, 3
        DO 10 J = 4, 8
          IPR(I + 394) = 2**J
          IF (PAR(I + 100) * 3.0 .LT. IPR(I + 394)) GOTO 20
   10   CONTINUE
   20 CONTINUE
      M1    = IPR(395)
      M2    = IPR(396)
      M3    = IPR(397)
      NGRID = M1 * M2 * M3
      ITOP  = NGRID * 2
      ITOP2 = ITOP + 3 * (M1 + 2) * (M2 + 2)
      IF (ITOP2 .GT. MP1) THEN
        IPR(2) = 49
      ELSE
        CALL PLA153 (MODE, VOID(1), VOID(ITOP + 1), NPK)
      ENDIF
      RETURN
      END
      SUBROUTINE PLA153 (MODE, FFT, R3D, NPK)
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16,
     1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP25=99,NP29=63,
     2 NP38=125,NP39=30,NP41=200,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /COM3/ NGRID, STHM, ITOP
      DIMENSION F(84), FFT(*), R3D(*)
      CHARACTER LINE*80
      ACAL  = 0.0
      BCAL  = 0.0
      FCAL  = 0.0
      PCAL  = 0.0
      NSYMH = IPR(255)
      IF (MODE .EQ. 0) THEN
        LU  = LU21
        ISW = -5
      ELSE
        LU  = LU4
        ISW = 5
      ENDIF
      CALL GEN108 (LU, 0)
      M1    = IPR(395)
      M2    = IPR(396)
      M3    = IPR(397)
      FS000 = 0.0
      CALL GEN074 (FFT, 0.0, 1, ITOP)
      FFT(1) = FS000
   20 READ (LU) F
      DO 50 I = 1, 79, 6
        IF (NINT(F(I)) .EQ. 0) GOTO 60
        CALL GEN046 (F(I), C2, C3, C4)
        IF (MODE .EQ. 0) THEN
          ACAL = F(I + 1) ** 2
          BCAL = 0.0
        ELSE
          IF (F(I + 3) .GT. STHM) GOTO 50
          FC = SQRT(F(I + 4)**2 + F(I + 5)**2) + 1.E-8
          IF (MODE .LT. 0) THEN
            FRAC = F(I + 1) / FC - 1.0
          ELSE
            FRAC = F(I + 1) / FC
          ENDIF
          AC   = F(I + 4) * FRAC
          BC   = F(I + 5) * FRAC
          FCAL = FRAC * FC
          PCAL = ATAN2(BC, AC) * GL(5)
        ENDIF
        DO 40 N = 1, NSYMH
          XJX(1) = C2
          XJX(2) = C3
          XJX(3) = C4
          XJX(4) = PCAL
          CALL SGSM (LINE, N, XJX, LU6, ISW, IERR)
          IHT  = NINT(XJX(7))
          IKT  = NINT(XJX(8))
          ILT  = NINT(XJX(9))
          IF (MODE .NE. 0) THEN
            PHAS = XJX(10) / GL(5)
            ACAL = FCAL * COS(PHAS)
            BCAL = FCAL * SIN(PHAS)
          ENDIF
          ISN = 1
          DO 30 J = 1, 2
            IF (J .EQ. 2) ISN = -1
            IH = ISN * IHT
            IK = ISN * IKT
            IL = ISN * ILT
            IF (IH .LT. 0) IH = IH + M1
            IF (IK .LT. 0) IK = IK + M2
            IF (IL .LT. 0) IL = IL + M3
            LOC = 2 * ((IL * M2 + IK) * M1 + IH + 1)
            FFT(LOC -1) = ACAL
            FFT(LOC)    = BCAL * ISN
   30     CONTINUE
   40   CONTINUE
   50 CONTINUE
      GOTO 20
   60 CALL GEN028 (FFT, IPR(395), 3, -1)
      RHOMIN = PAR(268)
      CALL PLA134 (FFT, R3D, 0, RHOMIN, MODE, NPK, 1)
      RETURN
      END
      SUBROUTINE PLA155 (TNP)
      PARAMETER (NP12=600,NP13=500,NP17=99,NPVD=40000000,NP23=18000,
     1 NPP=NPVD+2*NP23,NP38=125,NP39=30)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /SHX/ F(126), G(126), LR, LG, LH, LI, LP, LF, LA, LB,
     1 LY, LL, LQ, LE, LV, LX, LD, LZ, LJ, HKLF(11)
      COMMON // A(NPP)
      COMMON /WORDD/ IH(20), IR
      CHARACTER IH*1, IR*80, KEY*4
      DO 10 I = 1, 10
        IH(I) = CHAR(47 + I)
   10 CONTINUE
      IH(11) = '.'
      IH(12) = '-'
      IH(13) = '+'
      IH(14) = 'X'
      IH(15) = 'Y'
      IH(16) = 'Z'
      IH(17) = ','
      IH(18) = '='
      IH(19) = '/'
      IH(20) = CHAR(32)
      LR = 1
      OPEN (LR, FILE = 'shelxs.ins', STATUS = 'OLD',     ERR = 320)
      LH = 3
      OPEN (LH, FILE = 'shelxs.hkl', STATUS = 'OLD',     ERR = 320)
      LI = 10
      OPEN (LI, FILE = 'shelxs.lis', STATUS = 'UNKNOWN', ERR = 320)
      LP = 60
      OPEN (LP, FILE = 'shelxs.res', STATUS = 'UNKNOWN', ERR = 320)
      LA = 2
      OPEN (LA, STATUS = 'SCRATCH', FORM = 'UNFORMATTED', ERR = 320)
      LB = 4
      OPEN (LB, STATUS = 'SCRATCH', FORM = 'UNFORMATTED', ERR = 320)
      LF = 8
      OPEN (LF, STATUS = 'SCRATCH', FORM = 'UNFORMATTED', ERR = 320)
      LG = 9
      OPEN (LG, STATUS = 'SCRATCH', FORM = 'UNFORMATTED', ERR = 320)
      WRITE (LI, 99998)
      CALL GEN074 (A, 0.0, 1, 76)
      IER   = 0
      LX    = 25
      LL    = 1
      LZ    = 0
      LQ    = 0
      LY    = 65
      LJ    = 0
      NB    = 4
      JR    = 4
      HS    = 0.0
      X     = 0.0
      A(14) = 1.0
      A(16) = 1.0
      A(19) = 1.0
      A(26) = 1.2
      A(27) = 5.0
      A(28) = 0.005
      A(29) = 0.7
      A(32) = 1.5
      CALL GEN074 (A, -2.0, 33, 35)
      CALL GEN074 (A,  2.0, 36, 38)
      A(39) = TNP
      A(43) = 4.0
      A(52) = 2.0
      A(53) = 1.0
      A(56) = 28.0
      A(58) = 0.5
      A(59) = 1.5
      A(64) = 1.0
      A(65) = 1.0
      A(69) = 1.0
      A(73) = 1.0
      CALL GEN074 (F, 1.0, 121, 123)
      CALL GEN074 (F, 0.0, 124, 126)
      GOTO 50
   40 WRITE (LP, 99996) IR(1:JR)
   50 READ (LR, 99996) IR
      KEY = IR(1:4)
      CALL GEN039 (1, IR, 4, 80, NB, JR)
      WRITE (LI, 99996) IR(1:JR)
      IF (KEY .EQ. 'TITL') GOTO 40
      CALL GEN074 (G, 0.0, 1, 126)
      NA = 0
      JD = 0
      NJ = LY + 7
      L  = LY + 21
      N  = 4
      IF (KEY .EQ. 'SYMM') THEN
        J = LY + 10
        DO 60 I = J, L
          A(I + 2) = 0.0
   60   CONTINUE
      ENDIF
   70 W  = 1.0
   80 V  = 0.0
      NB = 0
      Y  = 1.0
      U  = 10.0
      Z  = 1.0
  100 N  = N + 1
      K  = 10
      IF (N .LE. JR) THEN
        X  = 0.0
        DO 110 KK = 1, 19
          IF (IR(N:N) .EQ. IH(KK)) THEN
            IF (KK .LT. 11) THEN
              Z  = Y * Z
              V  = U * ABS(V) + Z * X
              NB = 1
              IF (V .NE. 0.0) THEN
                V = SIGN(V, W)
                W = V
              ENDIF
              GOTO 100
            ENDIF
            K = KK - 9
            GOTO 130
          ENDIF
          X = X + 1.0
  110   CONTINUE
        K = 1
      ENDIF
  130 IF (KEY .NE. 'SYMM') THEN
        IF (K  .EQ. 2) GOTO 160
        IF (NB .EQ. 0) THEN
          IF (K .EQ. 1) K = 6
          IF (IABS(K - 6) .GT. 1)  GOTO 150
          IF (IR(N:N) .EQ. IH(20)) GOTO 150
          JD = JD + 1
          DO 140 K = 1, 4
            IF (N .GT. JR) GOTO 220
            IF (IR(N:N) .EQ. IH(17)) GOTO 70
            IF (IR(N:N) .EQ. IH(18)) GOTO 180
            IF (IR(N:N) .EQ. IH(19)) GOTO 220
            IF (IR(N:N) .EQ. IH(20)) GOTO 70
            N = N + 1
  140     CONTINUE
          GOTO 70
        ENDIF
        NA    = NA + 1
        G(NA) = V
  150   IF (K .LT. 9) THEN
          GOTO 210
        ELSE IF (K .EQ. 9) THEN
          GOTO 180
        ELSE
          GOTO 220
        ENDIF
      ENDIF
      IF (K .EQ. 1) THEN
        GOTO 100
      ELSE IF (K .EQ. 2) THEN
        GOTO 160
      ELSE IF (K .EQ. 3 .OR. K .EQ. 4) THEN
        A(L) = AINT(24.5 * V) / 24.0
        GOTO 210
      ELSE IF (K .GE. 5 .AND. K .LE. 7) THEN
        K = K + NJ
        A(K) = W
        GOTO 70
      ELSE IF (K .EQ. 8 .OR. K .EQ. 10) THEN
        A(L) = A(L) + AINT(24.5 * V) / 24.0
        L = L + 1
        NJ = NJ + 3
        IF (NJ + 8 .LT. L) GOTO 70
        LY = LY + 12
        GOTO 40
      ELSE IF (K .EQ. 9) THEN
        GOTO 190
      ENDIF
  160 U = 1.0
      Y = 0.1
      GOTO 100
  180 WRITE (LP, 99996) IR(1: JR)
  190 READ (LR, 99996) IR
      NB = 4
      JR = 4
      CALL GEN039 (1, IR, 4, 80, NB, JR)
      WRITE (LI, 99996) IR(1: JR)
      N = 4
      GOTO 70
  210 IF (K .NE. 3) GOTO 70
      W = -1.0
      GOTO 80
  220 IF (KEY .EQ. 'CELL') THEN
        DO 230 J = 1, 7
          A(J) = G(J)
  230   CONTINUE
        U = 2.0 * A(2) * A(3) * A(4)
        DO 240 J = 2, 4
          X        = A(J + 3) / GL(5)
          G(J)     = COS(X)
          G(J + 3) = SIN(X)
          A(J + 9) = U * G(J) / A(J)
          A(J + 6) = A(J) * A(J)
  240   CONTINUE
        X     = (G(2) * G(3) - G(4)) / (G(5) * G(6))
        Y     = SQRT(ABS(1.0 - X * X))
        A(46) = 1.0 / (A(2) * G(6) * Y)
        A(48) = 1.0 / (A(3) * G(5))
        A(47) = X * A(48) / Y
        A(49) = (-G(6) * G(2) * X - G(5) * G(3)) /
     1          (A(4) * G(5) * G(6) * Y)
        A(51) = 1.0 / A(4)
        A(50) = -G(2) * A(51) / G(5)
        A(60) = 1.0 / (A(46) * A(48) * A(51))
        GOTO 40
      ENDIF
      IF (KEY .EQ. 'LATT') THEN
        IF (G(1) .LT. 0.0) A(23) = 1.0
        LL = NINT(ABS(G(1)))
        GOTO 40
      ENDIF
      IF (KEY .EQ. 'SFAC')  THEN
        IF (LL .LE. 65) THEN
          N = 3 * LL
          L = INT(4.1 - 2.0 * A(23))
          CALL GEN074 (F, 0.5, 1, 12)
          CALL GEN074 (F, 0.0, 1, 3)
          IF (N .EQ. 12) THEN
            F(4)  = 0.0
            F(8)  = 0.0
            F(12) = 0.0
          ELSE IF (N .EQ. 9) THEN
            F(4) = 0.6666667
            F(5) = 0.3333333
            F(6) = 0.3333333
            F(7) = 0.3333333
            F(8) = 0.6666667
            F(9) = 0.6666667
          ELSE IF (N .GT. 12) THEN
            F(LL - 1) = 0.0
            N         = 4
          ENDIF
          LL = LY + 8
          DO 260 K = 2, L, 2
            DO 250 J = 1, N, 3
              LL = LL + 4
              A(LL)     = 3.0 - FLOAT(K)
              A(LL + 1) = F(J)     + 99.5
              A(LL + 2) = F(J + 1) + 99.5
              A(LL + 3) = F(J + 2) + 99.5
  250       CONTINUE
  260     CONTINUE
          LQ   = LL - 1
          F(1) = 1.1
        ENDIF
        LQ        = LQ + 5
        A(LQ)     = AINT (0.5 + G(1) + G(3) + G(5) + G(7) + G(9))
        A(LQ + 1) = G(13)
        LZ        = LZ + 1
        A(LQ + 3) = G(12)
        A(LQ + 4) = G(14)
        GOTO 40
      ENDIF
      IF (KEY .EQ. 'UNIT') THEN
        J  = LL + 4
        LE = LQ + 3
        LX = LQ + 5
        U  = 0.0
        V  = 0.0
        P  = 0.0
        Q  = 0.0
        R  = 0.0
        HS = 0.0
        Z  = 0.0
        Y  = 0.0
        DO 270 I = 1, NA
          IF (A(J) .GT. 1.5) Z = Z + G(I)
          W = A(J) * G(I)
          P = P + W
          Q = Q + A(J + 4) * G(I)
          A(J + 4) = G(I)
          R = R + A(J + 3) * G(I)
          HS = MAX (HS, A(J) * A(J))
          U = U + W * A(J)
          V = V + W * A(J) * A(J)
          Y = Y + W * SQRT(A(J))
          J = J + 5
  270   CONTINUE
        T  = Q * 1.66052 / A(60)
        Z  = A(60) / Z
        X  = FLOAT(LL - LY - 8)
        WRITE (LI, 99995) A(60), Z, P, Q, T
        A(24) = SQRT(0.25 * X / U)
        T     = (2.0 - A(23)) / X
        A(45) = V / (U * SQRT(T * U))
        Y     = Y**2 / (T * P**3)
        X     = 15.0 * (250.0 + A(60) / X) / FLOAT(LY - 53)
        FF    = AINT (MIN (X, 150.0 + 0.5 * X, 300.0 + 0.25 * X))
        A(44) = - MIN (20.0 + ABS(FF) * 0.5, 160.1 + 40.0 * A(23))
        A(40) = FF
        L     = 0
        M     = 0
        N     = 0
        T     = 30.0
        DO 280 K = 65, LY, 12
          IF (A(K)     .LT. - 0.5) L = 1
          IF (A(K + 4) .LT. - 0.5) M = 1
          IF (A(K + 8) .LT. - 0.5) N = 1
          IF (ABS(A(K + 9)) + ABS(A(K + 10)) + ABS(A(K + 11)) .GT. 0.1)
     1      T = 20.0
  280   CONTINUE
        A(42) = MAX (-1.1 + 0.3 * A(23),
     1          MIN (-0.2, -T * Y * (2.0 - A(23))))
        IF (T .LE. 25.0) THEN
          IF (A(23) .LT. 0.5) L = 3
          IF (L + M + N .GT. 2) A(44) = ABS(A(44))
        ENDIF
        GOTO 40
      ENDIF
      IF (KEY .EQ. 'OMIT') THEN
        IF (NA .EQ. 3) THEN
          IF (F(1) .GT. 119.5) GOTO 330
          F(1) = F(1) + 1.0
          I    = INT(F(1))
          F(I) = G(1) + 200.0 * (G(2) + 200.0 * G(3))
        ELSE
          A(52) = 0.5 * ABS(G(1))
          IF (NA .EQ. 2) A(53) = (SIN(8.726646E-3 * G(2)))**2
        ENDIF
        GOTO 40
      ENDIF
      IF (KEY .NE. 'HKLF')  GOTO 50
      A(41) = -4.0 -3.0 * A(23)
      IF (ABS(A(41)) .LT. 0.99) GOTO 330
      A(41) = SIGN(AINT(ABS(A(41))) + 0.1, A(41))
      A(60) = ABS(A(60))
      CLOSE (UNIT = LR, STATUS = 'KEEP')
      IF (G(2) .EQ. 0.0) THEN
        G(2)  = 1.0
        G(3)  = 1.0
        G(7)  = 1.0
        G(11) = 1.0
      ENDIF
      DO  290 I = 1, 11
        HKLF(I) = G(I)
  290 CONTINUE
      A(54) = 7.0
      IF (HS .GT. 290.0) A(54) = 4.0
      U = 195.0
      IF (A(20) .LT. -8.E9) U = 45.0
      U     = 0.28 * (2.0 - A(23)) * A(60) / FLOAT(LL - LY - 8)
      U     = U * 12.0 / (FLOAT(LY - 53) * (2.0 - A(23)))
      A(57) = 5.0 + AINT(U)
      LV    = LE - 6
      LX    = LX - 8
      WRITE (LG) F
      CALL GEN108 (LG, 0)
      U = 2.0 * A(2) * A(3) * A(4)
      DO 300 J = 2, 4
        F(J) = U * COS(1.74533E-2 * A(J + 3)) / A(J)
        F(J + 3) = F(J) * F(J)
  300 CONTINUE
      V = U * U
      U = 0.5 * A(1) * A(1) / (V - A(8) * F(5) - A(9) * F(6)
     1                   - A(10) * F(7)+ F(2) * F(3) * F(4))
      DO 310 J = 8, 10
        A(J + 6) = 0.5 * U * ((V / A(J)) - F(J - 3))
        A(J + 9) = -2.0 * U * A(J) * A(J + 3)
  310 CONTINUE
      A(17) = A(17) + U * A(12) * A(13)
      A(18) = A(18) + U * A(11) * A(13)
      A(19) = A(19) + U * A(11) * A(12)
      LD = LX
      CALL PLA156 (IER)
      IF (IER .NE. 0) GOTO 340
      CALL PLA157 (IER)
      IF (IER .NE. 0) GOTO 340
      CALL PLA158
      CALL PLA159
      CLOSE (LI)
      CLOSE (LP)
      GOTO 350
  320 WRITE (6, 99999)
      GOTO 350
  330 WRITE (LI, 99994)
      RETURN
  340 WRITE (6, 99997)
  350 RETURN
99999 FORMAT (/, '** CANNOT OPEN FILE')
99998 FORMAT ('SHELXS-86 - ',
     1        'Crystal Structure Solution - Stripped Version ', /)
99997 FORMAT ('** Problem in SHX86')
99996 FORMAT (A)
99995 FORMAT (/, 'V =', F10.2, 5X, 'At Vol =', F6.1, 5X, 'F(000) =',
     1 F8.1, //, '    Cell Wt =', F10.2, '    Rho =', F7.3, /)
99994 FORMAT (/, '** ERROR')
      END
      SUBROUTINE PLA156 (IER)
      PARAMETER (NP12=600,NP13=500,NP17=99,NPVD=40000000,NP23=18000,
     1 NPP=NPVD+2*NP23,NP38=125,NP39=30)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /SHX/ F(126), G(126), LR, LG, LH, LI, LP, LF, LA, LB,
     1 LY, LL, LQ, LE, LV, LX, LD, LZ, LJ, HKLF(11)
      COMMON // A(NPP)
      DIMENSION E(87), RS(13), SO(14), SU(14), IP(20)
      DATA RS /5.0, 3.5, 2.5, 2.0, 1.7, 1.5, 1.4, 1.3, 1.2, 1.1,
     1         1.0, 0.9, 0.8/
      LZ = LX + 7
      CALL GEN074 (SO, 0.0, 1, 14)
      CALL GEN074 (SU, 0.0, 1, 14)
      ML = LY + 12
      DO 10 I = ML, LL, 4
        A(I + 1) = A(I + 1) - 99.5
        A(I + 2) = A(I + 2) - 99.5
        A(I + 3) = A(I + 3) - 99.5
   10 CONTINUE
      CALL GEN074 (A, 0.0, 61, 64)
      CALL GEN074 (E, 0.0, 52, 87)
      SB = 1.0
      N  = 1
      NR = 0
      ND = 0
      NU = 0
      NX = 0
      M  = IABS(INT(G(1))) + 1
      G(1) = 0.5
   40 READ (LH, 99999, ERR = 40, END = 120) J, K, L, T, S
      T = T * G(2)
      S = S * G(2)
      IF (S .LT. 1.E-4) S = 0.1
      IF (T .LT. 0.5 * S) T = MIN (0.25 * S, 0.5 * SB)
      SB = 0.8 * SB + 0.2 * S
      IF (IABS(J) + IABS(K) + IABS(L) .EQ. 0) GOTO 120
      X = FLOAT(J)
      Y = FLOAT(K)
      Z = FLOAT(L)
      F(N + 1) = T
      F(N + 2) = S
      IF (T .LT. 1.E-6) GOTO 100
      U = X * G(3) + Y * G(4)  + Z * G(5)
      V = X * G(6) + Y * G(7)  + Z * G(8)
      W = X * G(9) + Y * G(10) + Z * G(11)
      IF (ABS(AMOD(U + 999.5, 1.0) - 0.5)
     1  + ABS(AMOD(V + 999.5, 1.0) - 0.5)
     2  + ABS(AMOD(W + 999.5, 1.0) - 0.5) .GT. 0.01) GOTO 80
      J = ML
   50 J = J + 4
      IF (J .LE. LL) THEN
        IF (ABS(AMOD(U * A(J + 1) + V * A(J + 2) +
     1      W * A(J + 3) + 999.5, 1.0) - 0.5) .LT. 0.01) THEN
          GOTO 50
        ELSE
          GOTO 80
        ENDIF
      ENDIF
      F(N) = 0.0
      DO 60 K = 65, LY, 12
        X = U * A(K)     + V * A(K + 3) + W * A(K + 6)
        Y = U * A(K + 1) + V * A(K + 4) + W * A(K + 7)
        Z = U * A(K + 2) + V * A(K + 5) + W * A(K + 8)
        IF (MAX(ABS(X), ABS(Y), ABS(Z)) .GT. 99.5) GOTO 100
        X = AINT(1.001 * X)
        Y = AINT(1.001 * Y)
        Z = AINT(1.001 * Z)
        F(N)  = MAX (F(N), ABS(X + 200.0 * (Y + 200.0 * Z)))
        A(61) = MAX (A(61), ABS(X))
        A(62) = MAX (A(62), ABS(Y))
        A(63) = MAX (A(63), ABS(Z))
   60 CONTINUE
      CALL GEN046 (F(N), X, Y, Z)
      IF (E(52) .GT. X) E(52) = X
      IF (E(53) .LT. X) E(53) = X
      IF (E(54) .GT. Y) E(54) = Y
      IF (E(55) .LT. Y) E(55) = Y
      IF (E(56) .GT. Z) E(56) = Z
      IF (E(57) .LT. Z) E(57) = Z
      K = 65
   70 K = K + 12
      IF (K .LE. LY) THEN
        Q = AINT(1.001 * (X * A(K) + Y * A(K + 3) + Z * A(K + 6))) +
     1      200.0 * (AINT(1.001 * (X * A(K + 1) + Y * A(K + 4) +
     2      Z * A(K + 7))) + 200.0 * AINT(1.001 * (X * A(K + 2) +
     3      Y * A(K + 5) + Z * A(K + 8))))
        IF (A(23) .LT. 0.5) Q = ABS(Q)
        IF (Q + 0.5 .LT. F(N)) GOTO 70
        YUNK = ABS(AMOD(0.5 + ABS(X * A(K + 9) + Y * A(K + 10) +
     1      Z * A(K + 11)), 1.0) - 0.5) - 0.01
        IF (YUNK .LT. 0.0) THEN
          GOTO 70
        ELSE
          GOTO 80
        ENDIF
      ENDIF
      Q = X * X * A(14) + Y * Y * A(15) + Z * Z * A(16) +
     1    Y * Z * A(17) + X * Z * A(18) + X * Y * A(19)
      IF (Q .GT. A(64)) A(64) = Q
      IF (Q .GE. 1.0) GOTO 90
      N = N + 3
      IF (N .GE. 126) THEN
        WRITE (LA) F
        N = 1
      ENDIF
      GOTO 110
   80 IF (F(N + 1) .LT. A(52) * F(N + 2)) GOTO 100
   90 NU = NU + 1
  100 NR = NR + 1
  110 ND = ND + 1
      GOTO 40
  120 F(N) = 0.0
      WRITE (LA) F
      CALL GEN108 (LA, 0)
      CLOSE (LH, STATUS = 'KEEP')
      IF (A(64) .GT. 1.0) A(64) = 1.0
      X = 2.0 * GL(5) * ATAN2(SQRT(A(64)), SQRT(1.0 - A(64)))
      WRITE (LI, 99998) ND, NR, A(61), A(62), A(63), X
      IF (A(20) .LT. - 8.E9) A(22) = MIN (A(22) * A(22), A(64))
      NU = 0
      NR = 0
      L  = 1
      QH = E(53) - E(52) + 1.0
      QK = E(55) - E(54) + 1.0
      QL = FLOAT(LX) + 7.3
      QC = QL + 0.8 - E(52) - QH * (E(54) - QK * E(56))
      RA = 0.0
      RB = 0.0001
      RC = 0.0
      RD = 0.0001
  130 QM = FLOAT(NPP) + 0.3
      JF = 0
      N  = INT(MIN(QC + E(53) + QH * (E(55) + QK * E(57)), QM))
      NF = 0
      M  = LX + 8
  140 CALL GEN074 (A, 0.0, M, N)
      IF (LZ .LT. N) LZ = N
  160 READ (LA) F
      I = - 2
  170 I = I + 3
      IF (I .GT. 126) GOTO 160
      IF (F(I) .GE. 0.5) THEN
        CALL GEN046 (F(I), X, Y, Z)
        Q = QC + QH * (Y + QK * Z) + X
        IF (Q .GE. QL) THEN
          IF (Q .LE. QM) THEN
            J = INT(Q)
            IF (NF .EQ. 0) THEN
              A(J) = 1.0
            ELSE IF (NF .EQ. 1) THEN
              K        = INT(A(J))
              W        = MAX (F(I + 1) / F(I + 2), 3.0) / F(I + 2)
              A(K)     = F(I)
              A(K + 1) = A(K + 1) + W
              A(K + 2) = A(K + 2) + W * F(I + 1)
              A(K + 3) = A(K + 3) + 1.0
              A(K + 4) = A(K + 4) + F(I + 1)
            ELSE
              K        = INT(A(J))
              A(K + 1) = A(K + 1) + ABS(F(I + 1) - A(K + 2))
              A(K + 4) = A(K + 4) + 1.0 / F(I + 2)**2
            ENDIF
          ENDIF
        ENDIF
        GOTO 170
      ENDIF
      CALL GEN108 (LA, 0)
      IF (NF .EQ. 0) THEN
        NF = 1
        Q  = 0.3
        DO 180 I = M, N
          IF (A(I) .GE. 0.5) THEN
            A(I) = Q
            Q    = Q + 5.0
            IF (I + INT(Q) .GT. NPP) GOTO 190
            K = I
          ENDIF
  180   CONTINUE
        JF = 1
        Q  = Q + 5.0
        K  = N
  190   I  = K
        QM = FLOAT(I) + 1.0
        DO 200 J = M, I
          A(J) = A(J) + QM
  200   CONTINUE
        M  = I + 1
        QM = QM - 0.7
        N  = I + INT(Q - 5.0)
        GOTO 140
      ENDIF
      I  = M - 5
      IF (NF .LT. 2) THEN
  210   I = I + 5
        IF (I .GT. N) THEN
          NF = 2
          GOTO 160
        ENDIF
        A(I + 2) = A(I + 2) / A(I + 1)
        A(I + 1) = 0.0
        IF (A(I + 3) .GT. 1.5) RB = RB + A(I + 4)
        A(I + 4) = 0.0
        GOTO 210
      ENDIF
      READ (LG) F
      CALL GEN108 (LG, 0)
      JU = INT(F(1))
  220 I  = I + 5
      IF (I .LE. N) THEN
        NR = NR + 1
        G(L) = A(I)
        V    = A(I + 2)
        G(L + 1) = SQRT(MAX (1.E-8, V))
        W = 1.0 / SQRT(A(I + 4))
        CALL GEN046 (G(L), X, Y, Z)
        J  = INT(X)
        K  = INT(Y)
        NI = INT(Z)
        IF (A(I + 3) .GE. 1.5) THEN
          RA = RA + A(I + 1)
          P  = A(I + 1) / (A(I + 3) * SQRT(A(I + 3) - 1.0))
          IF (P .GE. 5.0 * W) THEN
            NX = NX + 1
          ENDIF
          W = MAX (P, W)
        ENDIF
        P = 0.0
        T = 0.0
        DO 230 K = 65, LY, 12
          Q = AINT(1.001 * (X * A(K) + Y * A(K + 3) + Z * A(K + 6))) +
     1    200.0 * (AINT(1.001 * (X * A(K + 1) + Y * A(K + 4)
     2    + Z * A(K + 7))) + 200.0 * AINT(1.001 * (X * A(K + 2)
     3    + Y * A(K + 5) + Z * A(K + 8))))
          S = SIGN(1.0, Q) * (X * A(K + 9) + Y * A(K + 10)
     1      + Z * A(K + 11))
          IF (A(23) .LT. 0.5) Q = ABS(Q)
          IF (Q + 0.5 .GE. G(L)) P = P + 1.0
          IF (0.5 - Q .GE. G(L))
     1      T = 10.0 * AINT(12.0 * AMOD(400.01 - S, 1.0) + 12.0)
  230   CONTINUE
        Q = X * X * A(14) + Y * Y * A(15) + Z * Z * A(16)
     1    + Y * Z * A(17) + X * Z * A(18) + X * Y * A(19)
        G(L + 2) = Q + AINT(AMOD(X + 998.01, 2.0) +
     1   AMOD(Y + 998.01, 2.0) * 2.0 + AMOD(Z + 998.01, 2.0) * 4.0)
        G(L + 3) = T + (1.0 / P)
        J = 58 + INT(MIN(14.1, 33.3333 * Q / (A(1) * A(1))))
        E(J) = E(J) + 1.0
        E(J + 15) = E(J + 15) + V / P
        S = 0.5 * A(1) / SQRT(Q)
        K = 13
  240   IF (RS(K) .LE. S) THEN
          K = K - 1
          IF (K .GT. 0) GOTO 240
        ENDIF
        K = K + 1
        SU(K) = SU(K) + 1.0
        IF (Q .LE. A(53)) THEN
          J = 1
  250     J = J + 1
          IF (JU .GE. J) THEN
            IF (ABS(G(L) - F(J)) .GE. 0.5) GOTO 250
          ELSE
            IF (V .GT. W * A(52)) GOTO 260
          ENDIF
        ENDIF
        G(L + 1) = - G(L + 1)
        SO(K) = SO(K) + 1.0
        NU = NU + 1
  260   RC = RC + W
        RD = RD + V
        L  = L  + 4
        IF (L .GE. 124) THEN
          WRITE (LB) G
          L = 1
        ENDIF
        GOTO 220
      ENDIF
      QC = QC - QM + QL
      IF (JF .EQ. 0) GOTO 130
      G(L) = 0.0
      WRITE (LB) G
      CALL GEN108 (LB, 0)
      NU = NR - NU
      RA = RA / RB
      RC = RC / RD
      WRITE (LI, 99991) NR, NU, RA, RC
      I = 0
      X = 0.0
      NQ = 1
      DO 270 I = 1, 13
        IF (SU(I) .GT. 0.5) NQ = I
  270 CONTINUE
      DO 280 I = 2, 4
        X = AINT(A(I) / RS(NQ))
        J = I + I + 18
        G(J - 1) = - X
        G(J) = X + 0.5
  280 CONTINUE
      DO 290 I = 1, NQ
        P = 0.5 * A(1) / RS(I)
        G(I + 30) = P * P
        G(I + 50) =
     1    2.0 * GL(5) * ATAN2(P, SQRT(MAX (0.0, 1.0 - G(I + 30))))
        SO(I) = SU(I) - SO(I)
        G(I) = 0.0
  290 CONTINUE
      G(14) = 0.0
      Z     = 0.0
      IF (LY .NE. 77) THEN
        IF (LY .LT. 90) THEN
          GOTO 320
        ELSE
          GOTO 310
        ENDIF
      ENDIF
      IF (A(81) * A(85) .LT. 0.0) GOTO 310
  300 G(21) = 0.0
      GOTO 320
  310 G(23) = 0.0
      IF (LY .EQ. 101) THEN
        IF (ABS(A(78)) + ABS(A(90)) .LT. 0.1) GOTO 300
      ENDIF
  320 Y = G(23)
  330 X = G(21)
  340 J = ML
  350 J = J + 4
      IF (J .LE. LL) THEN
        YUNK = ABS(AMOD(X * A(J + 1) + Y * A(J + 2) + Z * A(J + 3)
     1     + 999.5, 1.0) - 0.5) - 0.01
        IF (YUNK .LT. 0.0) THEN
          GOTO 350
        ELSE
          GOTO 380
        ENDIF
      ENDIF
      W = X + 200.0 * (Y + 200.0 * Z) + 0.5
      K = 65
  360 K = K + 12
      IF (K .LE. LY) THEN
        Q = AINT(1.001 * (X * A(K) + Y * A(K + 3) + Z * A(K + 6)))
     1    + 200.0 * (AINT(1.001 * (X * A(K + 1) + Y * A(K + 4)
     2    + Z * A(K + 7))) + 200.0 * AINT(1.001 * (X * A(K + 2)
     3    + Y * A(K + 5) + Z * A(K + 8))))
        IF (ABS(Q) .GT. W) GOTO 380
        IF (A(23) .LT. 0.5) Q = ABS(Q)
        IF (Q + 1.0 .LT. W) GOTO 360
        YUNK =ABS(AMOD(0.5 + ABS(X * A(K + 9) + Y * A(K + 10)
     1    + Z * A(K + 11)), 1.0) - 0.5) -  0.01
        IF (YUNK .LT. 0.0) THEN
          GOTO 360
        ELSE
          GOTO 380
        ENDIF
      ENDIF
      Q = X * X * A(14) + Y * Y * A(15) + Z * Z * A(16)
     1  + Y * Z * A(17) + X * Z * A(18) + X * Y * A(19)
      IF (Q .GE. 0.0001) THEN
        K = 30 + NQ
  370   IF (G(K) .GE. Q) THEN
          K = K - 1
          IF (K .GT. 30) GOTO 370
        ENDIF
        K = K - 29
        G(K) = G(K) + 1.0
      ENDIF
  380 X = X + 1.0
      IF (X .LT. G(22)) GOTO 340
      Y = Y + 1.0
      IF (Y .LT. G(24)) GOTO 330
      Z = Z + 1.0
      IF (Z .LT. G(26)) GOTO 320
      WRITE (LI, 99990) (RS(I),     I = 1, NQ)
      WRITE (LI, 99989) (SO(I),     I = 1, NQ)
      WRITE (LI, 99988) (SU(I),     I = 1, NQ)
      WRITE (LI, 99987) (G(I),      I = 1, NQ)
      WRITE (LI, 99986) (G(I + 50), I = 1, NQ)
      CALL GEN074 (G, 0.0, 1, 5)
      Q = 0.015
      DO 390 I = 58, 72
        IF (E(I) .GE. 9.5) THEN
          P    = ALOG(E(I + 15) / E(I))
          G(1) = G(1) + 1.0
          G(2) = G(2) + Q
          G(3) = G(3) + Q * Q
          G(4) = G(4) + P
          G(5) = G(5) + P * Q
        ENDIF
        Q = Q + 0.03
  390 CONTINUE
      P = 20.0
      IF (G(1) .GE. 0.5) THEN
        Q = G(1) * G(3) - G(2) * G(2)
        IF (Q .GE. 1.E-6) P = (G(2) * G(4) - G(1) * G(5)) / Q
      ENDIF
      P = P / (A(1) * A(1))
      T  = 10.0 / (A(64) + 0.001)
      NR = 1
      ND = LX + 39
      LH = ND
      I  = INT(A(29) * 0.1)
      IF (I .GT. 0) LH = LH + 2 * INT(1.5 + A(I + 60))
      LD = LH - 2
      W = 1.0 / (A(27) * A(27))
      W = W * W
      U = GL(8) * A(28) / (A(1) * A(1))
      DO 530 M = 1, 4
        IF (M .EQ. 1) CALL GEN074 (G, 0.0, 1, 38)
        IF (M .EQ. 2) THEN
          J = LX + 27
          DO 400 K = J, LH, 2
            A(K)     = 0.0
            A(K + 1) = 0.0
  400     CONTINUE
          R = 0.0
          Q = 0.0
          DO 410 K = 12, 19
            R = R + G(K)
            Q = Q + G(K + 19)
  410     CONTINUE
          R = R / MAX (Q, 0.01)
          DO 420 K = 31, 38
            G(K) = G(K) * R
  420     CONTINUE
          J = LX + 8
          DO 430 K = 1, 19
            A(J) = G(K) / MAX (G(K + 19), 0.01)
            J = J + 1
  430     CONTINUE
          DO 440 K = 12, 19
            A(J) = AMOD(A(29), 10.0) * (A(J) - 1.0) + 1.0
  440     CONTINUE
          IF (A(29) .LT. 5.0) GOTO 530
        ENDIF
        IF (M .EQ. 3) THEN
          IF (A(29) .GE. 5.0) THEN
            DO 450 K = ND, LH, 2
              A(K) = AMOD(A(29), 10.0) * (A(K) / MAX (A(K + 1), 0.01)
     1             - 1.0) + 1.0
  450       CONTINUE
          ENDIF
        ENDIF
        IF (M .EQ. 4) THEN
          J = LX + 27
          L = J + 3
          DO 460 K = J, L
            A(K + 4) = A(K) / MAX (A(K + 4), 0.01)
  460     CONTINUE
        ENDIF
  470   READ (LB) F
        DO 510 I = 1, 124, 4
          IF (F(I) .LT. 0.5) GOTO 520
          QC = AMOD(F(I + 2), 1.0)
          R  = F(I + 1)**2 * EXP(P * QC) * AMOD(F(I + 3), 10.0)
          Q  = QC * T
          N  = INT(Q)
          Q  = Q - FLOAT(N)
          N  = N + 1
          S  = 1.0 - Q
          L  = INT(12.0 + F(I + 2))
          IF (M .EQ. 1) THEN
            G(L)      = G(L)+ 1.0
            G(L + 19) = G(L + 19) + R
            G(N)      = G(N)      + S
            G(N + 1)  = G(N +  1) + Q
            G(N + 19) = G(N + 19) + R * S
            G(N + 20) = G(N + 20) + R * Q
            GOTO 510
          ENDIF
          K = N + LX + 7
          L = L + LX + 7
          R = R * A(L) * (A(K) * S + A(K + 1) * Q)
          CALL GEN046 (F(I), XX, YY, ZZ)
          E(1) = ABS(XX)
          E(2) = ABS(YY)
          E(3) = ABS(ZZ)
          IF (A(29) .GE. 5.0) THEN
            J = INT(A(29) * 0.1)
            J = INT(0.5 + 2.0 * E(J)) + LX + 39
            IF (M .EQ. 2) THEN
              A(J)     = A(J)     + 1.0
              A(J + 1) = A(J + 1) + R
              GOTO 510
            ENDIF
            R = R * A(J)
          ENDIF
          IF (IABS(N - 5) .LE. 2) THEN
            IF (E(1) .LE. 0.5) THEN
              IF (MIN(E(2), E(3)) .LT. 0.5) GOTO 490
              J = LX + 27
              GOTO 480
            ENDIF
            IF (E(2) .LE. 0.5) THEN
              IF (E(3) .LT. 0.5) GOTO 490
              J = LX + 28
              GOTO 480
            ENDIF
            J = LX + 29
            IF (E(3) .GT. 0.5) J = J + 1
  480       IF (M .EQ. 3) THEN
              A(J) = A(J) + 1.0
              A(J + 4) = A(J + 4) + R
              GOTO 490
            ENDIF
            A(J + 8) = A(J + 8) + ABS(1.0 - R * A(J + 4))
          ENDIF
  490     IF (M .EQ. 4) THEN
            IF (R .GT. 0.001) R = SQRT(SQRT(1.0 /
     1                           ((1.0 / (R * R)) + W))) * EXP(U * QC)
            G(NR)     = F(I)
            L         = 4
            E(4)      = F(I)
            G(NR + 1) = F(I + 1)
            G(NR + 2) = R
            NR        = NR + 3
            IF (NR .GE. 126) THEN
              WRITE (LA) G
              NR = 1
            ENDIF
            IF (R .GE. ABS(A(26))) THEN
              IF (F(I + 1) .GE. 0.0) THEN
                DO 500 K = 4, L
                  LD = LD + 4
                  A(LD) = E(K)
                  IF (LD .GT. NPP - 2000) GOTO 760
                  A(LD + 1) = MIN (R, 9.0)
                  A(LD + 2) = 0.0
                  A(LD + 3) = 1.0
                  IF (A(26) .GT. 0.0) THEN
                    A(LD + 2) = AINT(F(I + 3) * 0.1) * 10.0
                    A(LD + 3) = 1.0 / AMOD(F(I + 3), 10.0)
                  ENDIF
  500           CONTINUE
              ENDIF
            ENDIF
          ENDIF
  510   CONTINUE
        GOTO 470
  520   CALL GEN108 (LB, 0)
  530 CONTINUE
      G(NR) = 0.0
      WRITE (LA) G
      CALL GEN108 (LA, 0)
      NA = LX + 4
      AP = 0.0
      M  = LY + 12
      DO 540 I = M, LL, 4
        A(I + 1) = A(I + 1) + 99.5
        A(I + 2) = A(I + 2) + 99.5
        A(I + 3) = A(I + 3) + 99.5
  540 CONTINUE
      JJ = IABS(INT(A(54)))
      M  = 0
      K  = 0
      I  = 0
      DO 550 J = 65, LY, 12
        IF (ABS(A(J + 1)) .GT. 0.5) I = 1
        IF (ABS(A(J + 2)) .GT. 0.5) K = 1
        IF (ABS(A(J + 5)) .GT. 0.5) M = 1
  550 CONTINUE
      J = LX + 27
      IF (I + K + M .EQ. 3) THEN
        DO 570 M = 1, 2
          K = J + 2
          X = A(J) + A(J + 1) + A(K)
          DO 560 I = J, K
            A(I) = X
  560     CONTINUE
          J = J + 8
  570   CONTINUE
        GOTO 600
      ENDIF
      IF (I .NE. 0) THEN
        I = LX + 28
        GOTO 580
      ENDIF
      IF (K .NE. 0) THEN
        I = LX + 29
        GOTO 580
      ENDIF
      IF (M .EQ. 0) GOTO 600
      J = LX + 28
      I = LX + 29
  580 M = J + 8
      DO 590 K = J, M, 8
        X    = A(K) + A(I)
        A(K) = X
        A(I) = X
        I    = I + 8
  590 CONTINUE
  600 J = LX + 27
      DO 610 I = 1, 4
        G(I) = A(J + 8) / MAX (A(J), 0.01)
        J    = J + 1
  610 CONTINUE
      IF (LZ .LT. LD + 3) LZ = LD + 3
      T = ABS(A(26))
      S = T
      DO 620 I = 5, 14
        IP(I) = 0
        G(I)  = T
        T     = T + 0.1
  620 CONTINUE
      I = LX + 4
      K = LH - 2
      IF (LD .LE. LH) THEN
        WRITE (LI, 99982) S
        GOTO 760
      ENDIF
  630 M = 1
  640 K = K + 4
      IF (K .LE. LD) THEN
        Q = A(K + 1)
        DO 650 L = 5, 14
          IF (Q .GT. G(L)) IP(L) = IP(L) + 1
  650   CONTINUE
        I        = I + 4
        A(I)     = A(K)
        F(M)     = A(K)
        F(M + 1) = A(K + 2) + Q
        F(M + 2) = A(K + 3)
        A(I + 1) = F(M + 1)
        M        = M + 3
        A(I + 2) = -1.0
        A(I + 3) = A(K + 3)
        IF (M .LT. 126) GOTO 640
        WRITE (LF) F
        GOTO 630
      ENDIF
      LD   = I
      F(M) = 0.0
      WRITE (LF) F
      CALL GEN108 (LF, 0)
      WRITE (LI, 99983) (G(I), I = 5, 14), (IP(I), I = 5, 14)
      WRITE (LI, 99984) (G(I), I = 1, 4)
      WRITE (LI, 99981)
      P = 2.0 * A(52)
      Q = 114.59 * ATAN2(SQRT(A(53)), SQRT(ABS(1.0 - A(53))))
      J = INT(AINT(A(29) * 0.1))
      U = A(29) - 10.0 * FLOAT(J)
      WRITE (LI, 99980) A(26), A(27), A(28), U, J, P, Q
      IF (ABS(A(39)) .GE. 0.5) THEN
        J = INT(A(40))
        K = INT(A(41))
        Q = AMOD(ABS(A(41)), 1.0)
        WRITE (LI, 99978) A(39), J, K, Q, A(42)
        L = INT(A(43))
        M = INT(A(44))
        WRITE (LI, 99977) L, M
      ENDIF
      I = INT(A(54))
      IF (I .EQ. 2) I = 6
      J = INT(A(57))
      WRITE (LI, 99975) I, J, A(58), A(59)
      L = LX + 4
  660 L = L  + 4
      IF (L .LE. LD) THEN
        A(L) = ABS(A(L))
        A(L + 3) = 0.0
        GOTO 660
      ENDIF
      LJ = LL - 1
      IF (IABS(JJ - 1) .LT. 2) GOTO 750
      IF (LX .NE. LV) THEN
        M = 0
        CALL GEN074 (F, 0.0, 1, 3)
        I = LX + 4
  670   I = I + 4
        IF (I .LE. LD) THEN
          R = AMOD(A(I + 1), 10.0)
          CALL GEN046 (A(I), X, Y, Z)
          X = X * GL(6)
          Y = Y * GL(6)
          Z = Z * GL(6)
          O = 0.0
          P = 0.0
          J = LV
  680     J = J + 8
          IF (J .LE. LX) THEN
            K = INT(0.001 * A(J + 1)) * 5 + LJ
            Q = A(K) * A(J + 5)
            DO 690 K = 65, LY, 12
              U = X * A(K) + Y * A(K + 3) + Z * A(K + 6)
              V = X * A(K + 1) + Y * A(K + 4) + Z * A(K + 7)
              W = X * A(K + 2) + Y * A(K + 5) + Z * A(K + 8)
              T = U * A(J + 2) + V * A(J + 3) + W * A(J + 4)
     1          + X * A(K + 9) + Y * A(K + 10) + Z * A(K + 11)
              O = O + Q * SIN(T)
              P = P + Q * COS(T)
  690       CONTINUE
            GOTO 680
          ENDIF
          O = O * A(23)
          Q = SQRT(O * O + P * P)
          IF (Q .GE. 1.E-6) THEN
            A(I + 2) = GL(5) * ATAN2(O, P)
            IF (A(I + 2) .LT. 0.0) A(I + 2) = A(I + 2) + 360.0
            IF (R .GE. A(32)) THEN
              F(1) = F(1) + R * R
              F(2) = F(2) + R * Q
              F(3) = F(3) + Q * Q
              M    = M + 1
              A(I + 3) = Q / R
            ENDIF
          ENDIF
          GOTO 670
        ENDIF
        J = (LX - LV) / 8
        R = SQRT(ABS(1.0 - F(2) * F(2) / (F(1) * F(3))))
        WRITE (LI, 99974) R, J, M, A(32)
      ENDIF
      IF (ABS(A(39)) .LE. 0.5) THEN
        IF (AP .LE. 0.5) THEN
          IF (LE .LT. LQ + 4) GOTO 750
        ENDIF
      ENDIF
      I = LX + 4
  700 I = I + 4
      IF (I .LE. LD) THEN
        A(I + 3) = AMOD(A(I + 1), 10.0)
        GOTO 700
      ENDIF
      N = (LD - NA) / 4
      M = 1
  710 M = 3 * M + 1
      IF (M .LT. N) GOTO 710
  720 M = M / 3
      N = 4 * M
      NJ = NA + N
      NI = NJ + 4
      DO 740 I = NI, LD, 4
        Q = A(I)
        R = A(I + 1)
        S = A(I + 2)
        T = A(I + 3)
        J = I
  730   K = J - N
        IF (A(K + 3) .LE. T) THEN
          A(J)     = A(K)
          A(J + 1) = A(K + 1)
          A(J + 2) = A(K + 2)
          A(J + 3) = A(K + 3)
          J = K
          IF (J .GT. NJ) GOTO 730
        ENDIF
        A(J) = Q
        A(J + 1) = R
        A(J + 2) = S
        A(J + 3) = T
  740 CONTINUE
      IF (M .GT. 2) GOTO 720
  750 LZ = NA
      RETURN
  760 IER = 1
      RETURN
99999 FORMAT (3I4, 2F8.2)
99998 FORMAT (//, I8, 2X, 'Reflections Read, of Which', I6, ' Rejected'
     1        //, 3X, 'Maximum H, K, L and 2-Ttheta=', 3F6.0, F8.2)
99991 FORMAT (/I8, ' Unique Reflections, of Which', I7, 2X,
     1        'Observed', //, 3X, 'R(int) =', F7.4, 5X,
     2        'R(sigma) =', F7.4, 6X, 'Friedel Opposites Merged')
99990 FORMAT (///, 'Number of Unique Data as a Function of Resolution ',
     1        'in Angstroms', //, ' Resolution  inf', 13F8.2)
99989 FORMAT (/, 'N(observed) ', 13F8.0)
99988 FORMAT (/, 'N(measured) ', 13F8.0)
99987 FORMAT (/, 'N(theory)   ', 13F8.0)
99986 FORMAT (/, 'Two-Ttheta  0.0', 13F8.1)
99984 FORMAT (//, 19X, 'Centric Acentric    0KL      H0L      HK0',
     1        6X, 'Rest', //, 'Mean abs(E*E-1)    0.968    0.736',
     2        4F9.3)
99983 FORMAT (///, 'Observed E  .gt. ', 10F6.3, //, ' Number',
     1        8X, 10I6)
99982 FORMAT (/, '** No Observed E Above', F7.3)
99981 FORMAT (/, 6X, 'Summary of Parameters', /)
99980 FORMAT ('ESEL  EMIN', F7.3, 3X, 'EMAX', F7.3, 3X, 'DELU', F6.3,
     1        3X, 'RENORM', F6.3, 3X, 'AXIS', I2, /,
     2        'OMIT  S', F6.2, 3X, '2THETA(MAX)', F7.1)
99978 FORMAT ('TREF  NP', F10.0, 3X, 'NE', I6, 3X, 'NTAN', I4,
     1        '   TW', F7.3, 3X, 'WN', F7.3)
99977 FORMAT ('SUBS  TYPE', I4, 3X, 'NS', I5)
99975 FORMAT ('FMAP  CODE', I3, /, 'PLAN  NPEAKS', I5,
     1        3X, 'DEL1', F6.3, 3X, 'DEL2', F6.3)
99974 FORMAT (///, 'RE =', F7.4, ' for', I4, ' Atoms and',
     1        I5, ' E Greater Than', F7.3)
      END
      SUBROUTINE PLA157 (IER)
      PARAMETER (NPVD=40000000,NP23=18000,NPP=NPVD+2*NP23)
      COMMON /SHX/ F(126), G(126), LR, LG, LH, LI, LP, LF, LA, LB,
     1 LY, LL, LQ, LE, LV, LX, LD, LZ, LJ, HKLF(11)
      COMMON // A(NPP)
      DIMENSION IP(27)
      NQ = 0
      CALL GEN097 (IP, 1, 27, 0)
      NC = 0
      NT = 0
      NA = LZ
      IF (ABS(A(39)) .LT. 0.5) GOTO 840
      IF (ABS(ABS(A(54)) - 1.5) .LT. 0.8) GOTO 840
      A(22) = A(43)
      A(28) = 0.0
      PA    = 0.1
      PS    = 0.1
      PF    = 0.1
      NF    = 1
      NB    = NA
      NY    = INT (MAX (ABS(A(40)), 10.0))
      NZ    = MIN (LD, INT(0.5 * (ABS(A(44)) + FLOAT(NY)) + 1.1) * 4
     1      + LX)
      MT = INT(A(43))
      I  = NA
      J  = NA
      IF (MT .EQ. 5) GOTO 10
      IF (MT .GT. 3) GOTO 30
      IF (MT .LT. 1) GOTO 30
   10 I = I + 4
      IF (I .LE. LD) THEN
        CALL GEN046 (A(I), F(1), F(2), F(3))
        F(5) = AMOD(ABS(F(1)) + 0.1, 2.0) + AMOD(ABS(F(2)) + 0.1, 2. ) +
     1         AMOD(ABS(F(3)) + 0.1, 2.0)
        IF (ABS(F(MT)) .GT. 0.5) GOTO 10
        K = I + 3
        DO 20 L = I, K
          P = A(L)
          A(L) = A(J + 4)
          A(J + 4) = P
          J = J + 1
   20   CONTINUE
        GOTO 10
      ENDIF
      NZ = MIN (NZ, J)
   30 MA = LX + 4
      NS = 0
      ME = LD + 4
      IF (MT .GE. 0) GOTO 440
      N = MIN (LX + 4 - 4 * MT, NZ)
      I = NA
      J = MIN (NZ - 4 * MT, LD)
   40 I = I + 4
      IF (I .GT. N) GOTO 440
      K = I + 3
      DO 50 L = I, K
        P    = A(L)
        A(L) = A(J)
        A(J) = P
        J = J + 1
   50 CONTINUE
      J = J - 8
      IF (J .GT. NZ) GOTO 40
      NZ = NZ - 4
      N  = MIN (N, NZ)
      GOTO 40
   60 L  = NA
      MB = NT + ((NZ - LX) / 4) - 3
   70 L  = L + 4
      IF (L .GT. NZ) GOTO 240
      R  = AMOD(A(L + 1), 10.0) * A(45)
      NQ = MB
      IZ = (L - LX - 4) / 4
      W  = A(L) - 0.5
   80 PQ = 0.0001
      RR = 0.0001
      Q  = 1.0
      PI = 0.0
      NN = NT+2
      I  = ME
      K  = I
      MZ = NT
   90 J  = MZ
  100 MZ = K + 2 * ((J - K) / 4)
      IF (A(MZ) .GT. W) GOTO 90
      K  = MZ
      IF (J .GT. K + 2) GOTO 100
      W = W + 1.0
  110 I = I + 2
  120 IF (I .GE. J) GOTO 150
      X = W - A(I) - A(J)
      IF (X .GT. 1.0) GOTO 110
      IF (X .LE. 0.0) THEN
        J = J - 2
        GOTO 120
      ENDIF
  130 NI = INT(A(I + 1) * Q)
      NJ = INT(A(J + 1))
      IF (IABS(NJ) .LE. IABS(NI)) THEN
        K  = NI
        NI = NJ
        NJ = K
      ENDIF
      IF (A(23) .LE. 0.5) THEN
        NJ = - IABS(NJ)
        NI = IABS(NI)
      ENDIF
      IF (NI + NJ .NE. 0) THEN
        N = IABS(NJ)
        M = IABS(NI)
        IF (M .NE. IZ) THEN
          IF (N .NE. IZ) THEN
            IF (NS .NE. 2) THEN
              IF (NS .NE. 4) THEN
                K  = N * 4 + LX + 5
                NK = M * 4 + LX + 5
                P  =(AMOD(A(K), 10.0) * AMOD(A(NK), 10.0))**2
                PQ = PQ + P
                IF (NS .EQ. 1) THEN
                  N    = N + NT + 1
                  A(N) = A(N) + P
                  M    = M + NT + 1
                  A(M) = A(M) + P
                ENDIF
                GOTO 140
              ENDIF
            ENDIF
            IF (NQ + 3 .GT. NPP) GOTO 850
            NQ    = NQ + 2
            A(NQ) = FLOAT(NI)
            Y     = AMOD(ABS(A(I + 1)), 1.0)
            IF (Q .LT. 0.0) Y = AMOD(1.008 - Y, 1.0)
            A(NQ + 1) = SIGN(FLOAT(N) + AMOD(ABS(A(J + 1)) + Y, 1.0),
     1                  FLOAT(NJ))
          ENDIF
        ENDIF
      ENDIF
  140 IF (Q .LT. 0) THEN
        GOTO 160
      ELSE
        GOTO 110
      ENDIF
  150 Q = - 1.0
      I = ME
      J = MZ
  160 I = I + 2
  170 X = W + A(I) - A(J)
      IF (X .LT. 0.0) GOTO 160
      IF (X .LT. 1.0) GOTO 130
      J = J + 2
      IF (J .LT. NN) GOTO 170
      IF (NS .NE. 3) THEN
        IF (NS .GT. 0) GOTO 180
      ENDIF
      A(L + 3) = R * SQRT(PQ)
      GOTO 70
  180 IF (NS .EQ. 1) GOTO 270
      I = MB
  190 I = I + 2
      IF (I .LE. NQ) THEN
        Q  = 1.0
        N  = IABS(INT(A(I)))
        NI = 4 * N + LX + 5
        M  = IABS(INT(A(I + 1)))
        NJ = 4 * M + LX + 5
        J = I
  200   J = J + 2
  210   IF (J .LE. NQ) THEN
          IF (IABS(INT(A(J))) .NE. N) GOTO 200
          IF (IABS(INT(A(J + 1))) .NE. M) GOTO 200
          Q        = Q + 1.0
          T        = A(J)
          V        = A(J + 1)
          A(J)     = A(NQ)
          A(J + 1) = A(NQ + 1)
          NQ       = NQ - 2
          IF (A(L + 1) .LT. 10.0) GOTO 200
          K = 720 + INT(12.0 * AMOD(ABS(A(I + 1)), 1.0))
     1      - INT(12.0 * AMOD(ABS(V), 1.0))
          IF (A(I) * T .LE. 0.0) THEN
            IF (A(NI) .LT. 10.0) GOTO 210
            K = K + INT(SIGN(0.1 * A(NI), A(I)))
          ENDIF
          IF (A(I + 1) * V .LE. 0.0) THEN
            IF (A(NJ) .LT. 10.0) GOTO 210
            K = K + INT(SIGN(0.1 * A(NJ), A(I + 1)))
          ENDIF
          IF (MOD(K, 12) .NE. 0) Q = -9.E5
          GOTO 210
        ENDIF
        IF (Q .LT. 0.0) GOTO 190
        IF (NS .EQ. 4) THEN
          IF (M .LE. IZ) THEN
            PA = PA + 1.0
            IF (L .LE. NC) PS = PS + 1.0
          ENDIF
        ENDIF
        Q = SQRT(Q)
        X = AMOD(A(NJ), 10.0) * AMOD(A(NI), 10.0)
        IF (NJ .EQ. NI) Q = Q * (X - 1.0) / X
        RR = RR + (X * Q)**2
        A(I) = SIGN(ABS(A(I)) + Q * 0.1, A(I))
        X  = X * Q * R
        Y  = X * SQRT(2.0 - A(23))
        Y  = MIN (Y * (0.5658 + Y * (Y * 0.0106 - 0.1304)),
     1       Y / (0.56 + Y))
        PQ = PQ + X * (X + 2.0 * Y * PI)
        PI = PI + X * Y
        GOTO 190
      ENDIF
      A(L + 3) = SQRT(PQ)
      IF (NS .NE. 2) THEN
        NQ = NQ + 2
        A(NQ) = 0.0
        A(NQ + 1) = FLOAT(IZ)
        I = MB
  220   I = I + 2
        IF (I .LE. NQ) THEN
          F(NF) = A(I)
          F(NF + 1) = A(I + 1)
          NF = NF + 2
          IF (NF .GE. 126) THEN
            WRITE (LB) F
            NF = 1
          ENDIF
          GOTO 220
        ENDIF
        IF (PA .GT. 2.0 * PS + 0.5) GOTO 520
        GOTO 70
      ENDIF
      A(28) = A(28) + A(L + 3)**2
      I = MB
  230 I = I + 2
      IF (I .LE. NQ) THEN
        IF (L .LE. NB) THEN
          IF (INT(ABS(A(I + 1))) .LT. IZ) PF = PF + 1.0
        ENDIF
        MB = MB + 2
        A(MB) = A(I)
        A(MB + 1) = A(I + 1)
        GOTO 230
      ENDIF
      MB = MB + 2
      IF (MB .GT. NPP - 2000) GOTO 850
      A(MB) = 0.0
      MB    = MB + 1
      A(MB) = FLOAT(IZ)
      MB    = MB + 1
      A(MB) = A(L + 3)
      A(MB + 1) = 125.0 / RR
      GOTO 70
  240 IF (NS .NE. 0) GOTO 290
      NS = 1
      IF (IABS(MT - 2) .NE. 2) GOTO 290
      IZ = 0
      I = NT + 2
      CALL GEN074 (A, 1.0, I, MB)
  260 READ (LA) F
      NF = - 2
  270 NF = NF + 3
      IF (NF .GT. 124) GOTO 260
      IF (0.5 .LE. F(NF)) THEN
        CALL GEN046 (F(NF), X, Y, Z)
        R = X * X * A(14) + Y * Y * A(15) + Z * Z * A(16)
     1    + Y * Z * A(17) + X * Z * A(18) + X * Y * A(19)
        IF (0.005 .GT. R) GOTO 270
        IF (EXP(2.0 * R / A(1)**2) * F(NF + 2) .GT. 0.65 + 0.05 * A(23))
     1    GOTO 270
        W = F(NF) - 0.5
        GOTO 80
      ENDIF
      I = LX + 4
      CALL GEN108 (LA, 0)
      J = NT + 1
  280 I = I + 4
      IF (I .LE. NZ) THEN
        J = J + 1
        A(I + 3) = A(I + 3) * A(J)
        GOTO 280
      ENDIF
  290 IF (NS .EQ. 1) THEN
        IF (MT .GT. 6) THEN
          T = FLOAT(6 - MT) / A(1)**2
          I = NA
  300     I = I + 4
          IF (I .LE. NZ) THEN
            CALL GEN046 (A(I), X, Y, Z)
            A(I + 3) = A(I + 3) * EXP(T * (X * X * A(14)
     1               + Y * Y * A(15) + Z * Z * A(16) + Y * Z * A(17)
     2               + X * Z * A(18) + X * Y * A(19)))
            GOTO 300
          ENDIF
        ENDIF
        NB = NA
        NC = LX + 4 * INT(ABS(A(44)) + 1.1)
  310   Q = 0.01
        I = NB
  320   I = I + 4
        IF (I .LE. NZ) THEN
          IF (Q .LE. A(I + 3)) THEN
            Q = A(I + 3)
            M = I
          ENDIF
          GOTO 320
        ENDIF
        IF (Q .GE. 0.1) THEN
          K = M + 3
          DO 330 I = M, K
            P = A(I)
            A(I) = A(NB + 4)
            A(NB + 4) = P
            NB = NB + 1
  330     CONTINUE
          IF (NB .LT. NC) GOTO 310
        ENDIF
        I  = NB
        NZ = MIN (NZ, NC)
  340   I  = I + 4
        IF (I .LE. LD) THEN
          A(I + 3) = AMOD(A(I + 1), 10.0)
          GOTO 340
        ENDIF
        N = (LD - NB) / 4
        M = 1
  350   M = 3 * M + 1
        IF (M .LT. N) GOTO 350
  360   M = M / 3
        N = 4 * M
        NJ = NB + N
        NI = NJ + 4
        DO 380 I = NI, LD, 4
          Q = A(I)
          R = A(I + 1)
          S = A(I + 2)
          T = A(I + 3)
          J = I
  370     K = J - N
          IF (A(K + 3) .LE. T) THEN
            A(J)     = A(K)
            A(J + 1) = A(K + 1)
            A(J + 2) = A(K + 2)
            A(J + 3) = A(K + 3)
            J = K
            IF (J .GT. NJ) GOTO 370
          ENDIF
          A(J)     = Q
          A(J + 1) = R
          A(J + 2) = S
          A(J + 3) = T
  380   CONTINUE
        IF (M .GT. 2) GOTO 360
        NS = 2
        NZ = NB
        MB = NT
        IF (MT .NE. 0) GOTO 440
      ENDIF
      IF (NS .EQ. 2) THEN
        K = MB + 3
        A(K - 1) = 0.0
        A(K) = 0.0
        J    = NT + 2
        DO 390 I = J, K
          A(ME) = A(I)
          ME = ME + 1
  390   CONTINUE
        NS = 3
        NC = MIN (LD, LX + 4 + 4 * NY)
        GOTO 430
      ENDIF
      IF (NS .NE. 3) GOTO 520
      NF = 1
      NC = NB
  400 Q  = 0.01
      I  = NC
  410 I  = I + 4
      IF (I .LE. NZ) THEN
        IF (Q .LE. A(I + 3)) THEN
          Q  = A(I + 3)
          M  = I
        ENDIF
        GOTO 410
      ENDIF
      IF (Q .GE. 0.1) THEN
        K  = M + 3
        DO 420 I = M, K
          P    = A(I)
          A(I) = A(NC + 4)
          A(NC + 4) = P
          NC = NC + 1
  420   CONTINUE
        IF (NC .LT. LX + 4 + 4 * NY) GOTO 400
      ENDIF
      NS = 4
  430 NZ = NC
  440 L  = MA
      NT = ME
      A(NT) = 0.0
      P  = 0.0
  450 L  = L + 4
      NG = NT
      P  = P + 1.0
      CALL GEN046 (A(L), X, Y, Z)
      DO 470 M = 65, LY, 12
        W = AINT(1.001 * (X * A(M) + Y * A(M + 3) + Z * A(M + 6)))
     1    + 200.0 * (AINT(1.001 * (X * A(M + 1) + Y * A(M + 4)
     2    + Z * A(M + 7))) + 200.0 * AINT (1.001 * (X * A(M + 2)
     3    + Y * A(M + 5) + Z * A(M + 8))))
        Q = 1.0 - A(23) * (1.0 - SIGN(1.0, W))
        W = ABS(W)
        J = NG
  460   J = J + 2
        IF (J .LE. NT) THEN
          IF (ABS(W - A(J)) .GT. 0.5) THEN
            GOTO 460
          ELSE
            GOTO 470
          ENDIF
        ENDIF
        NT = NT + 2
        A(NT) = W
        A(NT + 1) = Q * (P + AMOD (900.004 - Q * (X * A(M + 9)
     1    + Y * A(M + 10) + Z * A(M + 11)), 1.0))
  470 CONTINUE
      IF (NT .GT. NPP - 3000) GOTO 850
      IF (L .LT. NZ) GOTO 450
      N = (NT - ME) / 2
      M = 1
  480 M = 3 * M + 1
      IF (M .LT. N) GOTO 480
  490 M = M / 3
      N = M * 2
      NJ = ME + N
      NI = NJ + 2
      DO 510 I = NI, NT, 2
        Q = A(I)
        T = A(I + 1)
        J = I
  500   K = J - N
        IF (A(K) .GE. Q) THEN
          A(J) = A(K)
          A(J + 1) = A(K + 1)
          J = K
          IF (J .GT. NJ) GOTO 500
        ENDIF
        A(J) = Q
        A(J + 1) = T
  510 CONTINUE
      IF (M .GT. 2) GOTO 490
      IF (NS .EQ. 0) GOTO 60
      L  = NA
      MB = NT
      IF (NS .GT. 2) THEN
        NZ = MIN (LD, NC + 2 * NY)
        IF (NS .EQ. 4) THEN
          L  = MA
          NZ = NC
          IF (A(41) .LT. 0.0) NZ = LD
          A(41) = ABS(A(41))
        ENDIF
      ENDIF
      GOTO 70
  520 F(NF) = 0.0
      F(NF + 1) = 0.0
      WRITE (LB) F
      CALL GEN108 (LB, 0)
      J = (NB - LX - 4) / 4
      WRITE (LI, 99998) J, PF
      J = (NC - LX - 4) / 4
      WRITE (LI, 99999) J, PS, IZ, PA
      NY = NT + 4
      M  = LD - 1
      NQ = M
      IF (A(42) .GE. 0.9999) THEN
        IF (A(44) .GT. 0.0) GOTO 830
      ENDIF
      R         = 0.75 + 0.05 * A(23)
      A(NT + 2) = 9.E9
      NQ        = NT + 3
      A(NQ)     = -1.0
      MZ = INT(MIN(0.3 * FLOAT(NPP) + 0.7 * FLOAT(NQ), FLOAT(NQ)
     1   + 10000.0))
  530 READ (LA) F
      I = -2
  540 I = I + 3
      IF (I .GT. 124) GOTO 530
      IF (0.5 .LE. F(I)) THEN
        CALL GEN046 (F(I), X, Y, Z)
        P = X * X * A(14) + Y * Y * A(15) + Z * Z * A(16)
     1    + Y * Z * A(17) + X * Z * A(18) + X * Y * A(19)
        IF (0.005 .GT. P) GOTO 540
        P = EXP(2.0 * P / A(1)**2) * F(I + 2)
        IF (P .GT. R) GOTO 540
        M = NQ
        DO 560 N = 65, LY, 12
          Q = ABS(AINT(1.001 * (X * A(N) + Y * A(N + 3)
     1      + Z * A(N + 6))) + 200.0 * (AINT(1.001 * (X * A(N + 1)
     2      + Y * A(N + 4) + Z * A(N + 7))) + 200.0 * AINT(1.001 *
     3      (X * A(N + 2) + Y * A(N + 5) + Z * A(N + 8)))))
          J = M
  550     J = J + 2
          IF (J .LE. NQ) THEN
            IF (ABS(Q - A(J)) .LT. 0.5) THEN
              GOTO 560
            ELSE
              GOTO 550
            ENDIF
          ENDIF
          NQ = NQ + 2
          A(NQ) = Q
          A(NQ + 1) = P
  560   CONTINUE
  570   IF (NQ .LT. MZ) GOTO 540
        R  = R - 0.01
        J  = NT + 3
        K  = NQ
        NQ = J
  580   J  = J + 2
        IF (J .GT. K) GOTO 570
        IF (A(J + 1) .LE. R) THEN
          NQ        = NQ + 2
          A(NQ)     = A(J)
          A(NQ + 1) = A(J + 1)
        ENDIF
        GOTO 580
      ENDIF
      CALL GEN108 (LA, 0)
      NY = NQ + 1
      N = (NQ - NT - 3) / 2
      M = 1
  590 M = 3 * M + 1
      IF (M .LT. N) GOTO 590
  600 M  = M / 3
      N  = M + M
      NJ = NT + 3 + N
      NI = NJ + 2
      DO 620 I = NI, NQ, 2
        Q = A(I)
        T = A(I + 1)
        J = I
  610   K = J - N
        IF (A(K) .GE. Q) THEN
          A(J)     = A(K)
          A(J + 1) = A(K + 1)
          J        = K
          IF (J .GT. NJ) GOTO 610
        ENDIF
        A(J)     = Q
        A(J + 1) = T
  620 CONTINUE
      IF (M .GT. 2) GOTO 600
      A(NQ + 2) = 9.E9
      MZ = 5 * MIN ((NPP - NQ - 111) / 13, 1000) + NQ + 10
      NY = MAX (MZ + 1, NY)
      PZ = 0.0
      M  = NQ + 2
      MP = M + 5
      KZ = 0
      NI = NT + 2
      JN = NI + 1
      NL = 0
      L  = LX + 4
  630 L  = L + 4
      IF (L .GT. NC) GOTO 820
      NL = NL + 1
      I = NQ + 2
      N = MZ
      NU = -1
      S = 1.0
      Q = -1.0
      R = A(L)
      X = A(NQ) - R + 0.5
      J = ME + 2
      IF (X .GE. A(J)) THEN
        NM = NT
  640   K  = NM
  650   NM = J + 2 * ((K - J) / 4)
        IF (A(NM) .GT. X) GOTO 640
        J = NM
        IF (K .GT. J + 2) GOTO 650
      ENDIF
  660 I = I - 2
  670 X = A(J) - A(I) + R
      IF (X .LT. -0.5) GOTO 660
      IF (X .LT.  0.5) GOTO 790
      J = J - 2
      IF (J .GT. ME) GOTO 670
      S  = -1.0
      NU = 0
  680 J  = J + 2
  690 X  = R - A(I) - A(J)
      IF (X .GT.  0.5) GOTO 680
      IF (X .GT. -0.5) GOTO 790
      I = I - 2
      IF (I .GT. JN) GOTO 690
      Q  = 1.0
      NU = 1
  700 I  = I + 2
  710 X  = R + A(I) - A(J)
      IF (X .LT. -0.5) GOTO 700
      IF (X .LT.  0.5) GOTO 790
      J = J + 2
      IF (J .LT. NI) GOTO 710
  720 J = MZ
  730 J = J + 3
      IF (J .GT. N) GOTO 630
      S = A(J) + R
      I = J + 3
      K = N + 3
  740 K = K - 3
  750 IF (K .LE. I) GOTO 730
      X = S + A(I) + A(K)
      IF (X .LT. -0.5) GOTO 740
      IF (X .LT.  0.5) GOTO 760
      I = I + 3
      GOTO 750
  760 G(1) = FLOAT(NL) + AMOD(ABS(A(I + 1)) + ABS(A(J + 1))
     1     + ABS(A(K + 1)), 1.0)
      G(2) = A(J + 1)
      G(3) = A(I + 1)
      G(4) = A(K + 1)
      KZ   = KZ + 1
      P    = 2.0 - A(I + 2) - A(J + 2) - A(K + 2)
      DO 770 NJ = 1, 4
        NM = INT(ABS(G(NJ))) * 4 + LX + 5
        P  = P * AMOD(A(NM), 10.0)
  770 CONTINUE
      IF (P .LT. PZ) GOTO 740
      IF (M .LT. MP) M = MP
      A(MP) = P
      A(MP + 1) = G(1)
      A(MP + 2) = G(2)
      A(MP + 3) = G(3)
      A(MP + 4) = G(4)
      IF (M .GE. MZ - 8) THEN
        PZ = P
        NJ = NQ + 2
  780   NJ = NJ + 5
        IF (NJ .GT. M) GOTO 740
        IF (A(NJ) .LE. PZ) THEN
          PZ = A(NJ)
          MP = NJ
        ENDIF
        GOTO 780
      ENDIF
      MP = MP + 5
      GOTO 740
  790 NM = INT(ABS(A(J + 1)))
      IF (NM .LT. NL) THEN
        K = MZ
  800   K = K + 3
        IF (K .LE. N) THEN
          IF (NM .EQ. INT(ABS(A(K + 1)))) GOTO 810
          GOTO 800
        ENDIF
        IF (N .GT. NPP - 5) GOTO 720
        N = N + 3
        IF (NY .LT. N + 2) NY = N + 2
        A(N) = A(J) * S
        X = AMOD(ABS(A(J + 1)), 1.0)
        IF (S .LT. 0.0) X = AMOD(1.008 - X, 1.0)
        A(N + 1) = SIGN(AINT(ABS(A(J + 1))) + X, A(J + 1) * S)
        A(N + 2) = A(I + 1)**2
      ENDIF
  810 IF (NU .LT. 0) THEN
        GOTO 660
      ELSE IF (NU .EQ. 0) THEN
        GOTO 680
      ELSE
        GOTO 700
      ENDIF
  820 I = (M - NQ) / 5
      A(43) = 64.0 * A(45) / SQRT(FLOAT(I) + 24.0)
      IF (I .EQ. 0) A(43) = 0.0
      WRITE (LI, 99997) KZ, I
  830 LZ = M
      LQ = NQ + 2
      N  = ((M - LQ) / 5) * 8 + M + 5
      IF (N .GT. NY) NY = N
      A(27) = PF
      A(29) = FLOAT(ME)
      LR = NB
      LH = NC
  840 LE = NA
      RETURN
  850 IER = 1
      RETURN
99999 FORMAT (/, I6, ' Large E-Values Refined Using', F9.0,
     1        ' Unique TPR', /, I6, ' Reflections and', F9.0,
     2        ' Unique TPR for R(alpha)')
99998 FORMAT (//, I6, ' Subset Reflections and',
     1        F8.0, ' Unique TPR for Filter')
99997 FORMAT (/, I8, ' Negative Quartets Found,', I5, ' Used')
      END
      SUBROUTINE PLA158
      PARAMETER (NPVD=40000000,NP23=18000,NPP=NPVD+2*NP23)
C * TANGENT REFINEMENT
      COMMON /SHX/ F(126), G(126), LR, LG, LH, LI, LP, LF, LA, LB,
     1 LY, LL, LQ, LE, LV, LX, LD, LZ, LJ, HKLF(11)
      COMMON // A(NPP)
      COMMON /WORDD/ IH(20), IR
      DIMENSION IP(20), ID(31), SN(15), B(64), C(64), D(126),
     1 E(126), FB(64), FC(64), FD(64), FE(64), PM(64), PR(64)
      CHARACTER IH*1, IR*80
      NG = 0
      RR = 1.E8
      W  = 0.0
      S  = 0.0
      NA = LE
      IF (ABS(A(39)) .LT. 0.5) GOTO 810
      TW = AMOD(A(41), 1.0)
      MB = -1
      IF (A(27) .LT. 0.5) MB = 0
      IF (MB .NE. 0) TW = 5.0 * TW
      ME = INT(A(29))
      NB = LR
      NC = LH
      NI = ME + 1
      NJ = (NC - LX - 4) / 4 + ME
      CALL GEN074 (A, 0.1, NI, NJ)
      MP = LZ + 5
      NE = MP
      A(NE) = 0.0
      J = LQ
   20 J = J + 5
      IF (J .LE. LZ) THEN
        K = J + 3
        DO 30 L = J, K
          M         = INT(ABS(A(L + 1)))
          NE        = NE + 2
          A(NE)     = - FLOAT(M)
          A(NE + 1) = FLOAT(J)
          M         = M + ME
          A(M)      = A(M) + 2.0
   30   CONTINUE
        GOTO 20
      ENDIF
      ML = MP
      DO 40 I = NI, NJ
        J    = INT(A(I))
        A(I) = FLOAT(ML)
        ML   = ML + J
   40 CONTINUE
      I = MP
   50 I = I + 2
      IF (I .LE. NE) THEN
   60   IF (A(I) .GT. 0.0) GOTO 50
        M    = INT(0.1 - A(I)) + ME
        A(M) = A(M) + 2.0
        M    = INT(A(M))
        Q    = A(M)
        A(M) = - A(I)
        IF (I .EQ. M) GOTO 50
        A(I)     = Q
        Q        = A(M + 1)
        A(M + 1) = A(I + 1)
        A(I + 1) = Q
        GOTO 60
      ENDIF
      L  = 0
      NF = 1
      K  = LX + 4
   70 K  = K + 4
      IF (K .LE. NC) THEN
        L  = L + 1
        NJ = L + ME
        NJ = INT(A(NJ))
   80   IF (INT(A(NJ)) .LT. L) GOTO 70
        J  = INT(A(NJ + 1))
        NJ = NJ - 2
        T = AMOD(A(J + 1), 1.0)
        W = AINT(A(J + 1))
        X = AINT(A(J + 2))
        Y = AINT(A(J + 3))
        Z = AINT(A(J + 4))
   90   IF (INT(ABS(W)) .EQ. L) THEN
          S = SIGN(1.0, W)
          G(NF) = T + FLOAT(L)
          G(NF + 1) = S * X
          G(NF + 2) = S * Y
          G(NF + 3) = S * Z
          NF = NF + 4
          IF (NF .GE. 122) THEN
            WRITE (LG) G
            NF = 1
          ENDIF
          GOTO 80
        ENDIF
        S = W
        W = X
        X = Y
        Y = Z
        Z = S
        GOTO 90
      ENDIF
      G(NF) = 0.0
      WRITE (LG) G
      CALL GEN108 (LG, 0)
      WF = 0.0
      MS = ME - 3
      IF (MB .NE. 0) THEN
        IF (A(44) .LE. 0.0) THEN
          M  = (NB - LX - 4) / 4
          N  = LZ
          LZ = LQ
          I  = LQ
  100     I  = I + 5
          IF (I .LE. N) THEN
            IF (INT(A(I + 1)) .LE. M) THEN
              LZ        = LZ + 5
              A(LZ)     = A(I)
              A(LZ + 1) = A(I + 1)
              A(LZ + 2) = A(I + 2)
              A(LZ + 3) = A(I + 3)
              A(LZ + 4) = A(I + 4)
            ENDIF
            GOTO 100
          ENDIF
  110     Q = - 1.0
          N = 0
          I = LQ
  120     I = I + 5
          IF (I .LE. LZ) THEN
            IF (A(I) .GE. Q) THEN
              N = I
              Q = A(I)
            ENDIF
            GOTO 120
          ENDIF
          IF (N .NE. 0) THEN
            ME = ME + 4
            A(ME - 3) = A(N + 1)
            A(ME - 2) = A(N + 2)
            A(ME - 1) = A(N + 3)
            A(ME)     = A(N + 4)
            Q = 1.0
            K = ME - 3
            DO 130 I = K, ME
              J = INT(ABS(A(I))) * 4 + LX + 5
              Q = Q * AMOD(A(J), 10.0)
  130       CONTINUE
            WF = WF + Q
            LQ = LQ + 5
            A(N)     = A(LQ)
            A(N + 1) = A(LQ + 1)
            A(N + 2) = A(LQ + 2)
            A(N + 3) = A(LQ + 3)
            A(N + 4) = A(LQ + 4)
            IF (ME .LT. MS + 400) GOTO 110
          ENDIF
        ENDIF
      ENDIF
      I = (ME - MS) / 4
      WRITE (LI, 99999) I
      TS = 0.0
      TZ = 0.0
      NS = ME
      I  = LX + 4
  140 I  = I + 4
      IF (I .LE. LD) THEN
        TS = TS + A(I + 3)
        TZ = TZ + A(I + 3)**2 / (A(I + 3) + 5.0)
        IF (I .LE. NC) THEN
          IF (A(23) .GE. 0.5) THEN
            IF (A(I + 1) .LT. 10.0)  GOTO 140
            IF (A(I + 1) .LT. 120.0) GOTO 140
            IF (A(I + 1) .GT. 130.0) GOTO 140
          ENDIF
          IF (NS - ME .LE. 64) THEN
            CALL GEN046 (A(I), X, Y, Z)
            IF (AMOD(900.1 + Z, 2.0) + AMOD(98.1 + Y, 2.0) +
     1          AMOD(98.1 + X, 2.0) .LE. 0.5) THEN
              NS    = NS + 1
              A(NS) = FLOAT((I - LX - 4) / 4)
              J     = INT(X)
              K     = INT(Y)
              L     = INT(Z)
              T     = AMOD(A(I + 1), 10.0)
            ENDIF
          ENDIF
        ENDIF
        GOTO 140
      ENDIF
      NQ = 1
      MQ = 1
      IF (A(39) .GE. 0.0) THEN
        X  = 2.0 * FLOAT(NPP - NS)
        I  = INT(A(39) - 0.5)
        NQ = MIN (64, I + 1, INT(X / FLOAT(NC - LX - 4)))
        K  = I + NQ
        NQ = I / (K / NQ) + 1
        MQ = MIN (126, INT(X / FLOAT(NB - LX - 4)), (1 - MB) * NQ)
      ENDIF
      ML = NS + MAX (((NC - LX - 4) / 2) * NQ,
     1     ((NB - LX - 4) / 2) * MQ)
      I  = - MQ * MB
      MT = INT(A(41))
      NE = NS + 1
      NM = 2 * NQ
      NL = NE - NM
      MH = 2 * MQ
      ML = NE - MH
      RN = 2097152.0 * AMOD(SQRT(0.4321 * ABS(A(40))), 1.0)
      PQ = 9.E9
      TN = 0.3
      PS = 0.0
      DO 150 NJ = 1, 15
        SN(NJ) = SIN(FLOAT(NJ - 1) * 0.523598)
  150 CONTINUE
      CALL GEN097 (ID, 1,      31, 0)
  160 CALL GEN074 (FB, 0.0,    1, NQ)
      CALL GEN074 (FC, 0.0001, 1, NQ)
      CALL GEN074 (FD, 0.0,    1, NQ)
      CALL GEN074 (FE, 0.0,    1, NQ)
      CALL GEN074 (B , 0.0,    1, NQ)
      CALL GEN074 (C , 0.0,    1, NQ)
      CALL GEN074 (PM, 9.E9,   1, NQ)
      CALL GEN074 (D,  -1.E-6, 1, MQ)
      CALL GEN074 (E,  0.0,    1, MQ)
      NZ = MB
      MM = MQ
      PN = 0.1
  170 DO 180 I = 1, MQ
        RN = AMOD((1.0 + 2.0 * AINT(RN / 2.0 + 0.3)) * 5.0, 2097152.0)
        F(I) = 0.0
        IF (MB .EQ. 0) THEN
          PM(I) = 0.0
          PR(I) = RN
        ENDIF
        G(I) = RN
  180 CONTINUE
      IF (A(39) .LT. 0.0) G(1) = - A(39)
  190 N = NE
      M = NB
      IF (NZ .EQ. 0) M = NC
      DO 210 I = 1, MM
        R = G(I)
        R = AMOD(7169.0 * SQRT(R / 2097152.0), 1.0)
        K = N
        L = LX + 4
  200   L = L + 4
        IF (L .LE. M) THEN
          P = AMOD(A(L + 1), 10.0)
          IF (MB .NE. 0) P = P * 0.2
          IF (L .GT. NB) P = P * TW
          R = AMOD((1.0 + 2.0 * AINT(1048576.0 * R + 0.3)) * 5.0,
     1        2097152.0) / 2097152.0
          Q = R
          IF (L .LE. NA) Q = A(L + 2) / 360.0
          IF (A(23) .LE. 0.5) THEN
            Q        = SIGN(1.0, AMOD(Q + 0.75, 1.0) - 0.5)
            A(K)     = P * Q
            A(K + 1) = - A(K)
          ELSE
            IF (A(L + 1) .GT. 10.0)
     1        Q = AMOD(AINT(0.1 * A(L + 1)) / 24.0 + 9.25 - Q, 0.5)
     2          - 0.25 + Q
            Q        = Q * 6.28319
            A(K)     = P * COS(Q)
            A(K + 1) = P * SIN(Q)
          ENDIF
          K = K + MM * 2
          GOTO 200
        ENDIF
        N = N + 2
  210 CONTINUE
      MU = 1
      IF (MB .EQ. 0) GOTO 240
      M  = LD + 2
      IZ = 5
      IF (A(22) .LT. 3.5) GOTO 390
      DO 220 K = 65, LY, 12
        IF (ABS(A(K + 9)) + ABS(A(K + 10)) + ABS(A(K + 11)) .GT. 0.1)
     1       IZ = MIN (IZ + 1, 8)
  220 CONTINUE
      GOTO 390
  230 CALL GEN108 (LB, 0)
      CALL GEN108 (LG, 0)
  240 MU = NZ
      NZ = NZ + 1
      IF (NZ .GT. MT) GOTO 710
      READ (LG) G
      NG = 1
      MP = 0
  250 READ (LB) F
      M = -1
  260 M = M + 2
      IF (M .GT. 125) GOTO 250
      P = F(M)
      T = ABS(P)
      XQ = F(M + 1)
      Z = ABS(XQ)
  270 I = INT(T) * NM + NL
      J = INT(Z) * NM + NL
      IF (I .EQ. NL) GOTO 400
      IF (MU .EQ. 0) GOTO 260
  280 KI = INT(T) * 4 + LX + 5
      KJ = INT(Z) * 4 + LX + 5
      T = 10.0 * AMOD(T, 1.0)
      Z = AMOD(Z, 1.0)
      IF (A(23) .GT. 0.5) GOTO 320
      IF (Z .GT. 0.25) J = J + 1
      IF (ABS(T - 1.0) .LE. 0.001) THEN
        DO 290 K = 1, MM
          D(K) = D(K) + A(I) * A(J)
          I = I + 2
          J = J + 2
  290   CONTINUE
        GOTO 380
      ENDIF
  300 DO 310 K = 1, MM
        D(K) = D(K) + T * A(I) * A(J)
        I = I + 2
        J = J + 2
  310 CONTINUE
      GOTO 380
  320 R = SIGN(1.0, P)
      S = SIGN(1.0, XQ)
      K = INT(12.0 * Z)
      V = SN(K + 1) * T
      U = SN(K + 4) * T
      KJ = INT(0.1 * A(KJ))
      IF (KJ .LT. 12) GOTO 360
      IF (ABS(V) .GT. 0.001) GOTO 360
      KI = INT(0.1 * A(KI))
      IF (KI .NE. 12) GOTO 350
      T = U
      IF (KJ .EQ. 12) GOTO 300
      IF (KJ .NE. 18) GOTO 360
      T = T * S
      J = J + 1
  330 DO 340 K = 1, MM
        E(K) = E(K) + T * A(I) * A(J)
        I = I + 2
        J = J + 2
  340 CONTINUE
      GOTO 380
  350 IF (KI .EQ. 18) THEN
        T = U * R
        I = I + 1
        IF (KJ .EQ. 12) GOTO 330
        T = -T * S
        J = J + 1
        IF (KJ .EQ. 18) GOTO 300
        J = J - 1
        I = I - 1
      ENDIF
  360 DO 370 K = 1, MM
        Y = R * A(I + 1)
        X = U * A(I) - V * Y
        Y = U * Y + V * A(I)
        Q = S * A(J + 1)
        D(K) = D(K) + X * A(J) - Y * Q
        E(K) = E(K) + X * Q + Y * A(J)
        I = I + 2
        J = J + 2
  370 CONTINUE
  380 IF (NZ .GT. 0) GOTO 260
  390 M = M + 2
      P = A(M)
      XQ = A(M + 1)
      T = ABS(P)
      Z = ABS(XQ)
      IF (NZ .EQ. 0) GOTO 270
      I = INT(T) * MH + ML
      J = INT(Z) * MH + ML
      IF (I .GT. ML) GOTO 280
      IF (J .GT. ML) THEN
        GOTO 440
      ELSE
        GOTO 630
      ENDIF
  400 IF (J  .EQ. NL) GOTO 630
      IF (NZ .EQ. 0) GOTO 440
      IF (MU .EQ. 0) GOTO 450
      MP = MP + 1
      IF (NZ .EQ. MT) GOTO 410
      IF (A(43) .LT. 1.E-6) GOTO 450
  410 IF (MP .NE. INT(G(NG))) GOTO 450
      N = INT(ABS(G(NG + 1))) * NM + NL
      K = INT(ABS(G(NG + 2))) * NM + NL
      L = INT(ABS(G(NG + 3))) * NM + NL
      IF (A(23) .LE. 0.5) THEN
        IF (AMOD(G(NG), 1.0) .GT. 0.25) N = N + 1
        DO 420 I = 1, NQ
          B(I) = B(I) + A(N) * A(K) * A(L)
          N = N + 2
          K = K + 2
          L = L + 2
  420   CONTINUE
      ELSE
        I = INT(12.0 * AMOD(G(NG), 1.0))
        Q = SN(I + 1)
        P = SN(I + 4)
        R = SIGN(1.0, G(NG + 1))
        S = SIGN(1.0, G(NG + 2))
        T = SIGN(1.0, G(NG + 3))
        DO 430 I = 1, NQ
          U = A(N) * A(K) - A(N + 1) * A(K + 1) * R * S
          V = A(N) * A(K + 1) * S + A(N + 1) * A(K) * R
          X = U * A(L) - V * A(L + 1) * T
          Y = U * A(L + 1) * T + V * A(L)
          B(I) = B(I) + P * X + Q * Y
          C(I) = C(I) - P * Y + Q * X
          N = N + 2
          K = K + 2
          L = L + 2
  430   CONTINUE
      ENDIF
      NG = NG + 4
      IF (NG .GE. 122) THEN
        READ (LG) G
        NG = 1
      ENDIF
      GOTO 410
  440 M  = M + 2
      Z  = A(M)
      RR = A(M + 1)
  450 L  = 4 * INT(XQ) + LX + 4
      K  = MU
      IF (L .GE. NB) MU = 1
      IF (K .EQ. 0) GOTO 260
      P = AMOD(A(L + 1), 10.0)
      IF (A(L + 1) .GE. 10.0) THEN
        Q = 0.261799 * AINT(0.1 * A(L + 1))
        U = COS(Q)
        V = SIN(Q)
        IF (NZ .LE. 0) THEN
          DO 460 K = 1, MM
            X    = D(K) * U + E(K) * V
            E(K) = X * V
            D(K) = X * U
  460     CONTINUE
        ELSE
          DO 470 K = 1, NQ
            X    = B(K) * U + C(K) * V
            Y    = D(K) * U + E(K) * V
            C(K) = X * V
            E(K) = Y * V
            B(K) = X * U
            D(K) = Y * U
  470     CONTINUE
        ENDIF
      ENDIF
      T = P * A(45)
      IF (NZ .GT. 0) Z = A(L + 3)
      ZG = 1.0 / (Z + 5.0)
      IF (NZ .EQ. 0) THEN
        GOTO 530
      ELSE IF (NZ .GT. 0) THEN
        GOTO 560
      ENDIF
      IF (IZ .GT. 0) GOTO 530
      IF (A(23) .GT. 0.5) GOTO 510
      DO 480 K = 1, MQ
        F(K) = F(K) + (Z - T * ABS(D(K)))**2
        D(K) = -1.E-6
  480 CONTINUE
      GOTO 390
  490 DO 500 K = 1, MM
        W = SIGN(P, D(K)) * MIN (1.0, D(K)**2 * RR)
        D(K) = -1.E-6
        A(J + 1) = -W
        A(J) = W
        J = J + 2
  500 CONTINUE
      GOTO 550
  510 DO 520 K = 1, MQ
        F(K) = F(K) + (Z - T * SQRT(D(K)**2 + E(K)**2))**2
        E(K) = 0.0
        D(K) = -1.E-6
  520 CONTINUE
      GOTO 390
  530 IF (A(23) .LT. 0.5) GOTO 490
      DO 540 K = 1, MM
        W = D(K)**2 + E(K)**2
        W = P * MIN (1.0, W * RR) / SQRT(W)
        A(J + 1) = W * E(K)
        E(K) = 0.0
        A(J) = W * D(K)
        D(K) = - 1.E-6
        J = J + 2
  540 CONTINUE
  550 IF (L .LT. NB) GOTO 390
      GOTO 630
  560 ZZ = (Z / T)**2
      ZT = ZZ
      IF (A(L + 1) .GT. 10.0) ZT = 9.E9
      IF (NZ .GE. MT) THEN
        IF (A(23) .LE. 0.5) THEN
          DO 570 K = 1, NQ
            W     = B(K) * D(K)
            FB(K) = FB(K) + W
            FC(K) = FC(K) + ABS(W)
            W     = T * ABS(D(K))
            FD(K) = FD(K) + ZG * (Z - W)**2
            FE(K) = FE(K) + W
  570     CONTINUE
        ELSE
          DO 580 K = 1, NQ
            FB(K) = FB(K) + B(K) * D(K) + C(K) * E(K)
            W     = SQRT(D(K)**2 + E(K)**2)
            FC(K) = FC(K) + W * SQRT(B(K)**2 + C(K)**2)
            FD(K) = FD(K) + ZG * (Z - W * T)**2
            FE(K) = FE(K) + W * T
  580     CONTINUE
        ENDIF
        IF (L .GT. NC) GOTO 610
      ENDIF
      IF (L .GT. NA) THEN
        IF (A(23) .GE. 0.5) THEN
          DO 590 K = 1, NQ
            U = D(K) - A(43) * B(K)
            V = E(K) - A(43) * C(K)
            W = U**2 + V**2
            X = D(K)**2 + E(K)**2
            IF (X .GE. ZT) THEN
              X = ZZ / X
              Y = SIGN(SQRT(ABS(1.0 -X)), B(K) * E(K) - D(K) * C(K))
              X = SQRT(X)
              U = D(K) * X - E(K) * Y
              V = E(K) * X + D(K) * Y
            ENDIF
            W = P / SQRT(W)
            A(J + 1) = W * V
            A(J) = W * U
            J = J + 2
  590     CONTINUE
        ELSE
          DO 600 K = 1, NQ
            W = SIGN(P, D(K) - A(43) * B(K))
            A(J + 1) = -W
            A(J)     =  W
            J        = J + 2
  600     CONTINUE
        ENDIF
      ENDIF
  610 DO 620 K = 1, NQ
        B(K) = 0.0
        C(K) = 0.0
        D(K) = -1.E-6
        E(K) = 0.0
  620 CONTINUE
      IF (NZ .EQ. MT) GOTO 260
      IF (L .LT. NC) GOTO 380
  630 IF (NZ .GT. 0) GOTO 230
      M  = LD + 2
      IZ = IZ - 1
      IF (IZ .GT. NZ) GOTO 390
      IF (NZ .EQ. 0) GOTO 240
      J = MS
  640 J = J + 4
      IF (J .LE. ME) THEN
        K = INT(A(J)) * MH + ML
        L = INT(ABS(A(J + 1))) * MH + ML
        M = INT(ABS(A(J + 2))) * MH + ML
        N = INT(ABS(A(J + 3))) * MH + ML
        IF (A(23) .LE. 0.5) THEN
          IF (AMOD(A(J), 1.0) .GT. 0.25) K = K + 1
          DO 650 I = 1, MQ
            E(I) = E(I) + A(K) * A(L) * A(M) * A(N)
            K = K + 2
            L = L + 2
            M = M + 2
            N = N + 2
  650     CONTINUE
          GOTO 640
        ENDIF
        I = INT(12.0 * AMOD(A(J), 1.0))
        Q = SN(I + 1)
        P = SN(I + 4)
        R = SIGN(1.0, A(J + 1))
        S = SIGN(1.0, A(J + 2))
        T = SIGN(1.0, A(J + 3))
        DO 660 I = 1, MQ
          U = A(K) * A(L) - A(K + 1) * A(L + 1) * R
          V = A(K) * A(L + 1) * R + A(K + 1) * A(L)
          X = U*A(M) - V * A(M + 1) * S
          Y = U*A(M + 1) * S + V * A(M)
          E(I) = E(I) + P * (X * A(N) - V * A(N + 1) * T)
     1         - Q * (Y * A(N + 1) * T + X * A(N))
          K = K + 2
          L = L + 2
          M = M + 2
          N = N + 2
  660   CONTINUE
        GOTO 640
      ENDIF
      J = 0
      Q = -9.E9
  670 DO 680 I = 1, NQ
        IF (PM(I) .GE. Q) THEN
          Q = PM(I)
          M = I
        ENDIF
  680 CONTINUE
  690 J = J + 1
      IF (J .LE. MQ) THEN
        P = F(J) / A(28)
        IF (WF .GT. 0.1) P = P + MAX (0.0, E(J) / WF + 0.25)**2
        F(J) = 0.0
        E(J) = 0.0
        IF (P .GT. Q) GOTO 690
        PM(M) = P
        PR(M) = G(J)
        Q     = P
        GOTO 670
      ENDIF
      PN = PN + 1.0
      IF (A(39) .GE. 0.0) THEN
        IF (Q .GE. 0.125) THEN
          IF (PN .LT. 5.0) GOTO 170
        ENDIF
      ENDIF
      MM = NQ
      DO 700 I = 1, NQ
        G(I) = PR(I)
  700 CONTINUE
      NZ = 0
      GOTO 190
  710 Q = 9.E9
      R = 0.0
      V = 0.0
      T = 0.0
      M = 0
      DO 720 K = 1, NQ
        D(K) = FB(K) / FC(K)
        E(K) = FE(K) / TS
        C(K) = FD(K) / TZ
        P    = C(K)
        IF (ABS(FC(K)) .GT. 0.001) P = P + MAX (0.0, D(K) - A(42))**2
        I = INT(MIN(31.5, 1.0 + 50.0 * P))
        ID(I) = ID(I) + 1
        IF (P .LE. Q) THEN
          Q = P
          R = C(K)
          S = D(K)
          W = PR(K)
          V = PM(K)
          T = E(K)
          M = K
        ENDIF
        B(K) = P
  720 CONTINUE
      IF (TN .GE. 0.8) THEN
        IF (A(40) .GT. 0.0) GOTO 750
      ENDIF
      DO 740 K = 1, NQ
        J = 1
        IR(1:1) = ' '
        IF (K .EQ. M) IR(1:1) = '*'
        L = K + K - 2 + NL
        N = ME
  730   N = N + 1
        IF (N .LE. NS) THEN
          I = INT(A(N)) * NM + L
          J = J + 1
          IR(J:J) = IH(13)
          IF (A(I) .LT. 0.0) IR(J:J) = IH(12)
          GOTO 730
        ENDIF
  740 CONTINUE
  750 M = M + M - 2 + NL
      K = 0
      J = 1
      IR(1:1) = ' '
      N = ME
  760 N = N + 1
      IF (N .LE. NS) THEN
        I = INT(A(N)) * NM + M
        J = J + 1
        IR(J:J) = IH(13)
        IF (A(I) .LT. 0.0) IR(J:J) = IH(12)
        GOTO 760
      ENDIF
      IF (PQ .GE. Q) THEN
        I = LX + 4
  770   I = I + 4
        IF (I .LE. NC) THEN
          M = M + NM
          U = -9.E9
          IF (ABS(A(M)) + ABS(A(M + 1)) .GT. 0.01) U =
     1        57.29578 * ATAN2(A(M + 1) * A(23), A(M))
          IF (U .LT. 0.0) U = U + 360.0
          A(I + 2) = U
          GOTO 770
        ENDIF
        PQ = Q
        PS = W
      ENDIF
      TN = TN + FLOAT(NQ)
      IF (TN .LT. A(39)) GOTO 160
      DO 780 I = 1, 31
        F(I) = FLOAT(I - 1) * 0.02
  780 CONTINUE
      F(32) = 9.999
      WRITE (LI, 99997) (F(I), F(I + 1), ID(I), I = 1, 31)
      IF (TN .LT. 1.1) TN = 1.1
      WRITE (LI, 99998) TN, PS, PQ
      K = 0
      I = NA
  790 M = 0
  800 I = I + 4
      IF (I .LE. NC) THEN
        K    = K + 1
        A(I) = ABS(A(I))
        IF (A(I + 2) .LT. - 8.E9) GOTO 800
        NA        = NA + 4
        P         = A(NA)
        A(NA)     = A(I)
        A(I)      = P
        P         = A(NA + 1)
        A(NA + 1) = A(I + 1)
        A(I  + 1) = P
        P         = A(NA + 2)
        A(NA + 2) = A(I + 2)
        A(I + 2)  = P
        CALL GEN046 (A(NA), X, Y, Z)
        M          = M + 1
        IP(M)      = K
        IP(M + 4)  = INT(X)
        IP(M + 8)  = INT(Y)
        IP(M + 12) = INT(Z)
        IP(M + 16) = INT(A(NA + 2) + 0.5)
        F(M) = AMOD(A(NA + 1), 10.0)
        Q = 0.0174533 * A(NA + 2)
        P = F(M) * COS(Q)
        Q = F(M) * SIN(Q)
        GOTO 790
      ENDIF
      IF (M .GT. 0) WRITE (LI, 99996) (IP(J), IP(J + 4),
     1 IP(J + 8), IP(J + 12), F(J), IP(J + 16), J = 1, M)
      M  = 0
      P  = 0.0
  810 LE = NA
      RETURN
99999 FORMAT (//, I4, ' NQR Included in Filter')
99998 FORMAT (//, F10.0, ' Phase Sets Refined - Best Solution is Code',
     1        F10.0, '  With CFOM =', F8.4)
99997 FORMAT (//, 'CFOM Range   Frequency', /,
     1        31(/F6.3, ' - ', F5.3, I7))
99996 FORMAT (4(I7, '.', 3I4, F6.3, I4))
      END
      SUBROUTINE PLA159
      PARAMETER (NP12=600,NP13=500,NP17=99,NPVD=40000000,NP23=18000,
     1 NPP=NPVD+2*NP23,NP38=125,NP39=30)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /SHX/ F(126), G(126), LR, LG, LH, LI, LP, LF, LA, LB,
     1 LY, LL, LQ, LE, LV, LX, LD, LZ, LJ, HKLF(11)
      COMMON // A(NPP)
      W  = 0.0
   10 NA = LE
      NZ = INT(A(54))
      IF (NZ .LT. 4) GOTO 240
      IF (NZ .EQ. 5) GOTO 240
      IF (NA .LE. LX - 4) GOTO 240
      NT    = LD + 4
      A(NT) = 0.0
      PQ    = 10.0
      NB    = LX + 4
      I     = NB
   20 I     = I + 4
      P     = AMOD (A(I + 1), 10.0)
      Q     = 1.74533E-2 * A(I + 2)
      A(I + 2) = P * COS(Q)
      A(I + 3) = P * SIN(Q)
      IF (I .LT. NA) GOTO 20
   30 IF (NT .LE. NPP - 6) THEN
        NQ = NT
        I  = NB
   40   I  = I + 4
        IF (I .LE. NA) THEN
          CALL GEN046 (A(I), X, Y, Z)
          DO 60 J = 65, LY, 12
            P = 6.283185 * (X * A(J + 9) + Y * A(J + 10)
     1        + Z * A(J + 11))
            U = COS(P)
            V = SIN(P)
            P = U * A(I + 2) + V * A(I + 3)
            Q = U * A(I + 3) - V * A(I + 2)
            W = AINT(1.001 * (X * A(J) + Y * A(J + 3) + Z * A(J + 6)))
     1        + 200.0 * (AINT(1.001 * (X * A(J + 1) + Y * A(J + 4)
     2        + Z * A(J + 7))) + 200.0 * AINT(1.001 * (X * A(J + 2)
     3        + Y * A(J + 5) + Z * A(J + 8))))
            IF (W .LT. 0.0) Q = - Q
            W = ABS(W)
            K = NQ
   50       K = K + 3
            IF (K .LE. NT) THEN
              IF (ABS(W - A(K)) .LT. 0.5) THEN
                GOTO 60
              ELSE
                GOTO 50
              ENDIF
            ENDIF
            NT    = NT + 3
            A(NT) = W
            A(NT + 1) = P
            A(NT + 2) = Q * A(23)
            IF (NT .GT. NPP - 6) GOTO 70
   60     CONTINUE
          NQ = NT
          GOTO 40
        ENDIF
   70   LZ    = NT + 3
        A(LZ) = 9.E9
        M     = (LZ - LD) / 3
   80   M     = M / 2
        IF (M .GT. 0) THEN
          N = M * 3
          K = LZ - N
          J = LD + 4
   90     I = J
  100     L = I + N
          IF (A(I) .GE. A(L)) THEN
            Q    = A(L)
            A(L) = A(I)
            A(I) = Q
            Q    = A(L + 1)
            A(L + 1) = A(I + 1)
            A(I + 1) = Q
            Q        = A(L + 2)
            A(L + 2) = A(I + 2)
            A(I + 2) = Q
            I = I - N
            IF (I .GT. LD + 4) GOTO 100
          ENDIF
          J = J + 3
          IF (J .GT. K) THEN
            GOTO 80
          ELSE
            GOTO 90
          ENDIF
        ENDIF
      ENDIF
  110 NB = NA
      S  = 0.0
      L  = NB
  120 L  = L + 4
      IF (L .LE. LD) THEN
        P = AMOD(A(L + 1), 10.0)
        U = 0.0
        V = 0.0
        Z = A(L) - 0.5
        Q = 1.0
        I = LD + 4
        K = I
        M = NT
  130   J = M
  140   M = K + 3 * ((J - K) / 6)
        IF (A(M) .GT. Z) GOTO 130
        K = M
        IF (J .GT. K + 3) GOTO 140
        Z = Z + 0.5
  150   I = I + 3
  160   IF (I .GT. J) GOTO 180
        X = Z - A(I) - A(J)
        IF (X .GT.   0.5) GOTO 150
        IF (X .LE. - 0.5) THEN
          J = J - 3
          GOTO 160
        ENDIF
  170   U = U + A(I + 1) * A(J + 1) - A(I + 2) * A(J + 2) * Q
        V = V + A(I + 1) * A(J + 2) + A(I + 2) * A(J + 1) * Q
        IF (Q .LT. 0.0) THEN
          GOTO 190
        ELSE
          GOTO 150
        ENDIF
  180   I = LD + 4
        J = M
        Q = -1.0
  190   I = I + 3
  200   X = Z + A(I) - A(J)
        IF (X .LT. -0.5) GOTO 190
        IF (X .LT.  0.5) GOTO 170
        J = J + 3
        IF (J .LT. LZ) GOTO 200
        IF (A(L + 1) .GE. 10.0) THEN
          W = 0.261799 * AINT(0.1 * A(L + 1))
          X = COS(W)
          W = SIN(W)
          V = X * U + W * V
          U = X * V
          V = W * V
        ENDIF
        W = SQRT(U * U + V * V)
        X = P * W * A(45)
        IF (S .LT. X) S = X
        IF (X .LT. PQ) GOTO 120
        NA = NA + 4
        Q = A(L)
        T = A(L + 1)
        J = L
  210   J = J - 4
        IF (J .GE. NA) THEN
          A(J + 4) = A(J)
          A(J + 5) = A(J + 1)
          GOTO 210
        ENDIF
        A(NA) = Q
        A(NA + 1) = T
        A(NA + 2) = P * U / W
        A(NA + 3) = P * V * A(23) / W
        IF (NA - NB .LT. 400) GOTO 120
      ENDIF
      PQ = PQ * 0.8
      IF (S .GE. 0.1) THEN
        IF (NA .NE. LD) THEN
          IF (NA .GT. NB) GOTO 30
          PQ = 0.8 * S
          GOTO 110
        ENDIF
      ENDIF
      I = (NA - LX - 4) / 4
      J = (LD - LX - 4) / 4
      P = ABS(A(26))
      I = LX + 4
  220 N = - 2
  230 I = I + 4
      IF (I .LE. NA) THEN
        N = N + 3
        F(N) = A(I)
        F(N + 1) = A(I + 2)
        F(N + 2) = A(I + 3)
        IF (N .LT. 124) GOTO 230
        WRITE (LA) F
        GOTO 220
      ENDIF
      N = N + 3
      F(N) = 0.0
      WRITE (LA) F
      CALL GEN108 (LA, 0)
      LE = - 1
  240 IF (NZ .EQ. 0) GOTO 650
      IF (ABS(A(55)) .LE. 0.5) THEN
        WP = 1.0
        IF (NZ .LT. 4) WP = 0.0
        XJ = A(2)
        YJ = A(3)
        ZJ = A(4)
        IX = 0
        IY = 0
        IZ = 0
        KP = 1
        IF (A(23) .GE. 0.5) THEN
          IF (NZ .LT. 4) KP = 2
        ENDIF
        ML = LY + 12
        DO 260 I = 1, 3
          J = I + 30
          DO 250 K = I, J, 6
            F(K)     = 9.E9
            F(K + 3) = 1.0
  250     CONTINUE
  260   CONTINUE
        DO 310 L = ML, LL, 4
          DO 300 N = 65, LY, 12
            W = A(L)
            DO 290 K = 1, KP
              WWP = W * WP
              X = AMOD(A(N +  9) * WWP + A(L + 1) + 0.501, 1.0) - 0.001
              Y = AMOD(A(N + 10) * WWP + A(L + 2) + 0.501, 1.0) - 0.001
              Z = AMOD(A(N + 11) * WWP + A(L + 3) + 0.501, 1.0) - 0.001
              IX = 9
              IF (MAX (ABS(A(N + 1)), ABS(A(N + 2))) .LE. 0.01) THEN
                IX = 1
                IF (ABS(X) .LE. 0.01) THEN
                  IF (A(N) * W .GE. 0.5) IX = 0
                ENDIF
              ENDIF
              IY = 9
              IF (MAX (ABS(A(N + 3)), ABS(A(N + 5))) .LE. 0.01) THEN
                IY = 1
                IF (ABS(Y) .LE. 0.01) THEN
                  IF (A(N + 4) * W .GE. 0.5) IY = 0
                ENDIF
              ENDIF
              IZ = 9
              IF (MAX (ABS(A(N + 6)), ABS(A(N + 7))) .LE. 0.01) THEN
                IZ = 1
                IF (ABS(Z) .LE. 0.01) THEN
                  IF (A(N + 8) * W .GE. 0.5) IZ = 0
                ENDIF
                IF (A(N + 8) * W .GE. 0.0) THEN
                  IF (IZ .NE. 0) THEN
                    IF (IX + IY .LT. 1) F(6) = MIN (F(6), Z)
                    IF (IX .LT. 1) F(12)     = MIN (F(12), Z)
                    IF (IY .LT. 1) F(18)     = MIN (F(18), Z)
                    IF (F(30) .GT. Z) F(30)  = Z
                  ENDIF
                  GOTO 270
                ENDIF
                IF (IX + IY .LT. 1) F(3) = MIN (F(3), Z)
                IF (IX .LT. 1) F(9)      = MIN (F(9), Z)
                IF (IY .LT. 1) F(15)     = MIN (F(15), Z)
                IF (F(27) .GT. Z) F(27)  = Z
              ENDIF
  270         IF (IY .LT. 2) THEN
                IF (A(N + 4) * W .GE. 0.0) THEN
                  IF (IY .NE. 0) THEN
                    IF (IX + IZ .LT. 1) F(11) = MIN (F(11), Y)
                    IF (IX .LT. 1)      F(5)  = MIN (F(5), Y)
                    IF (IZ .LT. 1)      F(35) = MIN (F(35), Y)
                    IF (F(17) .GT. Y)   F(17) = Y
                  ENDIF
                  GOTO 280
                ENDIF
                IF (IX + IZ .LT. 1) F(8)  = MIN (F(8), Y)
                IF (IX .LT. 1)      F(2)  = MIN (F(2), Y)
                IF (IZ .LT. 1)      F(32) = MIN (F(32), Y)
                IF (F(14) .GT. Y)   F(14) = Y
              ENDIF
  280         IF (IX .LT. 2) THEN
                IF (A(N) * W .GE. 0.0) THEN
                  IF (IX .NE. 0) THEN
                    IF (IY + IZ .LT. 1) F(16) = MIN (F(16), X)
                    IF (IY .LT. 1)      F(22) = MIN (F(22), X)
                    IF (IZ .LT. 1)      F(28) = MIN (F(28), X)
                    IF (F(4) .GT. X) F(4) = X
                  ENDIF
                ELSE
                  IF (IY + IZ .LT. 1) F(13) = MIN (F(13), X)
                  IF (IY .LT. 1)      F(19) = MIN (F(19), X)
                  IF (IZ .LT. 1)      F(25) = MIN (F(25), X)
                  IF (F(1) .GT. X)    F(1)  = X
                ENDIF
              ENDIF
              W = - W
  290       CONTINUE
  300     CONTINUE
  310   CONTINUE
        DO 320 I = 1, 27, 13
          F(I + 6) = F(I)
          F(I + 9) = F(I + 3)
  320   CONTINUE
        DO 330 I = 3, 13, 5
          F(I + 18) = F(I)
          F(I + 21) = F(I + 3)
  330   CONTINUE
        DO 350 I = 1, 31, 6
          J = I + 2
          DO 340 K = I, J
            F(K) = 0.5 * F(K)
            IF (F(K) .LT. 1.0) F(K + 3) = 0.5 * F(K + 3)
            IF (F(K) .GT. 1.0) F(K) = 0.0
  340     CONTINUE
  350   CONTINUE
        RE = 19.6 * A(1) / SQRT(A(64))
        U  = 9.E9
        DO 380 M = 1, 31, 6
          DO 370 N = 1, 3
            L = N
  360       K = 1
            IF (0.501 .LE. F(M + 5)) K = 2
            J = 1
            IF (0.501 .LE. F(M + 4)) J = 2
            V = FLOAT(J * K) * F(M + 3)
            IF (V .LE. U) THEN
              IF (U .GT. V + 0.01) W = 9.E9
              U = V + 0.001
              X = YJ * FLOAT(J) - RE
              Y = ZJ * FLOAT(K) - RE
              Z = X * X + Y * Y
              IF (Z .LE. W) THEN
                W = Z
                A(55) = FLOAT(L)
                IX = INT(100.01 * F(M + 1)) - J
                IY = INT(100.01 * F(M + 2)) - K
                IZ = J
                KP = K
                A(56) = INT(3.5 + 100.0 * F(M + 3) * XJ / RE)
                A(36) = F(M + 3) * 100.0 / (A(56) - 3.0)
                A(33) = 100.0 * F(M) - A(36)
              ENDIF
            ENDIF
            X  = YJ
            YJ = ZJ
            ZJ = X
            X        = F(M + 1)
            F(M + 1) = F(M + 2)
            F(M + 2) = X
            X        = F(M + 4)
            F(M + 4) = F(M + 5)
            F(M + 5) = X
            L        = -L
            IF (L .LT. 0) GOTO 360
            X  = XJ
            XJ = YJ
            YJ = ZJ
            ZJ = X
            X  = F(M)
            F(M)     = F(M + 1)
            F(M + 1) = F(M + 2)
            F(M + 2) = X
            X        = F(M + 3)
            F(M + 3) = F(M + 4)
            F(M + 4) = F(M + 5)
            F(M + 5) = X
  370     CONTINUE
  380   CONTINUE
        J = INT(A(55))
        K = INT(A(56))
        L = NZ
        IF (NZ .EQ. 2) L = 6
        A(34) = IX
        A(35) = IY
        A(37) = IZ
        A(38) = KP
      ENDIF
      IF (NZ .LT. 7) GOTO 650
      IF (LE .LT. 0) GOTO 650
      A(54) = A(54) - 1.0
      LZ = LD + 8
      MB = LZ + 1251
      NB = MB - 9
      RC = 0.0
      HM = 0.0
      S  = 27.0 * (A(57) - 5.0)
      R = S
      T = 0.0
      I = LV
  390 I = I + 8
      IF (I .LE. LD) THEN
        J = INT(A(I + 1) * 0.001) * 5 + LJ
        A(I + 6) = A(J)
        IF (I .LE. LX) THEN
          IF (HM .LT. A(J)) HM = A(J)
          R = R + A(I + 5) * A(J) * A(J)
        ENDIF
        GOTO 390
      ENDIF
  400 READ (LF) F
      DO 440 I = 1, 124, 3
        IF (F(I) .LT. 0.5) GOTO 450
        IF (F(I + 1) .GE. 0.0) THEN
          P = AMOD(F(I + 1), 10.0)
          IF (ABS(P**2 - 0.8) .GE. T) THEN
  410       IF (NB + 16 .GE. NPP) THEN
              T = T + 0.05
              J = MB
  420         J = J + 9
  430         IF (J .GT. NB) GOTO 410
              IF (ABS(A(NB + 5)**2 - 0.8) .GT. T) GOTO 420
              A(J + 4) = A(NB + 4)
              A(J + 5) = A(NB + 5)
              A(J + 6) = A(NB + 6)
              NB = NB - 9
              GOTO 430
            ENDIF
            NB        = NB + 9
            A(NB + 6) = F(I)
            A(NB + 5) = P
            A(NB + 4) = F(I + 2)
          ENDIF
        ENDIF
  440 CONTINUE
      GOTO 400
  450 CALL GEN108 (LF, 0)
      DO 480 I = MB, NB, 9
        CALL GEN046 (A(I + 6), X, Y, Z)
        A(I) = X
        A(I + 1) = Y
        A(I + 2) = Z
        Q = SQRT(X * X * A(14) + Y * Y * A(15) + Z * Z * A(16)
     1    + Y * Z * A(17) + X * Z * A(18) + X * Y * A(19)) / A(1)
        A(I +7)=47.0 * Q * SQRT(Q)
        T = S * (3.834 / (3.834 + A(I + 7)))**2
        J = LV
  460   J = J + 8
        IF (J .GT. LX) GOTO 470
        K = INT(A(J + 1) * 0.001) * 5 + LJ
        W = SQRT(A(K) * SQRT(A(K)))
        T = T + A(J + 5) * (W * A(K) / (W + A(I + 7)))**2
        GOTO 460
  470   P = A(I + 5)
        A(I + 8) = SQRT(R / T)
        P = P / A(I + 8)
        A(I + 3) = P
        RC = RC + P * P
        A(I + 5) = 0.0
        A(I + 6) = 0.0
  480 CONTINUE
      J = LZ
      DO 490 I = 1, 1251
        A(J) = SIN(6.283185E-3 * FLOAT(I - 1))
        J = J + 1
  490 CONTINUE
      IX = (LD - LX) / 16
      IZ = LV + 1
      NA = LD + 8
      KP = (LD - LV) / 8
      SM = 0.0
      IY = 0
  500 I  = NA
  510 I  = I - 8
      IF (I .LT. IZ) GOTO 600
      IF (A(I + 5) .EQ. 0.0) GOTO 510
      NK = -2
      DO 520 J = 65, LY, 12
        NK = NK + 3
        G(NK) = 1000.0 * (A(I + 2) * A(J) + A(I + 3) * A(J + 1)
     1        +  A(I + 4) * A(J + 2) + A(J + 9))
        G(NK + 1) = 1000.0 * (A(I + 2) * A(J + 3)
     1            + A(I + 3) * A(J + 4)
     2            + A(I + 4) * A(J + 5) + A(J + 10))
        G(NK + 2) = 1000.0 * (A(I + 2) * A(J + 6)
     1            + A(I + 3) * A(J + 7)
     2            + A(I + 4) * A(J + 8) + A(J + 11))
  520 CONTINUE
  530 RA = 0.0
      RB = 0.0
      X = G(1)
      Y = G(2)
      Z = G(3)
      W = SQRT(A(I + 6) * SQRT(A(I + 6)))
      T = W * A(I + 6) * A(I + 5) * A(24)
      IF (LY .EQ. 65) THEN
        DO 540 J = MB, NB, 9
          KZ = LZ + INT(AMOD(1000000.5 + A(J) * X + A(J + 1) * Y
     1       + A(J + 2) * Z, 1000.0))
          O = T / (W + A(J + 7))
          U = A(J + 5) - A(KZ + 250) * O
          V = A(J + 6) - A(KZ) * O * A(23)
          S = (V * V + U * U) / A(J + 4)
          RA = RA + S
          IF (IX .GE. IY) THEN
            A(J + 6) = V
            A(J + 5) = U
          ENDIF
          RB = RB + A(J + 3) * SQRT(S)
  540   CONTINUE
      ELSE
        XJ = G(4)
        YJ = G(5)
        ZJ = G(6)
        IF (LY .EQ. 77) THEN
          DO 550 J = MB, NB, 9
            KZ = LZ + INT(AMOD(1000000.5 + A(J) * X + A(J + 1) * Y
     1         + A(J + 2) * Z, 1000.0))
            KY = LZ + INT(AMOD(1000000.5 + A(J) * XJ + A(J + 1) * YJ
     1         + A(J + 2) * ZJ, 1000.0))
            O  = T / (W + A(J + 7))
            U  = A(J + 5) - O * (A(KZ + 250) + A(KY + 250))
            V  = A(J + 6) - A(23) * O * (A(KZ) + A(KY))
            S  = (V * V + U * U) / A(J + 4)
            RA = RA + S
            IF (IX .GE. IY) THEN
              A(J + 6) = V
              A(J + 5) = U
            ENDIF
            RB = RB + SQRT(S) * A(J + 3)
  550     CONTINUE
        ELSE IF (LY .EQ. 101) THEN
          XK = G(7)
          YK = G(8)
          ZK = G(9)
          XL = G(10)
          YL = G(11)
          ZL = G(12)
          DO 560 J = MB, NB, 9
            KZ = LZ + INT(AMOD(1000000.5 + A(J) * X  + A(J + 1) * Y
     1         + A(J + 2) * Z, 1000.0))
            KY = LZ + INT(AMOD(1000000.5 + A(J) * XJ + A(J + 1) * YJ
     1         + A(J + 2) * ZJ, 1000.0))
            KX = LZ + INT(AMOD(1000000.5 + A(J) * XK + A(J + 1) * YK
     1         + A(J + 2) * ZK, 1000.0))
            KW = LZ + INT(AMOD(1000000.5 + A(J) * XL + A(J + 1) * YL
     1         + A(J + 2) * ZL, 1000.0))
            O  = T / (W + A(J + 7))
            U  = A(J + 5) - O * (A(KZ + 250) + A(KY + 250)
     1         + A(KX + 250) + A(KW + 250))
            V  = A(J + 6) - A(23) * O * (A(KZ) + A(KY) + A(KX) + A(KW))
            S  = (V * V + U * U) / A(J + 4)
            RA = RA + S
            IF (IX .GE. IY) THEN
              A(J + 6) = V
              A(J + 5) = U
            ENDIF
            RB = RB + SQRT(S) * A(J + 3)
  560     CONTINUE
        ELSE
          DO 580 J = MB, NB, 9
            X = 0.0
            Y = 0.0
            DO 570 K = 1, NK, 3
              KZ = LZ + INT(AMOD(1000000.5 + A(J) * G(K)
     1           + A(J + 1) * G(K + 1) + A(J + 2) * G(K + 2), 1000.0))
              X  = X + A(KZ + 250)
              Y  = Y + A(KZ)
  570       CONTINUE
            O  = T / (W + A(J + 7))
            V  = A(J + 6) - Y * A(23) * O
            U  = A(J + 5) - X * O
            S  = (U * U + V * V) / A(J + 4)
            RA = RA + S
            IF (IX .GE. IY) THEN
              A(J + 6) = V
              A(J + 5) = U
            ENDIF
            RB = RB + SQRT(S) * A(J + 3)
  580     CONTINUE
        ENDIF
      ENDIF
      W = RB * RB / (RA * RC)
      IF (IY .LT. 0) THEN
        GOTO 590
      ELSE IF (IY .EQ. 0) THEN
        GOTO 510
      ENDIF
      IF (W .LT. SM) GOTO 510
      IY = -IY
      GOTO 530
  590 A(I + 5) = 0.0
      KP = KP - 1
      IX = IX - 1
      IY = - IY
      SM = W
  600 IF (IY .NE. IX + 1) THEN
        IF (IY .EQ. 0) THEN
          SM = W
          IZ = LX + 1
          DO 610 J = MB, NB, 9
            A(J + 5) = - A(J + 5)
            A(J + 6) = - A(J + 6)
  610     CONTINUE
        ENDIF
        IF (IX .GT. 0) THEN
          IF (I .GT. IZ - 1) GOTO 510
          IY = IX + 1
          GOTO 500
        ENDIF
      ENDIF
      I    = 1
      G(1) = -0.5
      G(2) = 0.8
      G(3) = -0.02
      G(4) = -0.5
      G(5) = 1.9
      G(6) = -0.02
      G(7) = 1.0
      G(8) = 2.4
      G(9) = -0.01
      X    = 0.0
      Y    = 0.0
      DO 620 J = MB, NB, 9
        X = X + A(J + 5) * A(J + 5) + A(J + 6) * A(J + 6)
        Y = Y + A(J + 3) * A(J + 3)
  620 CONTINUE
      X = SQRT(Y / X)
      DO 640 J = MB, NB, 9
        F(I) = A(J) + 200.0 * (A(J + 1) + 200.0 * A(J + 2))
        W = 1.0
        IF (HM .LE. 18.5) THEN
          U = A(14) * A(J) * A(J) + A(15) * A(J + 1) * A(J + 1) + A(16)
     1      * A(J + 2) * A(J + 2) + A(17) * A(J + 1) * A(J + 2)
     2      + A(18) * A(J) * A(J + 2) + A(19) * A(J) * A(J + 1)
          U = U * GL(8) / (A(1) * A(1))
          S = SQRT(U + U)
          DO 630 K = 1, 7, 3
            V = G(K + 1) * S
            W = W + G(K) * SIN(V) * EXP(U * G(K+2)) / V
  630     CONTINUE
          W = SQRT(W)
        ENDIF
        U = X * A(J + 5)
        V = X * A(J + 6)
        S = SQRT(U * U + V * V)
        O = SQRT(1.0 / A(J + 4))
        T = 100.0 * W * (2.0 * A(J + 3) * TANH(S * O * A(J + 3)
     1    * A(J + 8)**2) / S - O)
        IF (A(54) .GT. 6.5) T = T * A(J + 8)
        F(I + 1) = U * T
        F(I + 2) = V * T
        IF (I .GE. 124) THEN
          WRITE (LA) F
          I = -2
        ENDIF
        I = I + 3
  640 CONTINUE
      F(I) = 0.0
      WRITE (LA) F
      CALL GEN108 (LA, 0)
      S = SQRT(1.0 - SM)
      J = (NB - MB + 9) / 9
      I = NB + 8
      M  = 0
      P  = 0.0
  650 LE = 0
      I  = LV
  660 I  = I + 8
      IF (I .LE. LX) THEN
        J = INT(0.001 * A(I + 1)) * 5 + LJ
        A(I + 7) = (0.1 + A(J + 1))**2
        GOTO 660
      ENDIF
      IF (A(57) .LT. 0.0) LX = LV
      RR = 0.1
      IF (MAX (A(5), A(6), A(7)) .GT. 110.0) RR = 0.3
      NZ = INT(A(54))
      IF (NZ .EQ. 6) NZ = 4
      IF (NZ .GT. 6) NZ = 6
      LX = MIN (LX, LV)
      RR = 0.5
      LD = LX
      IF (NZ .EQ. 0) GOTO 990
      IF (ABS(A(57)) .LT. 0.5) GOTO 990
      TP        = A(LX + 6)
      A(LX + 6) = 9.E9
      MP        = (INT(ABS(A(57))) * 8) + LX
      A(MP + 6) = MAX (0.0, 0.7 * A(20))
      ML        = LY + 12
      NX = INT(A(56))
      LZ = MP + 16
      IF (LZ + 8600 .GT. NPP) GOTO 990
      NL = 0
      NH = LZ + 8134
      CALL GEN074 (A, 0.0, LZ, NH)
      MA = MAX (MIN (INT(ABS(A(55))), 3), 1)
      NS = LZ + 8427
      NA = NH - 3
      SS = 0.0
      ZZ = A(33)
      KP = 1
      NF = 1
      NG = 1
      WP = 1.0
  680 READ (LA) F
      I = - 2
  690 I = I + 3
      IF (I .GT. 124) GOTO 680
      IF (ABS(F(I)) .GE. 0.5) THEN
        S = F(I + 1) * F(I + 1) + F(I + 2) * F(I + 2)
        IF (S .LT. 1.E-10) GOTO 690
        U = SQRT(S)
        CALL GEN046 (F(I), X, Y, Z)
        EZ = 0.0
        L  = NA
        DO 720 K = 65, LY, 12
          P = AINT(1.001 * (X * A(K)+ Y * A(K + 3) + Z * A(K + 6)))
          Q = AINT(1.001 * (X * A(K + 1) + Y * A(K + 4) + Z * A(K + 7)))
          R = AINT(1.001 * (X * A(K + 2) + Y * A(K + 5) + Z * A(K + 8)))
          W = P + 200.0 * (Q + 200.0 * R)
          A(L + 7) = ABS(W)
          IF (ABS(W - F(I)) .LT. 0.5) EZ = EZ + 1.0
          IF (ABS(W + F(I)) .LT. 0.5 - A(23)) EZ = EZ + 1.0
          J = NA
  700     J = J + 4
          IF (J .LE. L) THEN
            IF (ABS(A(J + 3) - A(L + 7)) .LT. 0.5) THEN
              GOTO 720
            ELSE
              GOTO 700
            ENDIF
          ENDIF
          DO 710 J = 1, MA
            A(L + 4) = P
            P = Q
            Q = R
            R = A(L + 4)
  710     CONTINUE
          IF (A(55) .GE. 0.0) THEN
            T = P
            P = Q
            Q = T
          ENDIF
          IF (ABS(Q) .LE. 63.5) THEN
            T = 127.0 * P + Q
            IF (ABS(T) .LE. 8134.5) THEN
              M = INT(ABS(T) + 0.001) + LZ
              L = L + 4
              IF (NF .LE. 1) THEN
                A(M) = 1.1
                GOTO 720
              ENDIF
              A(L + 2) = 100.0 * (X * A(K + 9) + Y * A(K + 10)
     1                 + Z * A(K + 11))
              A(L + 1) = T
            ENDIF
          ENDIF
  720   CONTINUE
        IF (NF .EQ. 1) GOTO 690
        R = 0.0
        P = F(I + 1)
        K = NA
        T = SQRT(EZ)
        Q = F(I + 2)
        Q = Q * T
        P = P * T
  730   K = K + 4
        IF (K .GT. L) GOTO 690
        Y = SIGN(1.0, A(K + 1) + 0.1)
        X = Y * A(K)
        Z = Q * Y
        SS = SS + SQRT(P * P + Q * Q)
        T = ABS(A(K + 1)) + 0.001
        M = INT(T)+LZ
        N = INT(A(M))
        R = Y * A(K + 2)
        N = N * NH + NS
        A(N) = T
        S = 0.0628319 * (X * ZZ + R)
        O = SIN(S)
        S = COS(S)
        T = P * S + Z * O
        S = P * O - Z * S
        Z = 0.0628319 * X * A(36)
        W = COS(Z)
        Z = SIN(Z)
        M = N + 1
        DO 740 N = 3, NH, 2
          A(M) = A(M) + T
          A(M + 1) = A(M + 1) + S
          O = T * W - S * Z
          S = T * Z + S * W
          T = O
          M = M + 2
  740   CONTINUE
        GOTO 730
      ENDIF
      CALL GEN108 (LA, 0)
      IF (NF .EQ. 1) THEN
        NF = 2
        M  = 0
        DO 750 I = LZ, NH
          M = M + INT(A(I))
  750   CONTINUE
        IF (M .LE. 0) THEN
          WRITE (LI, 99999)
        ELSE
          NH = MIN (NX, ((NPP - NS) / M - 1) / 2)
          IF (NH .GE. NX) THEN
            NH = NH + NH + 1
            IF (NH .GT. 2) GOTO 760
          ENDIF
        ENDIF
        GOTO 990
  760   NL = NS + (NH * M)
        CALL GEN074 (A, 0.0, NS, NL)
        K = 0
        L = LZ + 8134
        DO 780 I = LZ, L
          IF (A(I) .GE. 0.5) THEN
            A(I) = FLOAT(K)
            K    = K + 1
          ENDIF
  780   CONTINUE
        GOTO 680
      ENDIF
      NC    = -1
      NB    = -1
      NA    = LZ
      G(NG) = -1.0
      NG    = 0
      EZ    = 9999.0
      A(44) = 0.0
      YM    = AMOD(A(34) + 1000.1, 100.0) - 0.1
      ZM    = AMOD(A(35) + 1000.1, 100.0) - 0.1
      A(NL) = 1000000.0
      SS    = 999.1 / SS
      DO 790 I = 1, 126
        G(I) = SIN(6.283185E-2 * FLOAT(I - 1))
  790 CONTINUE
      MS = NS + 1
  800 Z  = 0.0
      W  = 63.5
      NK = NA + 2808
      CALL GEN074 (A, 0.0, NA, NK)
      CALL GEN074 (F, 0.0, 1, 106)
      NK = MS
      DO 870 I = NS, NL, NH
        IF (W .LE. A(I)) THEN
          K = INT(AMOD(Z * A(38), 100.0))
          L = INT(AMOD(Z * ZM, 100.0))
          N = NA
          DO 830 J = 1, 53
            L = MOD(L, 100)
            W = G(L + 1)
            Z = G(L + 26)
            DO 820 M = 1, 53
              A(N) = A(N) + F(M) * Z + F(M + 53) * W
              N = N + 1
  820       CONTINUE
            L = L + K
  830     CONTINUE
          IF (I .EQ. NL) GOTO 860
          Z = AINT(A(I) / 127.0 + 0.5) + 0.0001
          W = 127.0 * Z + 63.5
          CALL GEN074 (F, 0.0, 1, 106)
        ENDIF
        U = AMOD(A(I) + 63.0, 127.0) + 37.0
        K = INT(AMOD (U * A(37), 100.0))
        L = INT(AMOD (U * YM, 100.0))
        U = A(NK) * SS
        V = A(NK + 1) * SS
        DO 850 J = 1, 53
          L = MOD(L, 100)
          F(J) = F(J) + U * G(L + 26) - V * G(L + 1)
          F(J + 53) = F(J + 53) - V * G(L + 26) - U * G(L + 1)
          L = L + K
  850   CONTINUE
  860   NK = NK + NH
  870 CONTINUE
      IF (NC .LT. 0) GOTO 980
      Z = A(35)
      DO 970 I = 53, 2703, 53
        Z = Z + A(38)
        Y = A(34)
        DO 960 K = 1, 51
          Y = Y + A(37)
          NK = I + K
          M = NK + NB
          IF (EZ .GT. A(M)) EZ = A(M)
          P = A(M)
          IF (P * 1.2 .LT. A(MP + 6)) GOTO 960
          IF (A(M - 1) .GT. P) GOTO 960
          IF (A(M + 1) .GT. P) GOTO 960
          IF (MAX (A(M - 54), A(M - 53), A(M - 52)) .GT. P) GOTO 960
          IF (MAX (A(M + 52), A(M + 53), A(M + 54)) .GT. P) GOTO 960
          L = NK + NC
          IF (MAX (A(L - 53), A(L - 1), A(L), A(L + 1),
     1        A(L + 53)) .GT. P) GOTO 960
          N = NK + NA
          IF (MAX (A(N - 53), A(N - 1), A(N), A(N + 1),
     1        A(N + 53)) .GT. P) GOTO 960
          Q = P + P
          U = A(L) - A(N)
          V = A(M - 1) - A(M + 1)
          W = A(M - 53) - A(M + 53)
          R = U / (A(N) + A(L) - Q)
          S = V / (A(M - 1) + A(M + 1) - Q)
          T = W / (A(M - 53) + A(M + 53) - Q)
          H = P - (U * R + V * S + W * T) * 0.0416667
          IF (H .GT. A(44)) A(44) = H
          IF (H .LT. A(20)) GOTO 960
          W= 0.01 * ZZ + A(36) * (0.005 * R - 0.01)
          V= 0.005 * (Y + Y + A(37) * S)
          U= 0.005 * (Z + Z + A(38) * T)
          IF (A(55) .GE. 0.0) THEN
            T = U
            U = V
            V = T
          ENDIF
          DO 880 NK = 1, MA
            T = W
            W = V
            V = U
            U = T
  880     CONTINUE
          SK = 0.0
          XS = 0.0
          YS = 0.0
          ZS = 0.0
          CS = 1.0
          DO 920 NK = 1, KP
            DO 910 L = 65, LY, 12
              XA = U * A(L) + V * A(L + 1) + W * A(L + 2)
     1           + WP * A(L + 9)
              YA = U * A(L + 3) + V * A(L + 4) + W * A(L + 5)
     1           + WP * A(L + 10)
              ZA = U * A(L + 6) + V * A(L + 7) + W * A(L + 8)
     1           + WP * A(L + 11)
              DO 900 M = ML, LL, 4
                O = CS * A(M) * XA + A(M + 1)
                P = CS * A(M) * YA + A(M + 2)
                Q = CS * A(M) * ZA + A(M + 3)
                N = LV
                R = AMOD(O - U, 1.0) - 0.5
                S = AMOD(P - V, 1.0) - 0.5
                T = AMOD(Q - W, 1.0) - 0.5
                IF (R * R * A(8) + S * S * A(9) + T * T * A(10)
     1            + S * T * A(11) + R * T * A(12)
     2            + R * S * A(13) .LE. RR) THEN
                  XS = XS + R + U
                  YS = YS + S + V
                  ZS = ZS + T + W
                  SK = SK + 1.0
                ENDIF
  890           N  = N + 8
                IF (N .LE. LD) THEN
                  R = AMOD(O - A(N + 2), 1.0) - 0.5
                  S = AMOD(P - A(N + 3), 1.0) - 0.5
                  T = AMOD(Q - A(N + 4), 1.0) - 0.5
                  YUNK = R * R * A(8) + S * S * A(9) + T * T * A(10)
     1                 + S * T * A(11) + R * T * A(12)
     2                 + R * S * A(13) - A(N + 7)
                  IF (YUNK .LT. 0.0) THEN
                    GOTO 960
                  ELSE
                    GOTO 890
                  ENDIF
                ENDIF
  900         CONTINUE
  910       CONTINUE
            CS = -1.0
  920     CONTINUE
          J  = LD + 8
          NK = J
  930     J  = J - 8
          IF (A(J + 6) .LT. H) GOTO 930
  940     NK = NK - 8
          IF (J .LT. NK) THEN
            N = NK + 7
            DO 950 L = NK, N
              A(L + 8) = A(L)
  950       CONTINUE
            GOTO 940
          ENDIF
          A(J + 8)  = 0.0
          A(J + 9)  = 1000.1
          SK        = 1.0 / SK
          A(J + 10) = XS * SK
          A(J + 11) = YS * SK
          A(J + 12) = ZS * SK
          A(J + 13) = SK
          A(J + 14) = H
          A(J + 15) = RR
          LD = MIN (LD + 8, MP)
  960   CONTINUE
  970 CONTINUE
  980 NC = NB
      NB = NA
      NA = NA + 2809
      IF (NA .GT. LZ + 8426) NA = LZ
      MS = MS + 2
      NG = NG + 1
      ZZ = ZZ + A(36)
      IF (NX .NE. NG) GOTO 800
      A(LX + 6) = TP
  990 IF (A(54) .GT. 6.5) GOTO 10
      I = LV
 1000 I = I + 8
      IF (I .LE. LD) THEN
        WRITE (LP, 99997) A(I + 2), A(I + 3), A(I + 4)
        GOTO 1000
      ENDIF
      WRITE (LP, 99998) (HKLF(I), I = 1, 11)
      RETURN
99999 FORMAT (/, '** No Data for Fourier', ///)
99998 FORMAT ('HKLF ', 2F6.2, 9F7.3, /, 'END ', //)
99997 FORMAT ('Q000 1', 3F8.4)
      END
      SUBROUTINE PLA160 (MODE, TM1)
C *******************************************************************
      PARAMETER (NP4=9,NP10=16,NP12=600,NP13=500,NP17=99,NP18=50,
     1 NPVD=40000000,NP22=256,NP23=18000,NP38=125,NP39=30,
     4 NCS=50, NZM = 200000, NRS = NPVD - 10 * NZM)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON // XYZDUM(2, NP23), RS(NRS), TNZ(NZM, 10)
      COMMON /FSPGR/ CRI(11), PNZ(13, 10), STLS(10)
      COMMON /DFSPGR/ SUM(NCS, 5), NUM(NCS, 5), XMFS(NCS), XTL(12),
     1 XNM(12), NNZ(13), ANZ(13), IR(3), IN(24), XN(48), FMN(12),
     2 ITL(12), AVNZ(3), NREF, IPERC, TRMX(3, 3), LU, ISPGRC, ISPGRA,
     3 ISPGRH, IPCNTC, IPCNTA, IPCNTH, IFRQC, IFRQA, IFRQH, RAVERC,
     4 RAVERA, RAVERH
      COMMON /LPLAT/ TLATT(9, NP18), XCELL(7, NP18), LLAUE(NP18),
     1 RVL(12, 3), NTL(12, 3), RVAL(NP18, 3), NRLT0, NRLT, NREXT,
     2 RMAX, AVIOS
      COMMON /SFCLC/ NATO, NNG(3), NGRID
      COMMON /PL138/ IHKLS(5, 48), PHIS(48), NSYM, NSYMH, MHK, MPH,
     1 ICNTR, IND1, IND2, IND3
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /CFSPGR/ EXT, ILAT0, ILAT1, LAUE
      CHARACTER EXT(NCS)*1, ILAT0*1, ILAT1*1, LAUE*5
      INTEGER HMAX
      DIMENSION TM1(3, 3), YPAR(107)
      COMMON /PLA22/ LGR(12), XSYST(8), IBVL(8), LAT(7)
      CHARACTER LGR*5, XSYST*12, IBVL*1, LAT*1
      COMMON /PAGENM/ PAGET, PAGEIND(25)
      CHARACTER PAGET*8, PAGEIND*8
      COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0
      COMMON /CGG11/ BCD, SBCD
      CHARACTER BCD*132, SBCD*132
      COMMON /CGGT/ IGGT
      CHARACTER IGGT*80
      COMMON /DSPGR/ TYPE, NLAUE
      CHARACTER TYPE(NCS)*16, NLAUE(13)*5
      COMMON /LPLATC/ BLATT(NP18), CLATT(NP18)
      CHARACTER BLATT*1, CLATT*1
      LH      = 0
      LK      = 0
      LL      = 0
      JH      = 0
      JK      = 0
      JL      = 0
      IND1    = 1
      IND2    = 2
      IND3    = 3
      HMAX    = 0
      STLM    = 0.0
      LTNR    = 0
      KMAX    = 0
      LMAX    = 0
      IUNIT   = 0
      IPCNTC  = 0
      IPCNTA  = 0
      IPCNTH  = 0
      IFRQC   = 0
      IFRQA   = 0
      IFRQH   = 0
      ISPGRC  = 0
      ISPGRA  = 0
      ISPGRH  = 0
      RAVERC  = 100.0
      RAVERA  = 100.0
      RAVERH  = 100.0
      CRI(11) = PAR(141)
       IWIN = IGBL(25) * IGBL(32)
C * FSPGR - DETERMINE SPACEGROUP FROM OBSERVED DATA
      IF (MODE .EQ. 1) THEN
        RMAX  = PAR(430)
        PAGET = 'SPGRfrEx'
        CALL PLA269 (-2)
        STLM = SIN (PAR(419) / GL(5)) / PAR(17)
        WRITE (LU7, 99985) JID(1:9)
        WRITE (LU6, 99985) JID(1:9)
C * NEWSYM : FIND SPACEGROUP (POSSIBLE HIGHER SYMMETRY)
      ELSE IF (MODE .EQ. 2) THEN
        RMAX = PAR(429)
        IF (IWIN .EQ. 1) THEN
          BCD  = 'NewSym'//CHAR(0)
          CALL GGIP (HORS, VERT, 0.0, 1)
          CALL GGIP20 (0.0,  BCD, 7, 1.4, 4, 8, 9.6, VERT - 1.8)
          CALL GGIP20 (0.0,  BCD, 7, 1.4, 2, 8, 9.4, VERT - 1.9)
          CALL GGIP (0.0, 0.0, 0.0, 6)
          VRT = VERT - 5.5
          CALL GEN038 (PRBUF, 1, 80)
        ENDIF
        PAGET = 'NEWSYM'
        CALL PLA269 (0)
        STLM = 0.0
        WRITE (LU7, 99986) PAR(248), JID(1:9)
        WRITE (LU6, 99986) PAR(248), JID(1:9)
        LTNR  = IPR(241)
        NSYM  = IPR(48)
        NSYMH = IPR(255)
        ICNTR = IPR(257)
        CALL PLA130 (NATO, 0)
        IF (NATO .LT. 0) THEN
          WRITE (LU6, 99998)
          GOTO 310
        ENDIF
        HMAX = INT(4 * PAR(101) / 3)
        KMAX = INT(4 * PAR(102) / 3)
        LMAX = INT(4 * PAR(103) / 3)
        MPH  = 2 * HMAX + 1
        MPK  = 2 * KMAX + 1
        MHK  = MPH * MPK
      ENDIF
      IMODE = IPR(365)
      IF (IMODE .EQ. 0) IMODE = 3
      IF (IMODE .NE. 2) THEN
        CALL PLA169 (0, 0, 0, 0.0, LU6)
        CALL PLA162 (0, 0, 0, 0, 0, 0.0, 0.0, IDUM)
      ENDIF
      IF (IMODE .GT. 1) THEN
        DO 20 I = 1, 12
          NNZ(I) = 0
          ANZ(I) = 0.0
          DO 10 J = 1, 10
            IF (I .EQ. 12) THEN
              VAL = (1.0 - EXP(- J * 0.1)) * 100.0
            ELSE
              VAL = 0.0
            ENDIF
            PNZ(I, J) = VAL
   10     CONTINUE
   20   CONTINUE
      ENDIF
      NREF = 0
      OPEN (UNIT = LU8, STATUS = 'SCRATCH', FORM = 'UNFORMATTED')
      IF (MODE .EQ. 2) GOTO 60
      SCALE = 100.0
      IEND = -1
   30 CALL PLA132 (JH, JK, JL, RINT, RSIG, CALI, UCINT, ACALS, BCALS,
     1             ACOR, IEND)
      IF (IEND .EQ. 1) GOTO 40
      IF (RINT .LT. 999999.0) GOTO 30
      SCALE = 1.0
   40 IUNIT = NINT(GEN120 (TM1))
      IEND = -1
   50 CALL PLA132 (JH, JK, JL, RINT, RSIG, CALI, UCINT, ACALS, BCALS,
     1             ACOR, IEND)
      IF (IEND .EQ. 1) GOTO 140
      IF (IUNIT .NE. 1) THEN
        IH = JH
        IK = JK
        IL = JL
        IF (GEN050 (TM1, IH, IK, IL, JH, JK, JL) .LT. 0.0) GOTO 50
      ENDIF
      IF (JH .EQ. 0 .AND. JK .EQ. 0 .AND. JL .EQ. 0) GOTO 140
      IX = NINT(MAX(0.0, RINT * SCALE))
      IF (RSIG .LE. 0.0) RSIG = 0.5
      IS = NINT(RSIG * SCALE)
      GOTO 100
   60 JH = - HMAX -1
   70 JH = JH + 1
      IF (JH .GT. HMAX) THEN
        CALL GGIP20 (0.0, PRBUF, 20, 0.8, 0, 2, 7.0, VRT)
        GOTO 140
      ENDIF
      JK = - KMAX - 1
   80 JK = JK + 1
      IF (JK .GT. KMAX) GOTO 70
      JL = - 1
   90 JL = JL + 1
      IF (JL .GT. LMAX) GOTO 80
      IF (JH .EQ. 0 .AND. JK .EQ. 0 .AND. JL .EQ. 0) GOTO 90
      IF (LTNR .GT. 1) THEN
        IF (GEN049 (LAT(LTNR), JH, JK, JL) .LT. 0.0) GOTO 90
      ENDIF
      CALL PLA139 (JH, JK, JL, IEXT, IASM)
      IF (IEXT .NE. 0) GOTO 90
  100 STLK = GEN095 (PAR(191), JH, JK, JL)
      STL  = SQRT(STLK)
        FSC = 1.0
      IF (MODE .EQ. 2) THEN
        IF (STL .LT. PAR(248)) THEN
          ACAL = 0.0
          BCAL = 0.0
          CALL PLA131 (JH, JK, JL, ACAL, BCAL, ACALA, BCALA, DUM)
          IX   = MIN (999999999, NINT(100.0 * (ACAL**2 + BCAL**2)))
          IS   = MAX (1, NINT(SQRT(FLOAT(IX))))
        ELSE
          GOTO 90
        ENDIF
      ENDIF
      IF (IMODE .NE. 2) CALL PLA169 (1, IX, IS, STL, LU6)
      IF (STL .GT. STLM) THEN
        XI = IX
        SI = IS
        WRITE (LU8) JH, JK, JL, XI, SI, FSC, STL
        NREF = NREF + 1
        IF (IMODE .GT. 1) THEN
          IF (JH .NE. 0 .AND. JK .NE. 0 .AND. JL .NE. 0) THEN
            DO 120 I = 1, 10
              IF (STL .LE. STLS(I)) THEN
                NNZ(I)         = NNZ(I) + 1
                IF (NNZ(I) .LE. NZM) THEN
                  TNZ(NNZ(I), I) = XI
                  ANZ(I)         = ANZ(I) + XI
                  NNZ(11)        = NNZ(11) + 1
                ELSE IF (NNZ(I) .EQ. NZM) THEN
                  WRITE (LU6, 99987)
                  STOP
                ENDIF
                GOTO 130
              ENDIF
  120       CONTINUE
  130       CONTINUE
          ENDIF
        ENDIF
        IF (IMODE .NE. 2) THEN
          IF (SI .GT. 0.0) THEN
            XISI = XI / SI
          ELSE
            XISI = 0.0
          ENDIF
          CALL PLA161 (0, JH, JK, JL, XISI, FSC)
        ENDIF
      ENDIF
      IF (MODE .EQ. 1) THEN
        GOTO 50
      ELSE
        IF (MOD(NREF, 1000) .EQ. 0) THEN
          CALL GGIP20 (0.0, PRBUF, 20, 0.8, 0, 2, 7.0, VRT)
          WRITE (PRBUF, 99983) NREF
          CALL GGIP20 (0.0, PRBUF, 20, 0.8, 1, 2, 7.0, VRT)
          CALL GGIP (0.0, 0.0, 0.0, 6)
        ENDIF
        GOTO 90
      ENDIF
  140 IF (IMODE .NE. 2) THEN
        CALL PLA169 (-1, 0, 0, 0.0, LU6)
        IF (IPR(210) .NE. -3) THEN
          CALL PLA169 (-2, 0, 0, 0.0, LU6)
          CALL PLA169 (-2, 0, 0, 0.0, LU7)
        ENDIF
        CALL PLA162 (-1, 0, 0, 0, 0, 0.0, 0.0, NR)
        IF (NR .GT. 0) THEN
          NXCT = 0
        ELSE
          NXCT = 1
          NR   = - NR
        ENDIF
        IPR(94) = 2
        IAPPEND = 0
        IF (IMODE .EQ. 1 .AND. NR .NE. 1 .AND. NXCT .NE. 0) THEN
          CALL PLA164 (IMODE, 0, LAT(1), TM1, PAR(383))
          IAPPEND = 1
        ENDIF
        CALL PLA164 (IMODE, IAPPEND, LAT(NR), TM1, PAR(383))
        LRET0  = 0
        ISPR47 = 0
        REWIND LU2
        IF (IPR(548) .EQ. 0)
     1   CALL PLA171 (LRET0, TM1, LU2, ISPR47, YPAR, 0)
      ELSE
        CALL GEN021 (TRMX, 1)
        WRITE (LU2, 99999) ((TM1(I, J), J = 1, 3), I = 1, 3), ILAT0
        CALL PLA167
      ENDIF
      IF (IMODE .GT. 1) THEN
        CALL GEN074 (AVNZ, 0.0, 1, 3)
        NZMX = 10
        ANZM = 0.0
        DO 160 I = 1, NZMX
          IF (NNZ(I) .GT. 0) THEN
            ANZ(I) = ANZ(I) / NNZ(I)
            ANZM   = MAX (ANZ(I), ANZM)
          ELSE
            NZMX   = I - 1
            GOTO 170
          ENDIF
  160   CONTINUE
  170   DO 200 I = 1, NZMX
          DO 190 J = 1, 10
            XANZ = J * 0.1 * ANZ(I)
            NZ   = 0
            DO 180 K = 1, NNZ(I)
              IF (K .GT. NZM) THEN
                WRITE (LU6, 99987)
                STOP
              ENDIF
              IF (TNZ(K, I) .LE. XANZ) NZ = NZ + 1
  180       CONTINUE
            PNZ(I, J) = FLOAT(NZ) * 100.0 / FLOAT(NNZ(I))
  190     CONTINUE
  200   CONTINUE
        IAE = MIN (6, NZMX)
        IAB = MIN (3, IAE)
        IAT = IAE - IAB + 1
        DO 220 J = 1, 10
          AVER = 0
          IF (IAB .GT. 0) THEN
            DO 210 I = IAB, IAE
              AVER = AVER + PNZ(I, J)
  210       CONTINUE
          ENDIF
          PNZ(11, J) = AVER / IAT
  220   CONTINUE
        WRITE (LU7, 99994)
        IF (ANZM .NE. 0.0) THEN
          DO 230 I = 1, 10
            WRITE (LU7, 99993) I, (PNZ(I, J), J = 1, 10),
     1                           NNZ(I), ANZ(I) * 1000.0 / ANZM
  230     CONTINUE
        ENDIF
        WRITE (LU7, 99992) (0.1 * J, J = 1, 10), IAB, IAE,
     1    (PNZ(11, J), J = 1, 10),
     2    (PNZ(12, J), J = 1, 10),
     3    (PNZ(13, J), J = 1, 10)
        DO 250 I = 11, 13
          DO 240 J = 1, 10
            PNZ(I, J) = PNZ(I, J) - 0.1 * J * PNZ(I, 10)
  240     CONTINUE
  250   CONTINUE
        DO 270 I = 11, 13
          DO 260 J = 1, 10
            PNZ(I, J) = PNZ(I, J) - PNZ(12, J)
            AVNZ(I - 10) = AVNZ(I - 10) + PNZ(I, J)
  260     CONTINUE
  270   CONTINUE
        IPERC = NINT(100.0 * AVNZ(1) / AVNZ(3))
        WRITE (LU7, 99991) IPERC
        WRITE (LU7, 99992) (0.1 * J, J = 1, 10), IAB, IAE,
     1    (PNZ(11, J), J = 1, 10),
     2    (PNZ(12, J), J = 1, 10),
     3    (PNZ(13, J), J = 1, 10)
      ENDIF
      IF (IMODE .GT. 1) THEN
        CALL PLA162 (0, 0, 0, 0, 0, 0.0, 0.0, IDUM)
        IF (IMODE .EQ. 3) THEN
          K = 0
          DO 5401 I = 1, 3
            DO 5402 J = 1, 3
              K = K + 1
              TRMX (I, J) = TLATT (K, NRLT)
 5402       CONTINUE
 5401     CONTINUE
          LAUE = NLAUE(LLAUE(NRLT))
          ILAT0 = CLATT(NRLT)
          ILAT1 = BLATT(NRLT)
        ENDIF
        CALL GEN108 (LU8, 0)
        DO 280 NRF = 1, NREF
          READ (LU8) KH, KK, KL, XI, SI, FSC, STL
          IF (GEN050 (TRMX, KH, KK, KL, LH, LK, LL) .GE. 0.0) THEN
            IF (LL .LT. 0) THEN
              IH = - LH
              IK = - LK
              IL = - LL
            ELSE IF (LL .EQ. 0) THEN
              IL = 0
              IF (LK .LT. 0) THEN
                IK = - LK
                IH = - LH
              ELSE IF (LK .EQ. 0) THEN
                IK = 0
                IH = IABS(LH)
              ELSE
                IK = LK
                IH = LH
              ENDIF
            ELSE
              IH = LH
              IK = LK
              IL = LL
            ENDIF
            IF (SI .GT. 0.0) THEN
              XISI = XI / SI
            ELSE
              XISI = 0.0
            ENDIF
            CALL PLA161 (1, IH, IK, IL, XISI, FSC)
          ENDIF
  280   CONTINUE
        CALL PLA162 (-2, 0, 0, 0, 0, 0.0, 0.0, LATT)
        IF (IPR(548) .EQ. 0) THEN
          M = 2 + IWIN
        ELSE
          M = 2
        ENDIF
        DO 300 N = 1, M
          IF (N .EQ. 1) THEN
            LU = LU6
          ELSE IF (N .EQ. 2) THEN
            LU = LU7
          ELSE
            LU = 0
          ENDIF
  290     WRITE (PRBUF, 99990) ((TRMX(I, J), J = 1, 3), I = 1, 3)
          IF (LU .GT. 0) THEN
            IF (LU .EQ. LU7) CALL PLA269 (0)
            WRITE (LU, 99997)
            WRITE (LU, 99995)
            WRITE (LU, 99989) PRBUF(1:80)
          ELSE
            CALL GGIP (HORS, VERT, 0.0, 1)
            VRT = VERT - 1.0
            CALL GGIP20 (0.0, PRBUF, 80, 0.35, 1, 2, 0.1, VRT)
          ENDIF
          WRITE (PRBUF, 99988)
          IF (LU .GT. 0) THEN
            WRITE (LU, 99984) PRBUF(1:80)
          ELSE
            VRT = VRT - 1.0
            CALL GGIP20 (0.0, PRBUF, 80, 0.35, 5 + IGBL(68), 2, 0.1,
     1                   VRT)
          ENDIF
          CALL PLA168
          IF (LU .EQ. LU7)
     1      WRITE (LU2, 99982) ISPGRC, ISPGRA, ISPGRH, IPCNTC
          IF (LU .EQ. 0) THEN
            CALL PLA015 (0, 39)
            CALL PLA013 (2, 1)
            IF (IGGT(1:4) .EQ. 'PLOT') GOTO 290
          ENDIF
  300   CONTINUE
      ENDIF
  310 IF (IPR(2) .EQ. 0) IPR(2) = -1
      CLOSE (LU8)
      RETURN
99999 FORMAT ('TRMX ', 9F7.3, 1X, A)
99998 FORMAT (/, ':: No Atoms Found on Input. Abort', /)
99997 FORMAT (/, 'Tentative Space Group Assignment - ',
     1 '(Please Check Carefully)', /, 80('='), /)
99995 FORMAT (':: NOTE: Space Group Determination Pitfalls:', /,
     1         '         - Twinning, Pseudo-Symmetry, Mult.Refl.')
99994 FORMAT (/, 'Nz-Test Statistics', /, 18('='))
99993 FORMAT ('Shell', I2, 10F6.2, I6, F7.1)
99992 FORMAT (/, '   z ->', 10F6.1, /, 'Av', I1, ':', I2, 1X, 10F6.2,
     1        /, 'NonCent', 10F6.2, /, 'CentroS', 10F6.2)
99991 FORMAT (/, 'Normalized N(z) curves (', I3, ' Percent Centric)',
     1        /, 43('='))
99990 FORMAT ('Candidate Space Groups in (',
     1         3F5.2, '/', 3F5.2, '/', 3F5.2, ') Cell')
99989 FORMAT (/, A, /, 80('='), /)
99988 FORMAT ('Name      #  AbsFreq',
     1        ' StandSet.     R(av)Perc. N  A/C-Prob')
99987 FORMAT (':: Increase NZM in FSPGR', //)
99986 FORMAT ('NEWSYM - Determine Symmetry from F(calc) data',
     1 '(Resol = ', F5.2, ') for: ', A, /, 80('='))
99985 FORMAT ('SPGR - Determine SpaceGroup from Observed ',
     1 'Extinctions for: ', A, /, 80('='))
99984 FORMAT (A, /, 80('-'))
99983 FORMAT ('REFL No =', I8)
99982 FORMAT ('SGNR', 4I5)
      END
      SUBROUTINE PLA161 (MODE, IH, IK, IL, XISI, FSC)
      CALL PLA162 (1, IH, IK, IL, MOD(IH + IK, 2), XISI, FSC, IDUM)
      CALL PLA162 (2, IH, IK, IL, MOD(IH + IL, 2), XISI, FSC, IDUM)
      CALL PLA162 (3, IH, IK, IL, MOD(IK + IL, 2), XISI, FSC, IDUM)
      CALL PLA162 (4, IH, IK, IL, MOD(IH + IK + IL, 2), XISI, FSC,
     1                IDUM)
      CALL PLA162 (5, IH, IK, IL, MOD(- IH + IK + IL, 3), XISI,
     1                FSC, IDUM)
      CALL PLA162 (6, IH, IK, IL, MOD(IH - IK + IL, 3), XISI,
     1                FSC, IDUM)
      CALL PLA162 (41, IH, IK, IL, MOD(IH, 2), XISI, FSC, IDUM)
      CALL PLA162 (42, IH, IK, IL, MOD(IK, 2), XISI, FSC, IDUM)
      CALL PLA162 (43, IH, IK, IL, MOD(IL, 2), XISI, FSC, IDUM)
      CALL PLA162 (44, IH, IK, IL, MOD(IH, 3), XISI, FSC, IDUM)
      CALL PLA162 (45, IH, IK, IL, MOD(IK, 3), XISI, FSC, IDUM)
      CALL PLA162 (46, IH, IK, IL, MOD(IL, 3), XISI, FSC, IDUM)
      IF (MOD(-IH + IK + IL, 3) .EQ. 0 .OR.
     1    MOD( IH - IK + IL, 3) .EQ. 0) THEN
        MODRTWIN = 0
      ELSE
        MODRTWIN = 1
      ENDIF
      CALL PLA162 (47, IH, IK, IL, MODRTWIN  , XISI, FSC, IDUM)
      IF (MOD (IK, 2) .EQ. 0 .AND. MOD (IK + IL, 4) .EQ. 2) THEN
        MODRTWIN = 1
      ELSE
        MODRTWIN = 0
      ENDIF
      CALL PLA162 (48, IH, IK, IL, MODRTWIN  , XISI, FSC, IDUM)
      IF (MOD (IH, 2) .EQ. 0 .AND. MOD (IH + IL, 4) .EQ. 2) THEN
        MODRTWIN = 1
      ELSE
        MODRTWIN = 0
      ENDIF
      CALL PLA162 (49, IH, IK, IL, MODRTWIN  , XISI, FSC, IDUM)
      IF (MOD (IH, 2) .EQ. 0 .AND. MOD (IH + IK, 4) .EQ. 2) THEN
        MODRTWIN = 1
      ELSE
        MODRTWIN = 0
      ENDIF
      CALL PLA162 (50, IH, IK, IL, MODRTWIN  , XISI, FSC, IDUM)
      IF (MODE .NE. 0) THEN
        IF (IH .EQ. 0) THEN
          CALL PLA162 (7, IH, IK, IL, MOD(IK, 2), XISI, FSC, IDUM)
          CALL PLA162 (8, IH, IK, IL, MOD(IL, 2), XISI, FSC, IDUM)
          CALL PLA162 (9, IH, IK, IL, MOD(IK + IL, 2), XISI, FSC,
     1                  IDUM)
          CALL PLA162 (19, IH, IK, IL, MOD(IK + IL, 4), XISI, FSC,
     1                  IDUM)
          IF (IK .EQ. 0) THEN
            CALL PLA162 (10, IH, IK, IL, 0, XISI, FSC, IDUM)
            CALL PLA162 (11, IH, IK, IL, MOD(IL, 2), XISI, FSC, IDUM)
            CALL PLA162 (12, IH, IK, IL, MOD(IL, 2), XISI, FSC, IDUM)
            CALL PLA162 (18, IH, IK, IL, MOD(IL, 2), XISI, FSC, IDUM)
            CALL PLA162 (20, IH, IK, IL, MOD(IL, 4), XISI, FSC, IDUM)
            CALL PLA162 (24, IH, IK, IL, MOD(IL, 4), XISI, FSC, IDUM)
            CALL PLA162 (31, IH, IK, IL, MOD(IL, 6), XISI, FSC, IDUM)
            CALL PLA162 (39, IH, IK, IL, MOD(IL, 3), XISI, FSC, IDUM)
          ELSE IF (IL .EQ. 0) THEN
            CALL PLA162 (14, IH, IK, IL, MOD(IK, 2), XISI, FSC, IDUM)
            CALL PLA162 (15, IH, IK, IL, MOD(IK, 2), XISI, FSC, IDUM)
            CALL PLA162 (17, IH, IK, IL, MOD(IK, 2), XISI, FSC, IDUM)
            CALL PLA162 (21, IH, IK, IL, MOD(IK, 4), XISI, FSC, IDUM)
            CALL PLA162 (23, IH, IK, IL, MOD(IK, 4), XISI, FSC, IDUM)
          ENDIF
        ELSE IF (IK .EQ. 0) THEN
          CALL PLA162 (10, IH, IK, IL, MOD(IH, 2), XISI, FSC, IDUM)
          CALL PLA162 (11, IH, IK, IL, MOD(IL, 2), XISI, FSC, IDUM)
          CALL PLA162 (12, IH, IK, IL, MOD(IH + IL, 2), XISI, FSC,
     1                  IDUM)
          CALL PLA162 (20, IH, IK, IL, MOD(IH + IL, 4), XISI, FSC,
     1                  IDUM)
          IF (IL .EQ. 0) THEN
            CALL PLA162 (14, IH, IH, IL, 0, XISI, FSC, IDUM)
            CALL PLA162 (16, IH, IK, IL, MOD(IH, 2), XISI, FSC, IDUM)
            CALL PLA162 (22, IH, IK, IL, MOD(IH, 4), XISI, FSC, IDUM)
          ENDIF
        ELSE IF (IL .EQ. 0) THEN
          CALL PLA162 (13, IH, IK, IL, MOD(IH, 2), XISI, FSC, IDUM)
          CALL PLA162 (14, IH, IK, IL, MOD(IK, 2), XISI, FSC, IDUM)
          CALL PLA162 (15, IH, IK, IL, MOD(IH + IK, 2), XISI, FSC,
     1                  IDUM)
          CALL PLA162 (21, IH, IK, IL, MOD(IH + IK, 4), XISI, FSC,
     1                  IDUM)
          IF (IH .EQ. IK) THEN
            CALL PLA162 (32, IH, IK, IL, MOD(IH, 2), XISI, FSC, IDUM)
          ENDIF
        ELSE IF (IH .EQ. IK) THEN
          CALL PLA162 (25, IH, IK, IL, MOD(IL, 2), XISI, FSC, IDUM)
          CALL PLA162 (26, IH, IK, IL, MOD(IH, 2), XISI, FSC, IDUM)
          CALL PLA162 (27, IH, IK, IL, MOD(IH + IL, 2), XISI, FSC,
     1                  IDUM)
          CALL PLA162 (28, IH, IK, IL, MOD(2 * IH + IL, 4), XISI,
     1                  FSC, IDUM)
          CALL PLA162 (34, IH, IK, IL, MOD(IL, 3), XISI, FSC, IDUM)
        ELSE IF (IH .EQ. -IK .AND. IH .NE. 0) THEN
          CALL PLA162 (29, IH, IK, IL, MOD(IH + IL, 3), XISI, FSC,
     1                  IDUM)
          CALL PLA162 (30, IH, IK, IL, MOD(- IH + IL, 3), XISI,
     1                  FSC, IDUM)
          CALL PLA162 (33, IH, IK, IL, MOD(IL, 2), XISI, FSC, IDUM)
          CALL PLA162 (40, IH, IK, IL, MOD(IH, 2), XISI, FSC, IDUM)
        ELSE IF (IK .EQ. -2 * IH .AND. IH .NE. 0) THEN
          CALL PLA162 (35, IH, IK, IL, MOD(IL, 2), XISI, FSC, IDUM)
          CALL PLA162 (37, IH, IK, IL, MOD(IL, 3), XISI, FSC, IDUM)
        ELSE IF (IH .EQ. - 2 * IK .AND. IH .NE. 0) THEN
          CALL PLA162 (36, IH, IK, IL, MOD(IL, 2), XISI, FSC, IDUM)
          CALL PLA162 (38, IH, IK, IL, MOD(IL, 3), XISI, FSC, IDUM)
        ENDIF
      ENDIF
      RETURN
      END
      SUBROUTINE PLA162 (NEX, IH, IK, IL, MHKL, XISI, FSC, LATT)
      PARAMETER (NP12=600,NP13=500,NP17=99,NP38=125,NP39=30,NCS=50)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /FSPGR/ CRI(11), PNZ(13, 10), STLS(10)
      COMMON /DFSPGR/ SUM(NCS, 5), NUM(NCS, 5), XMFS(NCS), XTL(12),
     1 XNM(12), NNZ(13), ANZ(13), IR(3), IN(24), XN(48), FMN(12),
     2 ITL(12), AVNZ(3), NREF, IPERC, TRMX(3, 3), LU, ISPGRC, ISPGRA,
     3 ISPGRH, IPCNTC, IPCNTA, IPCNTH, IFRQC, IFRQA, IFRQH, RAVERC,
     4 RAVERA, RAVERH
      COMMON /CGGT/ IGGT
      CHARACTER IGGT*80
      COMMON /LFSPGR/ EX
      COMMON /DSPGR/ TYPE, NLAUE
      CHARACTER TYPE(NCS)*16, NLAUE(13)*5
      COMMON /CFSPGR/ EXT, ILAT0, ILAT1, LAUE
      CHARACTER EXT(NCS)*1, ILAT0*1, ILAT1, LAUE*5
      LOGICAL EX(NCS)
      COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0
      CHARACTER PRBUF*132, TYP0*3
C ******************************************************************C
C*******************************************************************C
      IF (NEX .GT. 0) THEN
        IF (MHKL .EQ. 0) THEN
          SUM(NEX, 1) = SUM(NEX, 1) + FSC * XISI
          SUM(NEX, 4) = SUM(NEX, 4) + FSC
          NUM(NEX, 1) = NUM(NEX, 1) + 1
        ELSE
          SUM(NEX, 2) = SUM(NEX, 2) + FSC * XISI
          SUM(NEX, 5) = SUM(NEX, 5) + FSC
          NUM(NEX, 2) = NUM(NEX, 2) + 1
          IF (XISI .GT. XMFS(NEX)) THEN
            IF (IH .NE. 5 .AND. IK .NE. 5 .AND. IL .NE. 5) THEN
              XMFS(NEX)   = XISI
              NUM(NEX, 3) = IH
              NUM(NEX, 4) = IK
              NUM(NEX, 5) = IL
            ENDIF
          ENDIF
        ENDIF
      ELSE IF (NEX .EQ. 0) THEN
        DO 20 I = 1, NCS
          XMFS(I) = 0.0
          DO 10 J = 1, 5
            SUM(I, J) = 0.0
            NUM(I, J) = 0
   10     CONTINUE
   20   CONTINUE
        IPR(481) = 0
      ELSE IF (NEX .LT. 0) THEN
        DO 30 I = 1, NCS
          IF (NUM(I, 1) .GT. 0) SUM(I, 1) = SUM(I, 1) / SUM(I, 4)
          IF (NUM(I, 2) .GT. 0) SUM(I, 2) = SUM(I, 2) / SUM(I, 5)
          IF (SUM(I, 2) .GT. 0.0) THEN
            SUM(I, 3) = SUM(I, 1) / SUM(I, 2)
          ELSE
            IF (SUM(I, 1) .GT. 1.0) THEN
              SUM(I, 3) = 99.00
            ELSE
              SUM(I, 3) = 0.0
            ENDIF
          ENDIF
          IF    ((SUM(I, 2) .LT. CRI(1) .AND. SUM(I, 3) .GT. CRI(2))
     1      .OR. (SUM(I, 2) .LT. CRI(3) .AND. SUM(I, 3) .GT. CRI(4))
     2      .OR. (SUM(I, 2) .LT. CRI(5) .AND. SUM(I, 3) .GT. CRI(6))
     3      .OR. (SUM(I, 2) .LT. CRI(7) .AND. SUM(I, 3) .GT. CRI(8))
     4      .OR. (SUM(I, 2) .LT. CRI(9) .AND. SUM(I, 3) .GT. CRI(10))
     5      .OR.  SUM(I, 3) .GT. CRI(11)) THEN
            IF (XMFS(I) .GT. 5.0) THEN
              EXT(I) = '?'
            ELSE
              EXT(I) = 'E'
            ENDIF
            EX(I)  = .TRUE.
          ELSE
            IF (SUM(I, 2) .GT. 0.0 .AND. SUM(I, 2) .LT. 1.5
     1        .AND. XMFS(I) .LT. 3.0) THEN
              EXT(I) = '?'
              EX(I)  = .TRUE.
            ELSE
              IF (SUM(I, 3) .GT. 2.0) THEN
                EXT(I) = '>'
              ELSE
                EXT(I) = ' '
              ENDIF
              EX(I)  = .FALSE.
            ENDIF
          ENDIF
   30   CONTINUE
        IF (EX(1) .AND. EX(2) .AND. EX(3)) THEN
          LATT = 5
          NXCT = NUM(1, 2) + NUM(2, 2) + NUM(3, 2)
        ELSE IF (EX(5)) THEN
          LATT = 7
          NXCT = NUM(5, 2)
        ELSE IF (EX(4)) THEN
          LATT = 6
          NXCT = NUM(4, 2)
        ELSE IF (EX(1)) THEN
          LATT = 4
          NXCT = NUM(1, 2)
        ELSE IF (EX(2)) THEN
          LATT = 3
          NXCT = NUM(2, 2)
        ELSE IF (EX(3)) THEN
          LATT = 2
          NXCT = NUM(3, 2)
        ELSE
          LATT = 1
          NXCT = 0
        ENDIF
        IF (NXCT .NE. 0) LATT = - LATT
        IF (IPR(548) .EQ. 0) THEN
          M = 2 + IWIN
        ELSE
          M = 2
        ENDIF
        DO 200 N = 1, M
          NRSC = 0
          IF (N .EQ. 1) THEN
            LU = LU6
          ELSE IF (N .EQ. 2) THEN
            LU = LU7
          ELSE
            LU = 0
          ENDIF
   40     IF (LU .EQ. LU7) CALL PLA269 (0)
          IF (LU .EQ. 0) THEN
            CALL GGIP (HORS, VERT, 0.0, 1)
            VRT = VERT
          ENDIF
          IF (NEX .EQ. -1) THEN
            WRITE (PRBUF, 99994)
            IF (LU .GT. 0) THEN
              WRITE (LU, 99988) PRBUF(1:80)
            ELSE
              VRT = VRT - 0.8
              CALL GGIP20 (0.0, PRBUF, 80, 0.30, 1, 2, 1.0, VRT)
              VRT = VRT - 0.4
            ENDIF
          ELSE IF (NEX .EQ. -2) THEN
            WRITE (PRBUF, 99990)
            IF (LU .GT. 0) WRITE (LU, 99989) PRBUF(1:80)
          ENDIF
          PAR(428) = (SUM(1, 1) * NUM(1, 1) + SUM(1, 2) * NUM(1, 2))
     1             / (NUM(1, 1) + NUM(1, 2))
          DO 50 I = 1, NCS
            IF (NEX .EQ. -1) THEN
              IF (I .GT. 6 .AND. I .LE. 40) GOTO 50
            ELSE IF (NEX .EQ. -2) THEN
              IF (I .GT. 46) GOTO 50
            ENDIF
            IF (EXT(I) .NE. ' ') THEN
              TYP0 = TYPE(I)(14:16)
              NRSC = 1
            ELSE
              TYP0 = ' '
            ENDIF
            WRITE (PRBUF, 99999)
            IF (I .EQ. 1) THEN
              IF (LU .GT. 0) THEN
                WRITE (LU, 99987) PRBUF(1:80)
                WRITE (LU, 99998)
                WRITE (LU, 99997)
              ELSE
                VRT = VRT - 0.5
                CALL GGIP20 (0.0, PRBUF, 80, 0.30, 5 + IGBL(68), 2,
     1                       1.0, VRT)
                VRT = VRT - 0.4
                WRITE (PRBUF, 99998)
                CALL GGIP20 (0.0, PRBUF, 80, 0.30, 5 + IGBL(68), 2,
     1                       1.0, VRT)
              ENDIF
            ENDIF
            WRITE (PRBUF, 99996) I, EXT(I), TYP0, TYPE(I)(1:13),
     1        SUM(I, 1), SUM(I, 2), NUM(I, 1), NUM(I, 2), XMFS(I),
     2          (NUM(I, J), J = 3, 5), SUM(I, 3)
            IF (LU .GT. 0) THEN
              IF (LU .EQ. LU6) THEN
                IF (TYP0 .NE. ' ') THEN
                  IPR(481) = IPR(481) + 1
                  WRITE (LU6, 99987) PRBUF(1:80)
                  WRITE (LU2, 99995) EXT(I), TYP0, TYPE(I)(1:13),
     1            SUM(I, 1), SUM(I, 2), NUM(I, 1), NUM(I, 2),
     2            XMFS(I), (NUM(I, J), J = 3, 5), SUM(I, 3)
                ENDIF
              ELSE IF (LU .EQ. LU7) THEN
                WRITE (LU7, 99987) PRBUF(1:80)
              ENDIF
            ELSE
              VRT = VRT - 0.4
              CALL GGIP20 (0.0, PRBUF, 80, 0.30, 1, 2, 1.0, VRT)
            ENDIF
   50     CONTINUE
          IF (LU .GT. 0) THEN
            IF (NRSC .EQ. 0) WRITE (LU, 99993)
            IF (NEX .EQ. -2) THEN
              IF (LU .EQ. LU7) CALL PLA269 (0)
              WRITE (LU, 99991) (CRI(J), J = 1, 10)
            ENDIF
          ELSE
            CALL PLA013 (2, 1)
            IF (IGGT(1:4) .EQ. 'PLOT') GOTO 40
          ENDIF
  200   CONTINUE
      ENDIF
      RETURN
99999 FORMAT ('Nr     Ex. Condition    Aver(I/sig(I)) ',
     1 'Number of Refl', 2X, 'I/sigI', 12X, '.T/F.')
99998 FORMAT (24X, '.True. .False. .True. .False.   Max.F',
     1 '    H  K  L Ratio')
99997 FORMAT (78('='))
99996 FORMAT (I2, 1X, A, 1X, A, 1X, A, 2F8.2, 2I7, F9.2, 2X, 3I3,
     1        F6.1)
99995 FORMAT ('EXTI ', A, 1X, A, 1X, A, 2F7.2, 2I7, F9.2, 2X, 3I3,
     1        F8.2)
99994 FORMAT ('Analysis of General Reflections for Bravais ',
     1         'Centering')
99993 FORMAT (':: No Extinction Conditions Found')
99991 FORMAT (/, 'NOTE: Reflections obscured by BeamStop Excluded',
     1 ' from Statistics', /,
     2 '      5 0 0 etc. not included in Exception list (Fe?)', //,
     3 'Extinction Conditions have been Marked with E when', /,
     4 '     <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, /)
99987 FORMAT (A)
      END
      SUBROUTINE PLA163 (NAME)
      PARAMETER (NP4=9,NP10=16,NP12=600,NP13=500,NP17=99,NP18=50,
     1 NP22=256,NP38=125,NP39=30,NCS=50)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /DFSPGR/ SUM(NCS, 5), NUM(NCS, 5), XMFS(NCS), XTL(12),
     1 XNM(12), NNZ(13), ANZ(13), IR(3), IN(24), XN(48), FMN(12),
     2 ITL(12), AVNZ(3), NREF, IPERC, TRMX(3, 3), LU, ISPGRC, ISPGRA,
     3 ISPGRH, IPCNTC, IPCNTA, IPCNTH, IFRQC, IFRQA, IFRQH, RAVERC,
     4 RAVERA, RAVERH
      COMMON /LPLAT/ TLATT(9, NP18), XCELL(7, NP18), LLAUE(NP18),
     1 RVL(12, 3), NTL(12, 3), RVAL(NP18, 3), NRLT0, NRLT, NREXT,
     2 RMAX, AVIOS
      CHARACTER NAME*7, NAME1*7, NAME2*5
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0
      LINE = 'SPGR '//NAME
      CALL GEN038 (LINE, 13, 80)
      CALL SGSM (LINE, 0, FN, 0,  0, IERR)
      CALL SGSM (LINE, 0, FN, 0, 18, IERR)
      IF (NAME .EQ. 'Pa     ') THEN
        NAME1 = 'Pc'
        NAME2 = 'C-BA'
      ELSE IF (NAME .EQ. 'P2/a   ') THEN
        NAME1 = 'P2/c'
        NAME2 = 'C-BA'
      ELSE IF (NAME .EQ. 'P21/a  ') THEN
        NAME1 = 'P21/c'
        NAME2 = 'C-BA'
      ELSE IF (NAME .EQ. 'Pn     ') THEN
        NAME1 = 'Pc'
        NAME2 = 'A-B-N'
      ELSE IF (NAME .EQ. 'P2/n   ') THEN
        NAME1 = 'P2/c'
        NAME2 = 'A-B-N'
      ELSE IF (NAME .EQ. 'P21/n  ') THEN
        NAME1 = 'P21/c'
        NAME2 = 'A-B-N'
      ELSE IF (NAME .EQ. 'Pb-3   ') THEN
        NAME1 = 'Pa-3'
        NAME2 = 'BA-C'
      ELSE
        NAME1 = LINE(1:7)
        NAME2 = LINE(8:11)
      ENDIF
      IF (NAME2(1:3) .EQ. '   ') NAME2 = 'ABC  '
      CALL GEN020 (1, NAME2, 1, 5)
      IL  = NINT(FN(3))
      ID2 = NINT(FN(5))
      ID3 = 1
      IF (ID2 .EQ. 2) THEN
        NZP = IPERC
      ELSE
        NZP = 100 - IPERC
      ENDIF
      IF (LINE(71:72) .EQ. ' C') THEN
        LINE(71:77) = ' Chiral'
      ELSE
        LINE(71:77) = '       '
      ENDIF
      RAVER = RVL(IL, 1)
      ISGNR = NINT(FN(1))
      READ (LINE(66:70), 99997) IFRQ
      WRITE (PRBUF, 99999) IL, ID2, ID3, NAME, ISGNR,
     1    IFRQ, NAME1, NAME2, RAVER, NTL(IL, 3) ,
     2    NZP, LINE(71:77), LINE(14:14)
      IF (LU .EQ. 0) THEN
        VRT = VRT - 0.7
        IF (RVL(IL, 1) .GT. RMAX) THEN
          NCOL = 2
        ELSE
          NCOL = 1
        ENDIF
        CALL GGIP20 (0.0, PRBUF(13:80), 68, 0.35, NCOL, 2, 0.1, VRT)
      ELSE
        WRITE (LU, 99998) PRBUF(13:80)
        IF (LU .EQ. LU7) THEN
          WRITE (LU2, 99998) PRBUF(1:80)
          IF (LINE(14:14) .EQ. 'C') THEN
            IF (RAVER .LT. RAVERC) THEN
              IF (NZP .GT. IPCNTC) THEN
                IF (IFRQ .GT. IFRQC) THEN
                  ISPGRC = ISGNR
                  IFRQC  = IFRQ
                  RAVERC = RVL(IL, 1)
                  IPCNTC = NZP
                ENDIF
              ENDIF
            ENDIF
          ELSE
            IF (RAVER .LT. RAVERA) THEN
              IF (NZP .GT. IPCNTA) THEN
                IF (IFRQ .GT. IFRQA) THEN
                  ISPGRA = ISGNR
                  IFRQA  = IFRQ
                  RAVERA = RVL(IL, 1)
                  IPCNTA = NZP
                ENDIF
              ENDIF
            ENDIF
            IF (LINE(71:72) .EQ. ' C') THEN
              IF (RAVER .LT. RAVERH) THEN
                IF (NZP .GT. IPCNTH) THEN
                  IF (IFRQ .GT. IFRQH) THEN
                    ISPGRH = ISGNR
                    IFRQH  = IFRQ
                    RAVERH = RVL(IL, 1)
                    IPCNTH = NZP
                  ENDIF
                ENDIF
              ENDIF
            ENDIF
          ENDIF
        ENDIF
      ENDIF
      RETURN
99999 FORMAT ('SPGR ', 3I2, 1X, A, I4, I6, 2X, A, ' :', A, F8.2,
     1         I6, I4, A, 1X, A)
99998 FORMAT (A)
99997 FORMAT (I5)
      END
      SUBROUTINE PLA164 (IMODE, IAPPEND, OLATT, TM1, AXCRIT)
      PARAMETER (NP12=600,NP13=500,NP17=99,NP18=50,NPVD=40000000,
     1  NP23=18000, NP38=125,NP39=30,NCS=50,NSCR=2*NP23-1501*14)
C **********************************************************************
C **********************************************************************
C **********************************************************************
      INTEGER DOT
      DIMENSION MS(10, 55)
      REAL MAXD, V(3), ORT(3, 3), TAU(3)
      LOGICAL CHANGE
      DIMENSION TM1(3, 3)
      CHARACTER OLATT*1, LAT0*1, LATT*1
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /CHARS/ LAT0, LATT(3)
      COMMON /LATICE/ TRNSX(3, 3, 128), ROT(3, 5, 5), TRDAT(3, 3, 8)
      COMMON // DHX(3, 1501), TT(1501, 11), ISCR(NSCR), VOID(NPVD)
      COMMON /LEPAG/ AXES(15, 23), TM(3, 3), CL(3, 5), TP(3, 3),
     1 TG(3, 3), TPQ(3, 3), TPS(3, 3), G(3, 3), OR(3, 3), ROTQ(3, 3),
     2 TRMXT(3, 3), T(3), H(3), TC(6), CELL(7), OCELL(7), RCELL(7),
     3 IDET, NVEC
      COMMON /DFSPGR/ SUM(NCS, 5), NUM(NCS, 5), XMFS(NCS), XTL(12),
     1 XNM(12), NNZ(13), ANZ(13), IR(3), IN(24), XN(48), FMN(12),
     2 ITL(12), AVNZ(3), NREF, IPERC, TRMX(3, 3), LU, ISPGRC, ISPGRA,
     3 ISPGRH, IPCNTC, IPCNTA, IPCNTH, IFRQC, IFRQA, IFRQH, RAVERC,
     4 RAVERA, RAVERH
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /CFSPGR/ EXT, ILAT0, ILAT1, LAUE
      CHARACTER EXT(NCS)*1, ILAT0*1, ILAT1*1, LAUE*5
      COMMON /PLA22/ LGR(12), XSYST(8), IBVL(8), LAT(7)
      CHARACTER LGR*5, XSYST*12, IBVL*1, LAT*1
      COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0
      COMMON /CGG11/ BCD, SBCD
      CHARACTER BCD*132, SBCD*132
      COMMON /CGGT/ IGGT
      CHARACTER IGGT*80
      COMMON /FNAME/ KNM(8), KXT, KNM16
      COMMON /NAMES/ NAME(8), EXTENS, PROGNM, FNLU1, FNLU16, RDTYPE
      CHARACTER NAME*80, EXTENS*9, PROGNM*28, FNLU1*80, FNLU16*80,
     1          RDTYPE*7
      COMMON /LPLAT/ TLATT(9, NP18), XCELL(7, NP18), LLAUE(NP18),
     1 RVL(12, 3), NTL(12, 3), RVAL(NP18, 3), NRLT0, NRLT, NREXT,
     2 RMAX, AVIOS
      COMMON /LPLATC/ BLATT(NP18), CLATT(NP18)
      CHARACTER BLATT*1, CLATT*1
      IWIN = IGBL(25) * IGBL(32)
      K1   = 1
      IF (IMODE .EQ. 0) THEN
        LUIM = 2 + IWIN
      ELSE IF (IMODE .GT. 0) THEN
        IF (IAPPEND .EQ. 0) THEN
          NRLT0  = 1
          NRLT   = 1
        ELSE
          NRLT0  = NRLT0 + 1
          NRLT   = NRLT  + 1
        ENDIF
        LUIM = 2
        DO 10 I = 1, 6
          XCELL(I, NRLT0) = PAR(100 + I)
   10   CONTINUE
        XCELL(7, NRLT0) = GEN045 (PAR(101))
        DO 20 I = 1, 9
          TLATT(I, NRLT0) = 0.0
   20   CONTINUE
        TLATT (1, NRLT0) = 1.0
        TLATT (5, NRLT0) = 1.0
        TLATT (9, NRLT0) = 1.0
        BLATT(NRLT0)     = OLATT
        CLATT(NRLT0)     = 'a'
        LLAUE(NRLT0)     = 1
        RVAL(NRLT0, 1)   = 0.0
        RVAL(NRLT0, 2)   = 0.0
        RVAL(NRLT0, 3)   = 0.0
      ENDIF
      NLPB = 0
      NLPE = 0
      IPR(117) = 4
   30 IPR117   = IPR(117)
      IF (IPR(117) .EQ. 1) THEN
        NLPB  = 72
        NLPE  = 127
      ELSE IF (IPR(117) .EQ. 2) THEN
        NLPB  = 72
        NLPE  = 92
      ELSE IF (IPR(117) .EQ. 3) THEN
        NLPB  = 72
        NLPE  = 79
      ELSE IF (IPR(117) .EQ. 4) THEN
        NLPB  = 16
        NLPE  = 16
      ELSE IF (IPR(117) .EQ. 5) THEN
        NLPB  = 16
        NLPE  = 23
      ELSE IF (IPR(117) .EQ. 6) THEN
        NLPB  = 16
        NLPE  = 36
      ELSE IF (IPR(117) .EQ. 7) THEN
        NLPB  = 16
        NLPE  = 71
      ENDIF
      NLP = NLPB - 1
   40 NLP = NLP  + 1
   50 CALL GEN101 (IPR(94), NVEC, DHX)
      CALL GEN074 (AXES, 0.0, 1, 345)
      CALL GEN074 (TT, 0.0, 1, NVEC * 11)
      IDET = 1
      DO 60 I = 1, 6
        OCELL(I) = PAR(100 + I)
   60 CONTINUE
      OCELL(7) = GEN045 (OCELL)
      LATT(1)  = OLATT
      DO 70 I = 1, 7
        IF (LAT(I) .EQ. OLATT) GOTO 80
   70 CONTINUE
      I = 1
   80 DO 100 J = 1, 3
        DO 90 K = 1, 3
          TPS(J, K) = TRNSX(J, K, I)
          TPQ(J, K) = TRNSX(J, K, NLP)
   90   CONTINUE
  100 CONTINUE
      CALL GEN004 (TPQ, TPS, TP)
      CALL GEN026 (1, G, OCELL, GL(5))
      CALL GEN001 (1, TP, G, G)
      CALL PLA088 (G, TP, PAR(440))
      CALL GEN026 (-1, G, RCELL, GL(5))
      RCELL(7) = GEN045 (RCELL)
      K = 0
      L = 0
      DO 120 I = 1, 3
        DO 110 J = 1, 3
          TPS(I, J) = TP(I, J)
          K = K + 1
          TLATT(K, NRLT0 + 1) = TP(I, J)
          IF (NRLT0 .NE. 0) THEN
            IF (TLATT(K, NRLT0 + 1) .NE. TLATT(K, NRLT0)) L = 1
          ELSE
            L = 1
          ENDIF
  110   CONTINUE
  120 CONTINUE
      BLATT(NRLT0 + 1)     = 'P'
      CLATT(NRLT0 + 1)     = 'a'
      LLAUE(NRLT0 + 1)     = 1
      RVAL(NRLT0 + 1, 1)   = 0.0
      RVAL(NRLT0 + 1, 2)   = 0.0
      RVAL(NRLT0 + 1, 3)   = 0.0
      DO 130 K = 1, 7
        XCELL(K, NRLT0 + 1) = RCELL(K)
  130 CONTINUE
      IF (NRLT0 .NE. 0) THEN
        IF (BLATT(NRLT0 + 1) .NE. BLATT(NRLT0)) L = 1
      ELSE
        L = 1
      ENDIF
      NRLT0        = NRLT0 + L
      NRLT         = NRLT0
      CALL GEN044 (RCELL, OR)
      CALL GEN005 (OR, ORT)
      CALL GEN003 (ORT, ROTQ, DET, 0)
      DO 160 K = 1, NVEC
        DO 140 I = 1, 3
          V(I) = DHX(I, K)
  140   CONTINUE
        CALL GEN002 (1, OR, V, T, XLNG)
        DKW = 0.0
        DO 150 J = 1, 3
          TT(K, J)     = T(J)
          TT(K, J + 3) = T(J) * T(J)
          DKW          = DKW  + TT(K, J + 3)
  150   CONTINUE
        TT(K, 7)       = T(1) * T(2)
        TT(K, 8)       = T(1) * T(3)
        TT(K, 9)       = T(2) * T(3)
        TT(K, 10)      = SQRT(ABS(DKW))
        TT(K, 11)      = K
  160 CONTINUE
  170 CHANGE = .FALSE.
      DO 180 K = 1, NVEC - 1
        IF (TT(NINT(TT(K, 11)), 10) .GT. TT(NINT(TT(K + 1, 11)), 10))
     1    THEN
          CALL GEN018 (TT(K, 11), TT(K + 1, 11))
          CHANGE = .TRUE.
        ENDIF
  180 CONTINUE
      IF (CHANGE) GOTO 170
      I = NVEC
      ITEL = 0
      MAXD = 0.0
      DO 230 J = 1, NVEC
        DO 190 I = 1, 3
          V(I) = DHX(I, J)
  190   CONTINUE
        CALL GEN002 (1, ROTQ, V, TAU, XLNG)
        TC(1) = TAU(2) * TAU(2) + TAU(3) * TAU(3)
        TC(2) = TAU(1) * TAU(1) + TAU(3) * TAU(3)
        TC(3) = TAU(1) * TAU(1) + TAU(2) * TAU(2)
        TC(4) = -2 * TAU(1) * TAU(2)
        TC(5) = -2 * TAU(1) * TAU(3)
        TC(6) = -2 * TAU(2) * TAU(3)
        DO 220 K = 1, NVEC
          DOT = 0
          DO 200 N = 1, 3
            DOT = DOT + ABS(NINT(DHX(N, J) * DHX(N, K)))
  200     CONTINUE
          IF (DOT .GT. IPR(94) .OR. DOT .LE. 0) GOTO 220
          TAND = TT(K, 4) * TC(1) + TT(K, 5) * TC(2)
     1         + TT(K, 6) * TC(3) + TT(K, 7) * TC(4)
     2         + TT(K, 8) * TC(5) + TT(K, 9) * TC(6)
          TAND = ATAN(SQRT(ABS(TAND)) / DOT) * GL(5)
          IF (TAND .GT. AXCRIT) GOTO 220
          IF (ITEL .EQ. 15) THEN
            CALL GEN122 (AXES, 8, ITEL)
            CALL GEN122 (AXES, 7, ITEL)
            ITEL = 8
          END IF
          ITEL = ITEL + 1
          DO 210 I = 1, 3
            AXES(ITEL, I)     = DHX(I, K)
            AXES(ITEL, I + 3) = DHX(I, J)
            AXES(ITEL, I + 9) = TT(K, I) / TT(K, 10)
  210     CONTINUE
          AXES(ITEL, 7) = TAND
          AXES(ITEL, 8) = TT(K, 10)
          AXES(ITEL, 9) = DOT
          IF (TAND .GT. MAXD) MAXD = TAND
  220   CONTINUE
  230 CONTINUE
      IF (ITEL .GT. IPR(514)) THEN
        CALL GEN122 (AXES, 7, ITEL)
        ITEL = IPR(514)
      ENDIF
      METRIC = 0
      NTEL   = ITEL
      IBEG   = 1
      IEND   = 0
      ISOL   = 0
      CALL GEN122 (AXES, 7, ITEL)
      GOTO 250
  240 CALL GEN122 (AXES, 7, ITEL)
      IF (ITEL .EQ. 7) THEN
        ITEL = ITEL - 4
      ELSE
        ITEL = ITEL - 2
      ENDIF
  250 IF (LUIM .EQ. 3) THEN
        BCD = 'LePage'//CHAR(0)
        CALL GGIP (HORS, VERT, 0.0, 1)
        CALL GGIP20 (0.0,  BCD, 7, 1.4, 4, 8, 10.6, VERT - 1.8)
        CALL GGIP20 (0.0,  BCD, 7, 1.4, 2, 8, 10.4, VERT - 1.9)
        IF (NLPE .GT. NLPB) THEN
          WRITE (BCD, 99996) NLP - NLPB + 1,
     1          ((TPQ(I, J), J = 1, 3), I = 1, 3), GEN084 (TRNSX, NLP)
          CALL GGIP20 (0.0, BCD, 80, 0.35, 3, 2, 0.1, 6.0)
        ENDIF
      ENDIF
  260 DO 280 I = 1, 3
        DO 270 J = 1, 3
          TP(I, J) = TPS(I, J)
  270   CONTINUE
  280 CONTINUE
      IF (ITEL .EQ. -1) THEN
        ITEL = 0
      ELSE IF (ITEL .EQ. -2) THEN
        GOTO 640
      ELSE
        CALL GEN122 (AXES, 8, ITEL)
      ENDIF
      IF (ITEL .GT. 1 .AND. MOD(ITEL, 2) .EQ. 0) ITEL = ITEL - 1
      CALL PLA165 (ITEL, MAXD, AXCRIT, ISOL, LUIM)
      IF (MAXD .LE. PAR(441) .AND. METRIC .EQ. 0 .AND. ISOL .EQ. 1)
     1   THEN
        METRIC = 1
        NTEL   = ITEL
        DO 290 I = 1, 9
          AXES(I, 23) = I
  290   CONTINUE
      ENDIF
      IF (ITEL .GT. 0 .AND. (METRIC .EQ. 0 .OR. ISOL .EQ. 0)) GOTO 620
      ILAT0 = LAT0
      DO 310 I = 1, 3
        DO 300 J = 1, 3
          TRMX(I, J) = TP(I, J)
  300   CONTINUE
  310 CONTINUE
      CALL GEN004 (TRMX, TM1, TRMXT)
      ILAT1 = LATT(3)
      CALL PLA167
      IF (ILAT0 .EQ. 'a') THEN
        I1 = 1
        I2 = 1
      ELSE IF (ILAT0 .EQ. 'm') THEN
        I1 = 2
        I2 = 2
      ELSE IF (ILAT0 .EQ. 'o') THEN
        I1 = 3
        I2 = 3
      ELSE IF (ILAT0 .EQ. 't') THEN
        I1 = 4
        I2 = 5
      ELSE IF (ILAT0 .EQ. 'h') THEN
        IF (ILAT1 .EQ. 'R') THEN
          I1 = 6
          I2 = 7
        ELSE
          I1 = 6
          I2 = 10
        ENDIF
      ELSE
        I1 = 11
        I2 = 12
      ENDIF
      IF (IMODE .EQ. 3) THEN
        RVLX = 100.0
      ELSE
        RVLX = 0.0
      ENDIF
      DO 430 I0 = I2, I1, - 1
        RVLX = MIN (RVLX, RVL(I0, 1))
        IF (IMODE .NE. 0) THEN
          YUNK = ABS(CELL(4) - 90.0) + ABS(CELL(5) - 90.0) +
     1           ABS(CELL(6) - 90.0)
          IF (YUNK .LT. 0.001) THEN
            YUNK = 0.0
            DO 330 I = 1, 3
              DO 320 J = 1, 3
                IF (I .NE. J) THEN
                  YUNK = YUNK + ABS(TRMXT(I, J))
                ENDIF
  320         CONTINUE
  330       CONTINUE
            IF (YUNK .LT. 0.001) THEN
              DO 340 I = 1, 3
                TRMXT(I, I) = ABS(TRMXT(I, I))
  340         CONTINUE
            ENDIF
          ENDIF
          WRITE (LU2, 99999) ((TRMXT(I, J), J = 1, 3), I = 1, 3),
     1           ILAT0, ILAT1, I0, (RVL(I0, K), K = 1, 3),
     2           (NTL(I0, K), K = 1, 3), (CELL(I), I = 1, 7)
          IF (RVL(I0, 1) .LE. 40) THEN
            CLATT(NRLT0 + 1) = ILAT0
            BLATT(NRLT0 + 1) = ILAT1
            CALL GEN020 (-1, CLATT(NRLT0 + 1), 1, 1)
            CALL GEN020 ( 1, BLATT(NRLT0 + 1), 1, 1)
            LLAUE(NRLT0 + 1) = I0
            DO 350 I = 1, 3
              RVAL(NRLT0 + 1, I) = RVL(I0, I)
  350       CONTINUE
            DO 360 I = 1, 7
              XCELL(I, NRLT0 + 1) = CELL(I)
  360       CONTINUE
            M = 0
            DO 380 K = 1, 3
              DO 370 J = 1, 3
                M = M + 1
                TLATT(M, NRLT0 + 1) = TRMXT(K, J)
  370         CONTINUE
  380       CONTINUE
            DO 420 I = 1, NRLT0
              DIFF = 0.0
              DO 390 M = 1, 9
                DIFF = DIFF + ABS(TLATT(M, I) - TLATT(M, NRLT0 + 1))
  390         CONTINUE
              IF (DIFF .LT. 0.001) THEN
                IF (CLATT(NRLT0 + 1) .EQ. CLATT(I)) THEN
                  IF (BLATT(NRLT0 + 1) .EQ. BLATT(I)) THEN
                    IF (LLAUE(NRLT0 + 1) .EQ. LLAUE(I)) THEN
                      IF (I .EQ. 1) THEN
                        DO 400 J = 1, 3
                          RVAL(1, J) = RVAL(NRLT0 + 1, J)
  400                   CONTINUE
                        GOTO 430
                      ELSE
                        IF (RVAL(NRLT0 + 1, 1) .EQ. RVAL(I, 1)) THEN
                          DIFF = 0.0
                          DO 410 J = 1, 7
                            DIFF = DIFF +
     1                      ABS(XCELL(J, I) - XCELL(J, NRLT0 + 1))
  410                     CONTINUE
                          IF (DIFF .LT. 0.01) GOTO 430
                        ENDIF
                      ENDIF
                    ENDIF
                  ENDIF
                ENDIF
              ENDIF
  420       CONTINUE
            NRLT0 = NRLT0 + 1
            IF (RVAL(NRLT0, 1) .LT. RMAX) THEN
              IF (K1 .EQ. 1) THEN
                IF (BLATT(NRLT0) .EQ. 'P' .AND.
     1              CLATT(NRLT0) .EQ. 'a') THEN
                  NRLT = NRLT0
                ENDIF
              ENDIF
              IF (LLAUE(NRLT0) .GT. K1) THEN
                NRLT = NRLT0
                K1   = LLAUE(NRLT0)
              ENDIF
            ENDIF
          ENDIF
        ENDIF
  430 CONTINUE
      IF ((IMODE .EQ. 1 .OR. RVLX .GT. RMAX) .AND. ITEL .GT. 0) THEN
        IF (IMODE .EQ. 1 .AND. (IEND .LT. IBEG .AND. ITEL .EQ. 1)) THEN
          ITEL = 0
          GOTO 240
        ENDIF
        DO 440 I = 1, NTEL
          AXES(I, 23) = MOD(AXES(I, 23), 1000.0)
  440   CONTINUE
        CALL GEN122 (AXES, 23, NTEL)
        IF (IEND .EQ. 0) THEN
          IF (NTEL .GT. 1) THEN
            DO 460 I = 1, NTEL
              IEND = IEND + 1
              MS(10, IEND) = 1
              DO 450 J = 1, 9
                IF (J .EQ. I) THEN
                  MS(J, IEND) = 1
                ELSE
                  MS(J, IEND) = 0
                ENDIF
  450         CONTINUE
  460       CONTINUE
          ENDIF
          IEND = IEND + 1
          DO 470 J = 1, 10
            MS(J, IEND) = 0
  470     CONTINUE
        ENDIF
        IF (ILAT0 .EQ. 'c') THEN
          DO 490 J = 1, 3
            IEND         = IEND + 1
            MS(10, IEND) = 5
            DO 480 I = 1, 9
              IF (ABS(ABS(AXES(J, 13 + I)) - 90.0) .LT. AXCRIT) THEN
                MS(I, IEND) = 1
              ELSE
                MS(I, IEND) = 0
              ENDIF
  480       CONTINUE
            MS(J,  IEND) = 1
  490     CONTINUE
          V(1) = 1.0
          DO 520 I = 1, 4
            IF (I .GT. 2) THEN
              V(2) = -1.0
            ELSE
              V(2) = 1.0
            ENDIF
            IF (MOD(I, 2) .EQ. 0) THEN
              V(3) = -1.0
            ELSE
              V(3) = 1.0
            ENDIF
            IEND = IEND + 1
            MS(10, IEND) = 3
            DO 510 J = 1, 9
              DOT = 0
              DO 500 K = 1, 3
                DOT = DOT + NINT(AXES(J, K) * V(K))
  500         CONTINUE
              IF (DOT .EQ. 0) THEN
                MS(J, IEND) = 1
              ELSE
                MS(J, IEND) = 0
              ENDIF
  510       CONTINUE
  520     CONTINUE
        ELSE IF (ILAT0 .EQ. 'h') THEN
          IF (ILAT1 .EQ. 'P') THEN
            DO 540 J = 1, 7
              IF (NINT(AXES(J, 13)) .EQ. 2) THEN
                IEND         = IEND + 1
                MS(10, IEND) = 3
                DO 530 I = 1, 7
                  IF (ABS(ABS(AXES(J, 13 + I)) - 90.0) .LT. AXCRIT)
     1             THEN
                    MS(I, IEND) = 1
                  ELSE
                    MS(I, IEND) = 0
                  ENDIF
  530           CONTINUE
                MS(J, IEND) = 1
              ENDIF
  540       CONTINUE
          ENDIF
        ELSE IF (ILAT0 .EQ. 't') THEN
          IEND = IEND + 1
          MS(10, IEND) = 3
          DO 550 I = 1, 9
            IF (NINT(AXES(I, 13)) .EQ. 4) THEN
              MS(I, IEND) = 1
              J = I
            ELSE
              MS(I, IEND) = 0
            ENDIF
  550     CONTINUE
          N = 1
          DO 560 I = 1, 5
            IF (ABS(ABS(AXES(J, 13 + I)) - 90.0) .LT. AXCRIT) THEN
              N = N + 1
              MS(I, IEND) = 1
              IF (N .EQ. 3) GOTO 570
            ENDIF
  560     CONTINUE
        ENDIF
      ENDIF
  570 IF (IEND .GE. IBEG) THEN
        IF (IBEG .GT. 1) THEN
          DO 590 I = 1, IBEG - 1
            DO 580 J = 1, 10
              IF (MS(J, IBEG) .NE. MS(J, I)) GOTO 590
  580       CONTINUE
            IBEG = IBEG + 1
            GOTO 640
  590     CONTINUE
        ENDIF
        DO 600 I = 1, NTEL
          AXES(I, 23) = MOD(AXES(I, 23), 1000.0)
  600   CONTINUE
        DO 610 I = 1, NTEL
          IF (MS(I, IBEG) .EQ. 0) AXES(I, 23) = AXES(I, 23) + 1000.0
  610   CONTINUE
        CALL GEN122 (AXES, 23, NTEL)
        ITEL = MS(10, IBEG)
        IBEG = IBEG + 1
        GOTO 260
      ENDIF
      IF (IEND .GT. 0) ITEL = 1
  620 IF (IWIN .EQ. 1 .AND. IMODE .EQ. 0) THEN
        IF (METRIC .EQ. 0 .OR. NLP .LT. NLPE) THEN
          WRITE (SBCD, 99997) CHAR(0)
        ELSE
          WRITE (SBCD, 99998) CHAR(0)
        ENDIF
        CALL PLA015 (0, 39)
        CALL PLA013 (0, 1)
        IF (IPR(117)  .NE. IPR117) GOTO 30
        IF (IGGT(1:4) .EQ. 'REST' .OR. IGGT(1:4) .EQ. 'PLOT') GOTO 50
        IF (IGGT(1:4) .EQ. 'EXIT') GOTO 640
        IF (IGGT(1:3) .EQ. 'END')  GOTO 630
        IF (IGGT(1:1) .EQ. '!' .OR. IGGT(1:4) .EQ. 'NEXT') THEN
          IF (METRIC .EQ. 0) THEN
            GOTO 240
          ELSE
            GOTO 630
          ENDIF
        ENDIF
      ENDIF
  630 IF (NLP .LT. NLPE) GOTO 40
  640 IF (IMODE .GT. 0) THEN
        OPEN (LU61, FILE = NAME(1)(1:KNM(1))//'.trm',
     1    STATUS = 'UNKNOWN', FORM = 'UNFORMATTED')
        NREXT = IPR(481)
        AVIOS = PAR(428)
        WRITE (LU61) NRLT0, NRLT, NREXT, AVIOS, RMAX,
     1   RVL, NTL, TLATT, XCELL, LLAUE, RVAL, CLATT, BLATT
        CLOSE (LU61)
      ENDIF
      CALL GEN038 (IGGT, 1, 80)
      IGBL(23)  = 10
      RETURN
99999 FORMAT ('TRMX ', 9F7.3, 1X, A, A, I3, ' =', /, 5X, 3F6.1, 3I8,
     1        ' = ', /, 5X, 3F10.4, 3F8.3, F10.2)
99998 FORMAT ('[END]',  A)
99997 FORMAT ('[NEXT]', A)
99996 FORMAT ('TRANS:', I2, ' (', 3F6.2, ' /', 3F6.2, ' /',
     1         3F6.2, ') Det =', F5.2)
      END
      SUBROUTINE PLA165 (ITEL, MAXD, AXCRIT, ISOL, LUIM)
      PARAMETER (NP12=600,NP13=500,NP17=99,NPVD=40000000,NP23=18000,
     1           NP38=125,NP39=30,NSCR=2*NP23-1501*14)
      REAL MAXD, BB(3, 3)
      CHARACTER LATT*1, LAT0*1
      CHARACTER SYST0*10, SYST*12, LINE*80
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /CHARS/ LAT0, LATT(3)
      COMMON // DHX(3, 1501), TT(1501, 11), ISCR(NSCR), VOID(NPVD)
      COMMON /LEPAG/ AXES(15, 23), TM(3, 3), CL(3, 5), TP(3, 3),
     1 TG(3, 3), TPQ(3, 3), TPS(3, 3), G(3, 3), OR(3, 3), ROTQ(3, 3),
     2 TRMXT(3, 3), T(3), H(3), TC(6), CELL(7), OCELL(7), RCELL(7),
     3 IDET, NVEC
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      LATT(3) = 'P'
      MAXD    = 0.0
      ANGM    = 0.0
      ANGMN   = 0.0
      IF (ITEL .GT. 0) THEN
        ANGM  = 0.0
        ANGMN = 180.0
        DO 20 I = 1, ITEL
          IF (AXES(I, 7) .GT. MAXD) MAXD = AXES(I, 7)
          AXES(I, 13) = 0.0
          DO 10 J = 1, ITEL
            ANG = 0.0
            AXES(I, J + 13) = 0.0
            IF (I .NE. J) THEN
              ANG = AXES(I, 10) * AXES(J, 10)
     1            + AXES(I, 11) * AXES(J, 11)
     2            + AXES(I, 12) * AXES(J, 12)
              IF (ABS(ANG) .LT. 0.00001) THEN
                ANG = 90.0
              ELSE IF (ANG .GE. 1.0) THEN
                ANG = 0
              ELSE
                ANG = ACOS(ANG) * GL(5)
                IF (ANG .LT. 0.0)  ANG = ANG + 180.0
                IF (ANG .LT. 90.0) ANG = 180.0 - ANG
              ENDIF
              IF (ANG .GT. ANGM)   ANGM = ANG
              IF (ANG .LT. ANGMN) ANGMN = ANG
              AXES(I, J + 13) = ANG
              IF (ANG + AXCRIT .GT. 90.0 .AND.
     1            ANG - AXCRIT .LT. 90.0)
     1          AXES(I, 13) = AXES(I, 13) + 1
            ENDIF
   10     CONTINUE
   20   CONTINUE
      ENDIF
      IF (ITEL .EQ. 0) THEN
        SYST = 'Anorthic'
        CALL GEN021 (TM, 1)
      ELSE IF (ITEL .EQ. 1) THEN
        SYST = 'Monoclinic'
        DO 30 N = 1, 3
          TM(2, N) = AXES(ITEL, N)
   30   CONTINUE
        YDUM = COS((90.0 - AXCRIT) / GL(5))
        D1   = 999.0
        D2   = 0.0
        DO 60 K = 1, NVEC
          DUM = (TT(K, 1) * AXES(ITEL, 10)
     1        +  TT(K, 2) * AXES(ITEL, 11)
     2        +  TT(K, 3) * AXES(ITEL, 12)) / TT(K,10)
          IF (ABS(DUM) .GT. YDUM) GOTO 60
          IF (TT(K, 10) .GE. D1) THEN
            IF (TT(K, 10) .GT. D2) GOTO 60
            I  = 3
            D2 = TT(K, 10)
          ELSE
            D2 = D1
            DO 40 N = 1, 3
              TM(3, N) = TM(1, N)
              CL(3, N) = CL(1, N)
   40       CONTINUE
            I  = 1
            D1 = TT(K, 10)
          ENDIF
          DO 50 N = 1, 3
            TM(I, N) = DHX(N, K)
            CL(I, N) = TT(K, N)
   50     CONTINUE
   60   CONTINUE
        DUM = CL(1, 1) * CL(3, 1) + CL(1, 2) * CL(3, 2)
     1      + CL(1, 3) * CL(3, 3)
        IF (DUM .GT. 0.0) THEN
          DO 70 N = 1, 3
            TM(3, N) = - TM(3, N)
   70     CONTINUE
        ENDIF
        CALL GEN003 (TM, BB, DET, 0)
        IF (DET .LE. 0) THEN
          DO 80 N = 1, 3
            TM(2, N) = - TM(2, N)
   80     CONTINUE
        ENDIF
      ELSE IF (ITEL .EQ. 3) THEN
        SYST = 'Hexagonal   '
        IF (ANGM  .GT. 120.0 + AXCRIT .OR.
     1      ANGMN .LT. 120.0 - AXCRIT) THEN
          SYST = 'Orthorhombic'
          ZANG = 90
          GOTO 170
        ENDIF
        DOT  = 0.0
        K    = 0
        DO 100 I3 = 1, 3, 2
          K = K + 1
          DO 90 J3 = 1, 3
            TM(K, J3) = AXES(I3, J3)
            CL(K, J3) = AXES(I3, J3 + 9)
            IF (K .EQ. 2) DOT = DOT + CL(1, J3) * CL(2, J3)
   90     CONTINUE
  100   CONTINUE
        IF (DOT .GT. 0) THEN
          DO 110 J3 = 1, 3
            TM(2, J3) = - TM(2, J3)
            CL(2, J3) = - CL(2, J3)
  110     CONTINUE
        ENDIF
        CRS1     = CL(1, 2) * CL(2, 3) - CL(1, 3) * CL(2, 2)
        CRS2     = CL(1, 3) * CL(2, 1) - CL(1, 1) * CL(2, 3)
        CRS3     = CL(1, 1) * CL(2, 2) - CL(1, 2) * CL(2, 1)
        TM(3, 1) = CRS1 * ROTQ(1, 1) + CRS2 * ROTQ(2, 1)
     1           + CRS3 * ROTQ(3, 1)
        TM(3, 2) = CRS1 * ROTQ(1, 2) + CRS2 * ROTQ(2, 2)
     2           + CRS3 * ROTQ(3, 2)
        TM(3, 3) = CRS1 * ROTQ(1, 3) + CRS2 * ROTQ(2, 3)
     3           + CRS3 * ROTQ(3, 3)
        CALL GEN003 (TM, BB, DET, 0)
        DO 120 N = 1, 3
          TMDUM    = TM(3, N) * 3 / DET
          TM(3, N) = NINT(TMDUM)
  120   CONTINUE
        DO 140 LOOP = 1, 2
          MODL = 3
          H(1) = 2
          H(2) = 1
          H(3) = 1
          CALL GEN092 (MODL, H, TM, NUM)
          IF (NUM .EQ. 0) GOTO 230
          DO 130 N = 1, 3
            TM(1, N) = - TM(1, N)
            TM(2, N) = - TM(2, N)
  130     CONTINUE
  140   CONTINUE
        GOTO 310
      ELSE IF (ITEL .EQ. 5) THEN
        SYST = 'Tetragonal'
        ZANG = 90.0
        GOTO 170
      ELSE IF (ITEL .EQ. 7) THEN
        SYST = 'Hexagonal'
        ZANG = 120.0
        GOTO 170
      ELSE IF (ITEL .EQ. 9) THEN
        SYST = 'Cubic'
        K3   = 0
        N90  = 4
        DO 160 I3 = 1, 9
          IF (NINT(AXES(I3, 13)) .EQ. N90) THEN
            K3 = K3 + 1
            IF (K3 .LE. 3) THEN
              DO 150 J3 = 1, 3
                TM(K3, J3) = AXES(I3, J3)
  150         CONTINUE
            ENDIF
          ENDIF
  160   CONTINUE
        IF (K3 .NE. 3) GOTO 310
      ELSE
        GOTO 320
      ENDIF
      GOTO 230
  170 N90 = ITEL - 1
      IOK = 0
      DO 180 I = 1, ITEL
        IF (NINT(AXES(I, 13)) .EQ. N90) IOK = 1
  180 CONTINUE
      IF (IOK .EQ. 0) GOTO 310
      YDUM1 = COS((ZANG - AXCRIT) / GL(5))
      YDUM2 = COS((ZANG + AXCRIT) / GL(5))
      K = 0
      DO 210 I3 = 1, ITEL
        IF (NINT(AXES(I3, 13)) .LT. 2) GOTO 310
        IF (ITEL .LE. 3) THEN
          K3 = I3
          GOTO 190
        ENDIF
        IF (NINT(AXES(I3, 13)) .EQ. N90) THEN
          K3 = 3
          GOTO 190
        ENDIF
        K = K + 1
        IF (K .GT. 2) THEN
          K3 = 0
        ELSE
          K3 = K
        ENDIF
  190   IF (K3 .GT. 0) THEN
          DO 200 J3 = 1, 3
            TM(K3, J3) = AXES(I3, J3)
            CL(K3, J3) = AXES(I3, J3 + 9)
  200     CONTINUE
        ENDIF
  210 CONTINUE
      DUM = CL(1, 1) * CL(2, 1) + CL(1, 2) * CL(2, 2)
     1    + CL(1, 3) * CL(2, 3)
      IF (DUM .GT. 0.0) THEN
        DO 220 N = 1, 3
          TM(2, N) = - TM(2, N)
  220   CONTINUE
        DUM = - DUM
      ENDIF
      IF ((DUM .GT. YDUM1) .OR. (DUM .LT. YDUM2)) GOTO 310
  230 LAT0 = SYST(1:1)
      CALL GEN020 (-1, LAT0, 1, 1)
      CALL GEN003 (TM, BB, DET, 0)
      IF (DET .LT. 0) THEN
        DO 240 N = 1, 3
          TM(3, N) = - TM(3, N)
  240   CONTINUE
      ENDIF
      IDET = NINT(ABS(DET))
      IF (IDET .NE. 2) THEN
        IF (IDET .EQ. 3) LATT(3) = 'R'
        IF (IDET .EQ. 4) LATT(3) = 'F'
      ELSE
        MODL = 2
        LATT(3) = 'A'
        H(1) = 0
        H(2) = 1
        H(3) = 1
        CALL GEN092 (MODL, H, TM, NUM)
        IF (NUM .EQ. 0) GOTO 250
        LATT(3) = 'B'
        H(1) = 1
        H(2) = 0
        H(3) = 1
        CALL GEN092 (MODL, H, TM, NUM)
        IF (NUM .EQ. 0) GOTO 250
        LATT(3) = 'C'
        H(1)    = 1
        H(2)    = 1
        H(3)    = 0
        CALL GEN092 (MODL, H, TM, NUM)
        IF (NUM .EQ. 0) GOTO 250
        LATT(3) = 'I'
        H(1)    = 1
        H(2)    = 1
        H(3)    = 1
        CALL GEN092 (MODL, H, TM, NUM)
        IF ((NUM .NE. 0) .OR. (IDET .GT. 4)) THEN
          WRITE (LU6, 99988)
          WRITE (LU7, 99988)
          STOP 'STOPPED: "WRONG DETERMINANT!"'
        ENDIF
  250   CONTINUE
      ENDIF
      IF ((ITEL .LT. 3) .AND. (LATT(3) .EQ. 'A')) THEN
        DO 260 N = 1, 3
          CALL GEN018 (TM(1, N), TM(3, N))
          TM(2, N) = - TM(2, N)
  260   CONTINUE
        LATT(3) = 'C'
      ENDIF
      IF ((ITEL .EQ. 3) .AND. ((LATT(3) .EQ. 'A') .OR.
     1   (LATT(3) .EQ. 'B'))) THEN
        IF (LATT(3) .EQ. 'A') THEN
          DO 270 N = 1, 3
            CALL GEN018 (TM(1, N), TM(3, N))
            CALL GEN018 (TM(1, N), TM(2, N))
  270     CONTINUE
        ELSE
          DO 280 N = 1, 3
            CALL GEN018 (TM(2, N), TM(3, N))
            TM(1, N) = - TM(1, N)
  280     CONTINUE
        ENDIF
        LATT(3) = 'C'
      ENDIF
      CALL PLA166 (ITEL, LATT(1), AXCRIT, PAR(441), LUIM)
      CALL GEN004 (TM(1, 1), TP, TP)
      IF (LAT0 .EQ. 'm') THEN
        IF (LATT(3) .EQ. 'A') THEN
          TG(1, 1) =   TP(1, 1)
          TG(1, 2) =   TP(1, 2)
          TG(1, 3) =   TP(1, 3)
          TP(1, 1) =   TP(3, 1)
          TP(1, 2) =   TP(3, 2)
          TP(1, 3) =   TP(3, 3)
          TP(2, 1) = - TP(2, 1)
          TP(2, 2) = - TP(2, 2)
          TP(2, 3) = - TP(2, 3)
          TP(3, 1) =   TG(1, 1)
          TP(3, 2) =   TG(1, 2)
          TP(3, 3) =   TG(1, 3)
          LATT(3) = 'C'
        ELSE IF (LATT(3) .EQ. 'I') THEN
          TG(1, 1) =  TP(1, 1)
          TG(1, 2) =  TP(1, 2)
          TG(1, 3) =  TP(1, 3)
          TG(3, 1) =  TP(3, 1)
          TG(3, 2) =  TP(3, 2)
          TG(3, 3) =  TP(3, 3)
          TP(1, 1) = -TG(1, 1) - TG(3, 1)
          TP(1, 2) = -TG(1, 2) - TG(3, 2)
          TP(1, 3) = -TG(1, 3) - TG(3, 3)
          TP(3, 1) =  TG(1, 1)
          TP(3, 2) =  TG(1, 2)
          TP(3, 3) =  TG(1, 3)
          LATT(3) = 'C'
        ENDIF
      ENDIF
      IF (LAT0 .EQ. 'c') THEN
        LAT1 = 7
      ELSE IF (LAT0 .EQ. 'h') THEN
        IF (LATT(3) .EQ. 'R') THEN
          LAT1 = 5
        ELSE
          LAT1 = 6
        ENDIF
      ELSE IF (LAT0 .EQ. 't') THEN
        LAT1 = 4
      ELSE IF (LAT0 .EQ. 'o') THEN
        LAT1 = 3
      ELSE IF (LAT0 .EQ. 'm') THEN
        LAT1 = 2
      ELSE
        LAT1 = 1
      ENDIF
      CALL GEN104 (LAT1, TP)
      CALL GEN003 (TP, TG, DETM, 0)
      SYST0 = 'Metrically'
      IF (MAXD .GT. PAR(441)) SYST0 = 'Pseudo'
      DO 290 LUI = 1, LUIM
        IF (LUI .EQ. 1) THEN
          LU = LU6
        ELSE IF (LUI .EQ. 2) THEN
          LU = LU7
        ELSE
          LU = 0
        ENDIF
        WRITE (LINE, 99999)
        IF (LU .NE. 0) THEN
          WRITE (LU, 99989)
          WRITE (LU, 99995) LINE
          WRITE (LU, 99990)
        ELSE
          CALL GGIP20 (0.0, LINE, 79, 0.35, 5 + IGBL(68), 2, 0.1, 5.0)
        ENDIF
        WRITE (LINE, 99998) (TP(1, J), J = 1, 3),
     1                      (TG(J, 1), J = 1, 3), SYST0
        IF (LU .NE. 0) THEN
          WRITE (LU, 99995) LINE
        ELSE
          CALL GGIP20 (0.0, LINE, 79, 0.35, 1, 2, 0.1, 4.5)
        ENDIF
        WRITE (LINE, 99997) (TP(2, J), J = 1, 3),
     1                      (TG(J, 2), J = 1, 3), SYST
        IF (LU .NE. 0) THEN
          WRITE (LU, 99995) LINE
        ELSE
          CALL GGIP20 (0.0, LINE, 79, 0.35, 1, 2, 0.1, 4.0)
        ENDIF
        WRITE (LINE, 99996) (TP(3, J), J = 1, 3),
     1                      (TG(J, 3), J = 1, 3), MAXD
        IF (LU .NE. 0) THEN
          WRITE (LU, 99995) LINE
        ELSE
          CALL GGIP20 (0.0, LINE, 79, 0.35, 1, 2, 0.1, 3.5)
        ENDIF
  290 CONTINUE
      CALL GEN026 (1, G, OCELL, GL(5))
      CALL GEN001 (1, TP, G, G)
      CALL GEN026 (-1, G, CELL, GL(5))
      CELL(7) = GEN045 (CELL)
      DO 300 LUI = 1, LUIM
        IF (LUI .EQ. 1) THEN
          LU = LU6
        ELSE IF (LUI .EQ. 2) THEN
          LU = LU7
        ELSE
          LU = 0
        ENDIF
        WRITE (LINE, 99994)
        IF (LU .NE. 0) THEN
          WRITE (LU, 99989)
          WRITE (LU, 99995) LINE
          WRITE (LU, 99990)
        ELSE
          CALL GGIP20 (0.0, LINE, 79, 0.35, 5 + IGBL(68), 2, 0.1, 2.5)
        ENDIF
        WRITE (LINE, 99993) LATT(1), (OCELL(J), J = 1, 7)
        IF (LU .NE. 0) THEN
          WRITE (LU, 99995) LINE
        ELSE
          CALL GGIP20 (0.0, LINE, 79, 0.35, 1, 2, 0.1, 2.0)
        ENDIF
        WRITE (LINE, 99992) (RCELL(I), I = 1, 7)
        IF (LU .NE. 0) THEN
          WRITE (LU, 99995) LINE
        ELSE
          CALL GGIP20 (0.0, LINE, 79, 0.35, 1, 2, 0.1, 1.5)
        ENDIF
        WRITE (LINE, 99991) LAT0, LATT(3), (CELL(J), J = 1, 7)
        IF (LU .NE. 0) THEN
          WRITE (LU, 99995) LINE
        ELSE
          CALL GGIP20 (0.0, LINE, 79, 0.35, 1, 2, 0.1, 1.0)
        ENDIF
  300 CONTINUE
      ISOL = 1
      RETURN
  310 CALL PLA166 (ITEL, LATT(1), AXCRIT, PAR(441), LUIM)
      ISOL = 0
      RETURN
  320 WRITE (LU6, 99987) ITEL
      STOP ' WRONG "ITEL" NUMBER '
99999 FORMAT ('==== Transformation Matrix: Input (a,b,c) to ',
     1 'Conventional Cell(a'', b'', c'') ==== ')
99998 FORMAT ('(a'')   (', 3(F6.3), ') (a)   (x'')   (', 3(F6.3),
     1 ') (x)  ', A)
99997 FORMAT ('(b'') = (', 3(F6.3), ') (b).  (y'') = (', 3(F6.3),
     1 ') (y)  ', A)
99996 FORMAT ('(c'')   (', 3(F6.3), ') (c)   (z'')   (', 3(F6.3),
     1 ') (z)  FOM:', F7.3)
99995 FORMAT (A)
99994 FORMAT (16X, 'Latt', 5X, 'a', 7X, 'b', 7X, 'c',
     1 5X, 'Alpha', 3X, 'Beta', 2X, 'Gamma', 6X, 'Volume')
99993 FORMAT ('Input Cell', 8X, A, 2X, 3(1X, F7.3), 3(F7.2), F12.2)
99992 FORMAT ('Reduc Cell', 8X, 'P', 2X, 3(1X, F7.3), 3(F7.2), F12.2)
99991 FORMAT ('Conv. Cell', 7X, 2A, 2X, 3(1X, F7.3), 3(F7.2), F12.2)
99990 FORMAT (80('-'))
99989 FORMAT (1X)
99988 FORMAT (//, 'THERE IS SOMETHING WRONG IN LATT TYPE ANALYSIS')
99987 FORMAT ('Wrong ITEL =', I5)
      END
      SUBROUTINE PLA166 (ITEL, LATT, P2, P3, LUIM)
      PARAMETER (NP12=600,NP13=500,NP17=99,NP38=125,NP39=30)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /LEPAG/ AXES(15, 23), TM(3, 3), CL(3, 5), TP(3, 3),
     1 TG(3, 3), TPQ(3, 3), TPS(3, 3), G(3, 3), OR(3, 3), ROTQ(3, 3),
     2 TRMXT(3, 3), T(3), H(3), TC(6), CELL(7), OCELL(7), RCELL(7),
     3 IDET, NVEC
      CHARACTER LATT*1, LINE*80
      VERT = GL(1)
      DO 20 L = 1, LUIM
        IF (L .EQ. 1) THEN
          LU = LU6
        ELSE IF (L .EQ. 2) THEN
          CALL PLA269 (0)
          LU = LU7
        ELSE
          LU = 0
        ENDIF
        WRITE (LINE, 99993) IPR(94)
        IF (LU .EQ. 0) THEN
          CALL GGIP20 (0.0, LINE, 18, 0.35, 1, 2, 0.1, VERT - 2.5)
        ENDIF
        WRITE (LINE, 99999) P2, P3, LATT
        IF (LU .NE. 0) THEN
          WRITE (LU, 99996)
          WRITE (LU, 99992) LINE
          WRITE (LU, 99995)
        ELSE
          CALL GGIP20 (0.0, LINE, 76, 0.4, 1, 2, 0.1, VERT - 3.5)
        ENDIF
        IF (ITEL .GT. 0) THEN
          WRITE (LINE, 99998)
          IF (LU .NE. 0) THEN
            WRITE (LU, 99992) LINE
          ELSE
            CALL GGIP20 (0.0, LINE, 79, 0.35, 5 + IGBL(68), 2,
     1                   0.1, VERT - 4.5)
          ENDIF
          WRITE (LINE, 99994) (I, I = 1, 9)
          IF (LU .NE. 0) THEN
            WRITE (LU, 99992) LINE
            WRITE (LU, 99995)
          ELSE
            CALL GGIP20 (0.0, LINE, 79, 0.35, 5 + IGBL(68), 2, 0.1,
     1                   VERT - 5.0)
          ENDIF
          DO 10 I = 1, ITEL
            WRITE (LINE, 99997) I, AXES(I, 8), NINT(AXES(I, 13)),
     1            (NINT(AXES(I, K)), K = 1, 6), NINT(AXES(I, 9)),
     2            AXES(I, 7), (AXES(I, 13 + J), J = 1, ITEL)
            IF (LU .NE. 0) THEN
              WRITE (LU, 99992) LINE
            ELSE
              CALL GGIP20 (0.0, LINE, 79, 0.35, 1, 2, 0.1,
     1                     VERT - 5.1 - I * 0.5)
            ENDIF
   10     CONTINUE
        ENDIF
   20 CONTINUE
      RETURN
99999 FORMAT ('Possible 2-Fold Axes - 2-Axis Crit =', F5.2,
     1 ', Exp. Error =', F5.2, ' Deg., LATT = ', A)
99998 FORMAT (17X, 'Rows', 6X, 'Products', 7X, 'Angle Between Two ',
     1 'Direct Axes ')
99997 FORMAT (I2, F7.3, I2, 2(1X, 3I2), I3, F6.3, 1X, 9(1X, F4.0))
99996 FORMAT (1X)
99995 FORMAT (80('-'))
99994 FORMAT ('Nr', 3X, 'D', 4X, 'N', 1X, 'Direct', 2X,
     2 'Recip Dot Delta', 9(I4, 1X))
99993 FORMAT ('Max. Dot Prod =', I3)
99992 FORMAT (A)
      END
      SUBROUTINE PLA167
      PARAMETER (NP12=600,NP13=500,NP17=99,NP18=50,NPVD=40000000,
     1 NP23=18000,NP38=125,NP39=30,NCS=50, NZM = 200000,
     2 NRS = NPVD-10*NZM)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON // XYZDUM(2, NP23), RS(NRS), TNZ(NZM, 10)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /DFSPGR/ SUM(NCS, 5), NUM(NCS, 5), XMFS(NCS), XTL(12),
     1 XNM(12), NNZ(13), ANZ(13), IR(3), IN(24), XN(48), FMN(12),
     2 ITL(12), AVNZ(3), NREF, IPERC, TRMX(3, 3), LU, ISPGRC, ISPGRA,
     3 ISPGRH, IPCNTC, IPCNTA, IPCNTH, IFRQC, IFRQA, IFRQH, RAVERC,
     4 RAVERA, RAVERH
      COMMON /LPLAT/ TLATT(9, NP18), XCELL(7, NP18), LLAUE(NP18),
     1 RVL(12, 3), NTL(12, 3), RVAL(NP18, 3), NRLT0, NRLT, NREXT,
     2 RMAX, AVIOS
      COMMON /CFSPGR/ EXT, ILAT0, ILAT1, LAUE
      CHARACTER EXT(NCS)*1, ILAT0*1, ILAT1*1, LAUE*5
      DIMENSION DUMV(3, 3), AA(3, 3), BB(3, 3), V(6)
      COMMON /HKLMX/ HMAX, KMAX, LMAX, IHM, IHKM, IHKP
      INTEGER HMAX
      LH  = 0
      LK  = 0
      LL  = 0
      IH  = 0
      IK  = 0
      IL  = 0
      NLB = 0
      NLE = 0
      DO 20 I = 1, 12
        XTL(I) = 0.0
        XNM(I) = 0.0
        DO 10 J = 1, 3
          RVL(I, J) = 0.0
          NTL(I, J) = 0
   10   CONTINUE
   20 CONTINUE
      STLMX = 0.0
      HMAX = 0
      KMAX = 0
      LMAX = 0
      CALL GEN108 (LU8, 0)
      DO 30 I = 1, NREF
        READ (LU8) KH, KK, KL, XI, SI, STL, STL
        IF (GEN050 (TRMX, KH, KK, KL, LH, LK, LL) .GE. 0.0) THEN
          HMAX  = MAX (HMAX, IABS(LH))
          KMAX  = MAX (KMAX, IABS(LK))
          LMAX  = MAX (LMAX, IABS(LL))
          STLMX = MAX (STLMX, STL)
          IF (ILAT0 .EQ. 'h') THEN
            HMAX = MAX (HMAX, KMAX, IABS(LH + LK))
            KMAX = HMAX
          ENDIF
        ENDIF
   30 CONTINUE
      IF (ILAT0 .EQ. 't') THEN
        HMAX = MAX (HMAX, KMAX)
        KMAX = HMAX
      ELSE IF (ILAT0 .EQ. 'c') THEN
        HMAX = MAX (HMAX, KMAX, LMAX)
        KMAX = HMAX
        LMAX = HMAX
      ENDIF
      IHM   =  2 * HMAX + 1
      IHKM  = (2 * KMAX + 1) * IHM
      IHKLM = (2 * LMAX + 1) * IHKM
      IHKP  = (IHKLM + 1) / 2
      IF (IHKLM .GT. NPVD) THEN
        WRITE (LU6, 99989) HMAX, KMAX, LMAX, IHKLM, NPVD
        STOP ' FORCED ...'
      ENDIF
      CALL GEN026 (1, AA, PAR(101), GL(5))
      CALL GEN001 (1, TRMX, AA, DUMV)
      CALL GEN003 (DUMV, BB, DET, 0)
      CALL GEN025 (BB, V, 1)
      IF (ILAT0 .EQ. 'a') THEN
        NLB = 1
        NLE = 1
      ELSE IF (ILAT0 .EQ. 'm') THEN
        NLB = 2
        NLE = 2
      ELSE IF (ILAT0 .EQ. 'o') THEN
        NLB = 3
        NLE = 3
      ELSE IF (ILAT0 .EQ. 't') THEN
        NLB = 4
        NLE = 5
      ELSE IF (ILAT0 .EQ. 'h') THEN
        NLB = 6
        NLE = 10
      ELSE IF (ILAT0 .EQ. 'c') THEN
        NLB = 11
        NLE = 12
      ENDIF
      DO 70 NL = NLB, NLE
        DO 40 I = 1, IHKLM
          RS(I) = - 2.0
          J  = I - 1
          JL = J / IHKM
          JH = J - JL * IHKM
          JL = JL - LMAX
          JK = JH / IHM
          JH = JH - JK * IHM - HMAX
          JK = JK - KMAX
          IF (JH .NE. 0 .AND. JK .NE. 0 .AND. JL .NE. 0) THEN
            IF (GEN049 (ILAT1, JH, JK, JL) .GT. 0.0) THEN
              STLK = GEN095 (V, JH, JK, JL)
              STL  = SQRT(STLK)
              IF (STL .LE. STLMX) RS(I) = - 1.0
            ENDIF
          ENDIF
   40   CONTINUE
        CALL GEN108 (LU8, 0)
        DO 50 NRF = 1, NREF
          READ (LU8) KH, KK, KL, XI, SI, STL, STL
          IF (GEN050 (TRMX, KH, KK, KL, IH, IK, IL) .GT. 0.0) THEN
            IND = IL * IHKM + IK * IHM + IH + IHKP
            IF (XI .GT. 2.5 * SI) THEN
              IF (RS(IND) .GT. - 0.5) THEN
                RS(IND) = (RS(IND) + XI) / 2.0
              ELSE
                RS(IND) = XI
              ENDIF
            ELSE
              RS(IND) = 0.0
            ENDIF
          ENDIF
   50   CONTINUE
        DO 60 I = 1, IHKLM
          IF (RS(I) .GT. -1.5) THEN
            IN(1) = I
            I0    = I - 1
            IR(3) = I0 / IHKM
            IR(1) = I0 - IR(3) * IHKM
            IR(3) = IR(3) - LMAX
            IR(2) = IR(1) / IHM
            IR(1) = IR(1) - IR(2) * IHM - HMAX
            IR(2) = IR(2) - KMAX
            ISET  = IR(3) * IHKM + IHKP
            IR1M  = IR(1) * IHM
            IR2M  = IR(2) * IHM
            IF (ILAT0 .EQ. 'a') THEN
              CALL PLA170 (NL, 1, 1)
            ELSE IF (ILAT0 .EQ. 'm') THEN
              IN(2) = ISET  - IR2M + IR(1)
              CALL PLA170 (NL, 1, 2)
            ELSE IF (ILAT0 .EQ. 'o') THEN
              IN(2) = ISET - IR2M + IR(1)
              IN(3) = ISET + IR2M - IR(1)
              IN(4) = ISET - IR2M - IR(1)
              CALL PLA170 (NL, 1, 4)
            ELSE IF (ILAT0 .EQ. 't') THEN
              IN(2) = ISET + IR1M - IR(2)
              IN(3) = ISET - IR2M - IR(1)
              IN(4) = ISET - IR1M + IR(2)
              IF (NL .EQ. 5) THEN
                IN(5) = ISET + IR2M - IR(1)
                IN(6) = ISET + IR1M + IR(2)
                IN(7) = ISET - IR2M + IR(1)
                IN(8) = ISET - IR1M - IR(2)
                CALL PLA170 (NL, 1, 8)
              ELSE
                CALL PLA170 (NL, 1, 4)
              ENDIF
            ELSE IF (ILAT0 .EQ. 'h') THEN
              IHPK = IR(1) + IR(2)
              IRPM = IHPK * IHM
              IF (NL .LT. 9) THEN
                IN(2)  = ISET - IRPM + IR(2)
                IN(3)  = ISET + IR1M - IHPK
                IF (NL .EQ. 7) THEN
                  IN(4)  = ISET - IR1M - IR(2)
                  IN(5)  = ISET - IR2M + IHPK
                  IN(6)  = ISET + IRPM - IR(1)
                  CALL PLA170 (7, 1, 6)
                ELSE IF (NL .EQ. 8) THEN
                  IN(4)  = ISET + IR1M + IR(2)
                  IN(5)  = ISET + IR2M - IHPK
                  IN(6)  = ISET - IRPM + IR(1)
                  CALL PLA170 (8, 1, 6)
                ELSE
                  CALL PLA170 (6, 1, 3)
                ENDIF
              ELSE
                IN(2) = ISET + IRPM - IR(2)
                IN(3) = ISET + IR1M - IHPK
                IN(4) = ISET - IR2M - IR(1)
                IN(5) = ISET - IRPM + IR(2)
                IN(6) = ISET - IR1M + IHPK
                IF (NL .EQ. 10) THEN
                  IN(7)  = ISET + IR1M + IR(2)
                  IN(8)  = ISET - IR2M + IHPK
                  IN(9)  = ISET - IRPM + IR(1)
                  IN(10) = ISET - IR1M - IR(2)
                  IN(11) = ISET + IR2M - IHPK
                  IN(12) = ISET + IRPM - IR(1)
                  CALL PLA170 (NL, 1, 12)
                ELSE
                  CALL PLA170 (NL, 1, 6)
                ENDIF
              ENDIF
            ELSE IF (ILAT0 .EQ. 'c') THEN
              IST1 = IR(1) * IHKM + IHKP
              IST2 = IR(2) * IHKM + IHKP
              IR3M = IR(3) * IHM
              IN(2)  = ISET - IR2M + IR(1)
              IN(3)  = ISET + IR2M - IR(1)
              IN(4)  = ISET - IR2M - IR(1)
              IN(5)  = IST1 + IR3M + IR(2)
              IN(6)  = IST2 + IR1M + IR(3)
              IN(7)  = IST1 - IR3M - IR(2)
              IN(8)  = IST2 - IR1M - IR(3)
              IN(9)  = IST2 + IR1M - IR(3)
              IN(10) = IST1 - IR3M + IR(2)
              IN(11) = IST1 + IR3M - IR(2)
              IN(12) = IST2 - IR1M + IR(3)
              IF (NL .EQ. 12) THEN
                IN(13) = ISET + IR1M + IR(2)
                IN(14) = ISET + IR1M - IR(2)
                IN(15) = ISET - IR1M + IR(2)
                IN(16) = ISET - IR1M - IR(2)
                IN(17) = IST1 + IR2M + IR(3)
                IN(18) = IST2 + IR3M + IR(1)
                IN(19) = IST1 - IR2M - IR(3)
                IN(20) = IST2 - IR3M - IR(1)
                IN(21) = IST2 - IR3M + IR(1)
                IN(22) = IST1 + IR2M - IR(3)
                IN(23) = IST1 - IR2M + IR(3)
                IN(24) = IST2 + IR3M - IR(1)
                CALL PLA170 (NL, 1, 24)
              ELSE
                CALL PLA170 (NL, 1, 12)
              ENDIF
            ENDIF
          ENDIF
   60   CONTINUE
   70 CONTINUE
      DO 80 J = 1, 12
        IF (XNM(J) .GT. 0.0) THEN
          RVL(J, 1) = XTL(J) * 100.0 / XNM(J)
        ENDIF
        IF (NTL(J, 1) .GT. 0) THEN
          RVL(J, 2) = 100.0 * NTL(J, 2) / NTL(J, 1)
        ENDIF
        IF (NTL(J, 2) .GT. 0) THEN
          RVL(J, 3) = 100.0 * NTL(J, 3) / NTL(J, 2)
        ENDIF
   80 CONTINUE
      RETURN
99989 FORMAT (':: Increase NPVD: hm, km, lm =', 3I5, /,
     1        ':: NPVD(needed/current)', 2I10)
      END
      SUBROUTINE PLA168
      PARAMETER (NP18=50,NCS=50)
      COMMON /LPLAT/ TLATT(9, NP18), XCELL(7, NP18), LLAUE(NP18),
     1 RVL(12, 3), NTL(12, 3), RVAL(NP18, 3), NRLT0, NRLT, NREXT,
     2 RMAX, AVIOS
      COMMON /DSPGR/ TYPE, NLAUE
      CHARACTER TYPE(NCS)*16, NLAUE(13)*5
      COMMON /LFSPGR/ EX
      COMMON /CFSPGR/ EXT, ILAT0, ILAT1, LAUE
      CHARACTER EXT(NCS)*1, ILAT0*1, ILAT1*1, LAUE*5
      LOGICAL EX(NCS)
      IF (LAUE .EQ. NLAUE(13)) THEN
        IVAL  = 13
        IF (ILAT1 .EQ. 'R') THEN
          NB = 6
          NE = 7
        ELSE
          NB    = 1
          NE    = 12
        ENDIF
        DO 10 I = NB, NE
          IF (RVL(I, 1) .GT. 0.0) THEN
            IF (IVAL .EQ. 13) THEN
              IVAL  = I
            ELSE IF (RVL(I, 1) .LT. RMAX) THEN
              IVAL = I
            ENDIF
          ENDIF
   10   CONTINUE
        LAUE = NLAUE(IVAL)
      ENDIF
C*********************************************************************
C * TRICLINIC : LAUE CLASS -1                                        *
C*********************************************************************
      IF (ILAT0 .EQ. 'a') THEN
        IF (ILAT1 .EQ. 'P') THEN
          CALL PLA163 ('P1     ')
          CALL PLA163 ('P-1    ')
        ELSE IF (ILAT1 .EQ. 'A') THEN
          CALL PLA163 ('A1     ')
          CALL PLA163 ('A-1    ')
        ELSE IF (ILAT1 .EQ. 'B') THEN
          CALL PLA163 ('B1     ')
          CALL PLA163 ('B-1    ')
        ELSE IF (ILAT1 .EQ. 'C') THEN
          CALL PLA163 ('C1     ')
          CALL PLA163 ('C-1    ')
        ELSE IF (ILAT1 .EQ. 'I') THEN
          CALL PLA163 ('I1     ')
          CALL PLA163 ('I-1    ')
        ELSE IF (ILAT1 .EQ. 'F') THEN
          CALL PLA163 ('F1     ')
          CALL PLA163 ('F-1    ')
        ELSE IF (ILAT1 .EQ. 'R') THEN
          CALL PLA163 ('R1     ')
          CALL PLA163 ('R-1    ')
        ENDIF
C*********************************************************************
C * MONOCLINIC : B-UNIQUE  LAUE CLASS 1 2/M 1                        *
C*********************************************************************
      ELSE IF (ILAT0 .EQ. 'm') THEN
        IF (ILAT1 .EQ. 'I') THEN
          IF (EX(10) .AND. EX(11)) THEN
            CALL PLA163 ('Ia     ')
            CALL PLA163 ('I2/a   ')
          ELSE
            CALL PLA163 ('I2     ')
            CALL PLA163 ('Im     ')
            CALL PLA163 ('I2/m   ')
          ENDIF
        ELSE IF (ILAT1 .EQ. 'A') THEN
          IF (EX(10)) THEN
            CALL PLA163 ('Aa     ')
            CALL PLA163 ('A2/a   ')
          ELSE
            CALL PLA163 ('A2     ')
            CALL PLA163 ('Am     ')
            CALL PLA163 ('A2/m   ')
          ENDIF
        ELSE IF (ILAT1 .EQ. 'C') THEN
          IF (EX(11)) THEN
            CALL PLA163 ('Cc     ')
            CALL PLA163 ('C2/c   ')
          ELSE
            CALL PLA163 ('C2     ')
            CALL PLA163 ('Cm     ')
            CALL PLA163 ('C2/m   ')
          ENDIF
        ELSE
          IF (EX(12)) THEN
            IF (EX(17)) THEN
              CALL PLA163 ('P21/n  ')
              CALL PLA163 ('P21    ')
              CALL PLA163 ('Pn     ')
            ELSE
              CALL PLA163 ('Pn     ')
              CALL PLA163 ('P2/n   ')
            ENDIF
            IF (EX(10)) THEN
              IF (EX(17)) THEN
                CALL PLA163 ('P21/a  ')
                CALL PLA163 ('Pa     ')
              ELSE
                CALL PLA163 ('Pa     ')
                CALL PLA163 ('P2/a   ')
              ENDIF
            ENDIF
            IF (EX(11)) THEN
              IF (EX(17)) THEN
                CALL PLA163 ('P21/c  ')
                CALL PLA163 ('Pc     ')
              ELSE
                CALL PLA163 ('Pc     ')
                CALL PLA163 ('P2/c   ')
              ENDIF
            ENDIF
          ELSE IF (EX(10)) THEN
            IF (EX(17)) THEN
              CALL PLA163 ('P21/a  ')
              CALL PLA163 ('P21    ')
              CALL PLA163 ('Pa     ')
            ELSE
              CALL PLA163 ('Pa     ')
              CALL PLA163 ('P2/a   ')
            ENDIF
          ELSE IF (EX(11)) THEN
            IF (EX(17)) THEN
              CALL PLA163 ('P21/c  ')
              CALL PLA163 ('P21    ')
              CALL PLA163 ('Pc     ')
            ELSE
              CALL PLA163 ('Pc     ')
              CALL PLA163 ('P2/c   ')
            ENDIF
          ELSE
            IF (EX(17)) THEN
              CALL PLA163 ('P21    ')
              CALL PLA163 ('P21/m  ')
            ELSE
              CALL PLA163 ('P2     ')
              CALL PLA163 ('Pm     ')
              CALL PLA163 ('P2/m   ')
            ENDIF
          ENDIF
        ENDIF
C*******************************************************************
C * ORTHORHOMBIC LAUE CLASS 3 = 2/m 2/m 2/m                        *
C*******************************************************************
      ELSE IF (ILAT0 .EQ. 'o') THEN
        IF (ILAT1 .EQ. 'F') THEN
          IF (EX(19) .AND. EX(20) .AND. EX(21)) THEN
            CALL PLA163 ('Fddd   ')
          ELSE IF (EX(19) .AND. EX(20)) THEN
            CALL PLA163 ('Fdd2   ')
          ELSE IF (EX(19) .AND. EX(21)) THEN
            CALL PLA163 ('Fd2d   ')
          ELSE IF (EX(20) .AND. EX(21)) THEN
            CALL PLA163 ('F2dd   ')
          ELSE
            CALL PLA163 ('Fmm2   ')
            CALL PLA163 ('Fm2m   ')
            CALL PLA163 ('F2mm   ')
            CALL PLA163 ('F222   ')
            CALL PLA163 ('Fmmm   ')
          ENDIF
        ELSE IF (ILAT1 .EQ. 'I') THEN
          IF (EX(7) .AND. EX(8)) THEN
            IF (EX(10) .AND. EX(11)) THEN
              IF (EX(13) .AND. EX(14)) THEN
                CALL PLA163 ('Ibca   ')
              ELSE
                CALL PLA163 ('Iba2   ')
                CALL PLA163 ('Ibam   ')
              ENDIF
            ELSE IF (EX(12)) THEN
              IF (EX(13) .AND. EX(14)) THEN
                CALL PLA163 ('Ic2a   ')
                CALL PLA163 ('Icma   ')
              ELSE
                CALL PLA163 ('Ibm2   ')
                CALL PLA163 ('Ic2m   ')
                CALL PLA163 ('Ibmm   ')
                CALL PLA163 ('Icmm   ')
              ENDIF
            ENDIF
          ELSE IF (EX(9)) THEN
            IF (EX(10) .AND. EX(11)) THEN
              IF (EX(13) .AND. EX(14)) THEN
                CALL PLA163 ('I2cb   ')
                CALL PLA163 ('Imcb   ')
              ELSE IF (EX(15)) THEN
                CALL PLA163 ('Ima2   ')
                CALL PLA163 ('I2cm   ')
                CALL PLA163 ('Imam   ')
                CALL PLA163 ('Imcm   ')
              ENDIF
            ELSE IF (EX(12)) THEN
              IF (EX(13) .AND. EX(14)) THEN
                CALL PLA163 ('Im2a   ')
                CALL PLA163 ('I2mb   ')
                CALL PLA163 ('Imma   ')
                CALL PLA163 ('Immb   ')
              ELSE IF (EX(15)) THEN
                CALL PLA163 ('I222   ')
                CALL PLA163 ('Imm2   ')
                CALL PLA163 ('Im2m   ')
                CALL PLA163 ('I2mm   ')
                CALL PLA163 ('I212121')
                CALL PLA163 ('Immm   ')
              ENDIF
            ENDIF
          ENDIF
        ELSE IF (ILAT1 .EQ. 'A') THEN
          IF (EX(7) .AND. EX(8)) THEN
            IF (EX(10) .AND. EX(11)) THEN
              IF (EX(13) .AND. EX(14)) THEN
                CALL PLA163 ('Abaa   ')
                CALL PLA163 ('Acaa   ')
              ELSE IF (EX(14)) THEN
                CALL PLA163 ('Aba2   ')
                CALL PLA163 ('Acam   ')
              ENDIF
            ELSE IF (EX(11)) THEN
              IF (EX(13) .AND. EX(14)) THEN
                CALL PLA163 ('Ac2a   ')
                CALL PLA163 ('Abma   ')
              ELSE IF (EX(14)) THEN
                CALL PLA163 ('Abm2   ')
                CALL PLA163 ('Ac2m   ')
                CALL PLA163 ('Abmm   ')
                CALL PLA163 ('Acmm   ')
              ENDIF
            ENDIF
          ELSE IF (EX(9)) THEN
            IF (EX(10) .AND. EX(11)) THEN
              IF (EX(13) .AND. EX(14)) THEN
                CALL PLA163 ('A2aa   ')
                CALL PLA163 ('Amaa   ')
              ELSE IF (EX(14)) THEN
                CALL PLA163 ('A21am  ')
                CALL PLA163 ('Ama2   ')
                CALL PLA163 ('Amam   ')
              ENDIF
            ELSE IF (EX(11)) THEN
              IF (EX(13) .AND. EX(14)) THEN
                CALL PLA163 ('A21ma  ')
                CALL PLA163 ('Am2a   ')
                CALL PLA163 ('Amma   ')
              ELSE IF (EX(14) .AND. EX(16)) THEN
                CALL PLA163 ('A2122  ')
              ELSE IF (EX(14)) THEN
                CALL PLA163 ('A222   ')
                CALL PLA163 ('Amm2   ')
                CALL PLA163 ('Am2m   ')
                CALL PLA163 ('A2mm   ')
                CALL PLA163 ('Ammm   ')
              ENDIF
            ENDIF
          ENDIF
        ELSE IF (ILAT1 .EQ. 'B') THEN
          IF (EX(7) .AND. EX(8)) THEN
            IF (EX(10) .AND. EX(11)) THEN
              IF (EX(13) .AND. EX(14)) THEN
                CALL PLA163 ('Bbab   ')
                CALL PLA163 ('Bbcb   ')
              ELSE IF (EX(13)) THEN
                CALL PLA163 ('Bba2   ')
                CALL PLA163 ('Bbcm   ')
              ENDIF
            ELSE IF (EX(12)) THEN
              IF (EX(13) .AND. EX(14)) THEN
                CALL PLA163 ('Bb2b   ')
                CALL PLA163 ('Bbmb   ')
              ELSE IF (EX(13)) THEN
                CALL PLA163 ('Bb21m  ')
                CALL PLA163 ('Bbm2   ')
                CALL PLA163 ('Bbmm   ')
              ENDIF
            ENDIF
          ELSE IF (EX(8)) THEN
            IF (EX(10) .AND. EX(11)) THEN
              IF (EX(13) .AND. EX(14)) THEN
                CALL PLA163 ('B2cb   ')
                CALL PLA163 ('Bmab   ')
              ELSE IF (EX(13)) THEN
                CALL PLA163 ('Bma2   ')
                CALL PLA163 ('B2cm   ')
                CALL PLA163 ('Bmam   ')
                CALL PLA163 ('Bmcm   ')
              ENDIF
            ELSE IF (EX(12)) THEN
              IF (EX(13) .AND. EX(14)) THEN
                CALL PLA163 ('Bm21b  ')
                CALL PLA163 ('Bmmb   ')
                CALL PLA163 ('B2mb   ')
              ELSE
                IF (EX(17)) THEN
                  CALL PLA163 ('B2212  ')
                ELSE
                  CALL PLA163 ('B222   ')
                  CALL PLA163 ('Bmm2   ')
                  CALL PLA163 ('B2mm   ')
                  CALL PLA163 ('Bm2m   ')
                  CALL PLA163 ('Bmmm   ')
                ENDIF
              ENDIF
            ENDIF
          ENDIF
        ELSE IF (ILAT1 .EQ. 'C') THEN
          IF (EX(7) .AND. EX(8)) THEN
            IF (EX(10) .AND. EX(11)) THEN
              IF (EX(13) .AND. EX(14)) THEN
                CALL PLA163 ('Ccca   ')
                CALL PLA163 ('Cccb   ')
              ELSE
                CALL PLA163 ('Ccc2   ')
                CALL PLA163 ('Cccm   ')
              ENDIF
            ELSE
              IF (EX(13) .AND. EX(14)) THEN
                CALL PLA163 ('Cc2a   ')
                CALL PLA163 ('Ccmb   ')
              ELSE
                CALL PLA163 ('Ccm21  ')
                CALL PLA163 ('Cc2m   ')
                CALL PLA163 ('Ccmm   ')
              ENDIF
            ENDIF
          ELSE
            IF (EX(10) .AND. EX(11)) THEN
              IF (EX(13) .AND. EX(14)) THEN
                CALL PLA163 ('C2cb   ')
                CALL PLA163 ('Cmca   ')
              ELSE
                CALL PLA163 ('Cmc21  ')
                CALL PLA163 ('C2cm   ')
                CALL PLA163 ('Cmcm   ')
              ENDIF
            ELSE
              IF (EX(13) .AND. EX(14)) THEN
                CALL PLA163 ('Cm2a   ')
                CALL PLA163 ('C2mb   ')
                CALL PLA163 ('Cmma   ')
                CALL PLA163 ('Cmmb   ')
              ELSE
                IF (EX(18)) THEN
                  CALL PLA163 ('C2221  ')
                ELSE
                  CALL PLA163 ('C222   ')
                  CALL PLA163 ('Cm2m   ')
                  CALL PLA163 ('C2mm   ')
                  CALL PLA163 ('Cmm2   ')
                  CALL PLA163 ('Cmmm   ')
                ENDIF
              ENDIF
            ENDIF
          ENDIF
        ELSE IF (ILAT1 .EQ. 'P') THEN
          IF (EX(9)) THEN
            IF (EX(12)) THEN
              IF (EX(15)) THEN
                CALL PLA163 ('Pnnn   ')
              ELSE IF (EX(14)) THEN
                CALL PLA163 ('Pnnb   ')
              ELSE IF (EX(13)) THEN
                CALL PLA163 ('Pnna   ')
              ELSE
                CALL PLA163 ('Pnn2   ')
                CALL PLA163 ('Pnnm   ')
              ENDIF
            ENDIF
            IF (EX(11)) THEN
              IF (EX(15)) THEN
                CALL PLA163 ('Pncn   ')
              ELSE IF (EX(14)) THEN
                CALL PLA163 ('Pncb   ')
              ELSE IF (EX(13)) THEN
                CALL PLA163 ('Pnca   ')
              ELSE
                CALL PLA163 ('Pnc2   ')
                CALL PLA163 ('Pncm   ')
              ENDIF
            ENDIF
            IF (EX(10)) THEN
              IF (EX(15)) THEN
                CALL PLA163 ('Pnan   ')
              ELSE IF (EX(14)) THEN
                CALL PLA163 ('Pnab   ')
              ELSE IF (EX(13)) THEN
                CALL PLA163 ('Pnaa   ')
              ELSE
                CALL PLA163 ('Pna21  ')
                CALL PLA163 ('Pnam   ')
              ENDIF
            ENDIF
            IF (.NOT. EX(10) .AND. .NOT. EX(11) .AND. .NOT. EX(12)) THEN
              IF (EX(15)) THEN
                CALL PLA163 ('Pn2n   ')
                CALL PLA163 ('Pnmn   ')
              ELSE IF (EX(14)) THEN
                CALL PLA163 ('Pn2b   ')
                CALL PLA163 ('Pnmb   ')
              ELSE IF (EX(13)) THEN
                CALL PLA163 ('Pn21a  ')
                CALL PLA163 ('Pnma   ')
              ELSE
                CALL PLA163 ('Pnm21  ')
                CALL PLA163 ('Pn21m  ')
                CALL PLA163 ('Pnmm   ')
              ENDIF
            ENDIF
          ELSE IF (EX(8)) THEN
            IF (EX(12)) THEN
              IF (EX(15)) THEN
                CALL PLA163 ('Pcnn   ')
              ELSE IF (EX(14)) THEN
                CALL PLA163 ('Pcnb   ')
              ELSE IF (EX(13)) THEN
                CALL PLA163 ('Pcna   ')
              ELSE
                CALL PLA163 ('Pcn2   ')
                CALL PLA163 ('Pcnm   ')
              ENDIF
            ENDIF
            IF (EX(11)) THEN
              IF (EX(15)) THEN
                CALL PLA163 ('Pccn   ')
              ELSE IF (EX(14)) THEN
                CALL PLA163 ('Pccb   ')
              ELSE IF (EX(13)) THEN
                CALL PLA163 ('Pcca   ')
              ELSE
                CALL PLA163 ('Pcc2   ')
                CALL PLA163 ('Pccm   ')
              ENDIF
            ENDIF
            IF (EX(10)) THEN
              IF (EX(15)) THEN
                CALL PLA163 ('Pcan   ')
              ELSE IF (EX(14)) THEN
                CALL PLA163 ('Pcab   ')
              ELSE IF (EX(13)) THEN
                CALL PLA163 ('Pcaa   ')
              ELSE
                CALL PLA163 ('Pca21  ')
                CALL PLA163 ('Pcam   ')
              ENDIF
            ENDIF
            IF (.NOT. EX(10) .AND. .NOT. EX(11) .AND. .NOT. EX(12)) THEN
              IF (EX(15)) THEN
                CALL PLA163 ('Pc21n  ')
                CALL PLA163 ('Pcmn   ')
              ELSE IF (EX(14)) THEN
                CALL PLA163 ('Pc21b  ')
                CALL PLA163 ('Pcmb   ')
              ELSE IF (EX(13)) THEN
                CALL PLA163 ('Pc2a   ')
                CALL PLA163 ('Pcma   ')
              ELSE
                CALL PLA163 ('Pcm21  ')
                CALL PLA163 ('Pc2m   ')
                CALL PLA163 ('Pcmm   ')
              ENDIF
            ENDIF
          ELSE IF (EX(7)) THEN
            IF (EX(12)) THEN
              IF (EX(15)) THEN
                CALL PLA163 ('Pbnn   ')
              ELSE IF (EX(14)) THEN
                CALL PLA163 ('Pbnb   ')
              ELSE IF (EX(13)) THEN
                CALL PLA163 ('Pbna   ')
              ELSE
                CALL PLA163 ('Pbn21  ')
                CALL PLA163 ('Pbnm   ')
              ENDIF
            ENDIF
            IF (EX(11)) THEN
              IF (EX(15)) THEN
                CALL PLA163 ('Pbcn   ')
              ELSE IF (EX(14)) THEN
                CALL PLA163 ('Pbcb   ')
              ELSE IF (EX(13)) THEN
                CALL PLA163 ('Pbca   ')
              ELSE
                CALL PLA163 ('Pbc21  ')
                CALL PLA163 ('Pbcm   ')
              ENDIF
            ENDIF
            IF (EX(10)) THEN
              IF (EX(15)) THEN
                CALL PLA163 ('Pban   ')
              ELSE IF (EX(14)) THEN
                CALL PLA163 ('Pbab   ')
              ELSE IF (EX(13)) THEN
                CALL PLA163 ('Pbaa   ')
              ELSE
                CALL PLA163 ('Pba2   ')
                CALL PLA163 ('Pbam   ')
              ENDIF
            ENDIF
            IF (.NOT. EX(10) .AND. .NOT. EX(11) .AND. .NOT. EX(12)) THEN
              IF (EX(15)) THEN
                CALL PLA163 ('Pb2n   ')
                CALL PLA163 ('Pbmn   ')
              ELSE IF (EX(14)) THEN
                CALL PLA163 ('Pb2b   ')
                CALL PLA163 ('Pbmb   ')
              ELSE IF (EX(13)) THEN
                CALL PLA163 ('Pb21a  ')
                CALL PLA163 ('Pbma   ')
              ELSE
                CALL PLA163 ('Pb21m  ')
                CALL PLA163 ('Pbm2   ')
                CALL PLA163 ('Pbmm   ')
              ENDIF
            ENDIF
          ELSE
            IF (EX(12)) THEN
              IF (EX(15)) THEN
                CALL PLA163 ('P2nn   ')
                CALL PLA163 ('Pmnn   ')
              ELSE IF (EX(14)) THEN
                CALL PLA163 ('P21nb  ')
                CALL PLA163 ('Pmnb   ')
              ELSE IF (EX(13)) THEN
                CALL PLA163 ('P2na   ')
                CALL PLA163 ('Pmna   ')
              ELSE
                CALL PLA163 ('Pmn21  ')
                CALL PLA163 ('P21nm  ')
                CALL PLA163 ('Pmnm   ')
              ENDIF
            ENDIF
            IF (EX(11)) THEN
              IF (EX(15)) THEN
                CALL PLA163 ('P21cn  ')
                CALL PLA163 ('Pmcn   ')
              ELSE IF (EX(14)) THEN
                CALL PLA163 ('P2cb   ')
                CALL PLA163 ('Pmcb   ')
              ELSE IF (EX(13)) THEN
                CALL PLA163 ('P21ca  ')
                CALL PLA163 ('Pmca   ')
              ELSE
                CALL PLA163 ('Pmc21  ')
                CALL PLA163 ('P2cm   ')
                CALL PLA163 ('Pmcm   ')
              ENDIF
            ENDIF
            IF (EX(10)) THEN
              IF (EX(15)) THEN
                CALL PLA163 ('P2an   ')
                CALL PLA163 ('Pman   ')
              ELSE IF (EX(14)) THEN
                CALL PLA163 ('P21ab  ')
                CALL PLA163 ('Pmab   ')
              ELSE IF (EX(13)) THEN
                CALL PLA163 ('P2aa   ')
                CALL PLA163 ('Pmaa   ')
              ELSE
                CALL PLA163 ('P21am  ')
                CALL PLA163 ('Pma2   ')
                CALL PLA163 ('Pmam   ')
              ENDIF
            ENDIF
            IF (.NOT. EX(10) .AND. .NOT. EX(11) .AND. .NOT. EX(12)) THEN
              IF (EX(15)) THEN
                CALL PLA163 ('Pm21n  ')
                CALL PLA163 ('P21mn  ')
                CALL PLA163 ('Pmmn   ')
              ELSE IF (EX(14)) THEN
                CALL PLA163 ('Pm21b  ')
                CALL PLA163 ('P2mb   ')
                CALL PLA163 ('Pmmb   ')
              ELSE IF (EX(13)) THEN
                CALL PLA163 ('P21ma  ')
                CALL PLA163 ('Pm2a   ')
                CALL PLA163 ('Pmma   ')
              ELSE
                IF (EX(16)) THEN
                  IF (EX(17)) THEN
                    IF (EX(18)) THEN
                      CALL PLA163 ('P212121')
                      IF (EXT(16) .EQ. '?') CALL PLA163 ('P22121 ')
                      IF (EXT(17) .EQ. '?') CALL PLA163 ('P21221 ')
                      IF (EXT(18) .EQ. '?') CALL PLA163 ('P21212 ')
                      IF (EXT(16) .EQ. '?' .AND. EXT(17) .EQ. '?')
     1                    CALL PLA163 ('P2221  ')
                      IF (EXT(16) .EQ. '?' .AND. EXT(18) .EQ. '?')
     1                    CALL PLA163 ('P2212  ')
                      IF (EXT(17) .EQ. '?' .AND. EXT(18) .EQ. '?')
     1                    CALL PLA163 ('P2122  ')
                    ELSE
                      CALL PLA163 ('P21212 ')
                    ENDIF
                  ELSE
                    IF (EX(18)) THEN
                      CALL PLA163 ('P21221 ')
                    ELSE
                      CALL PLA163 ('P2122  ')
                    ENDIF
                  ENDIF
                ELSE
                  IF (EX(17)) THEN
                    IF (EX(18)) THEN
                      CALL PLA163 ('P22121 ')
                    ELSE
                      CALL PLA163 ('P2212  ')
                    ENDIF
                  ELSE
                    IF (EX(18)) THEN
                      CALL PLA163 ('P2221  ')
                    ELSE
                      CALL PLA163 ('P222   ')
                      CALL PLA163 ('Pmm2   ')
                      CALL PLA163 ('Pm2m   ')
                      CALL PLA163 ('P2mm   ')
                      CALL PLA163 ('Pmmm   ')
                    ENDIF
                  ENDIF
                ENDIF
              ENDIF
            ENDIF
          ENDIF
        ENDIF
C**********************************************************************
C * TETRAGONAL : LAUE CLASSES 4 = 4/M AND 5 = 4/M 2/M 2/M             *
C**********************************************************************
      ELSE IF (ILAT0 .EQ. 't') THEN
        IF (ILAT1 .EQ. 'I') THEN
          IF (LAUE .EQ. '  4/m') THEN
            IF (EX(13) .AND. EX(14)) THEN
              CALL PLA163 ('I41/a  ')
            ELSE
              IF (EX(24)) THEN
                CALL PLA163 ('I41    ')
              ELSE
                CALL PLA163 ('I-4    ')
                CALL PLA163 ('I4     ')
                CALL PLA163 ('I4/m   ')
              ENDIF
            ENDIF
          ELSE IF (LAUE .EQ. '4/mmm') THEN
            IF (EX(13) .AND. EX(14)) THEN
              IF (EX(7) .AND. EX(8)) THEN
                CALL PLA163 ('I41/acd')
              ELSE
                IF (EX(28)) THEN
                  CALL PLA163 ('I41/amd')
                ENDIF
              ENDIF
            ELSE
              IF (EX(7) .AND. EX(8)) THEN
                IF (EX(28)) THEN
                  CALL PLA163 ('I41cd  ')
                ELSE
                  CALL PLA163 ('I4cm   ')
                  CALL PLA163 ('I-4c2  ')
                  CALL PLA163 ('I4/mcm ')
                ENDIF
              ELSE
                IF (EX(28)) THEN
                  CALL PLA163 ('I41md  ')
                  CALL PLA163 ('I-42d  ')
                ELSE
                  IF (EX(24)) THEN
                    CALL PLA163 ('I4122  ')
                  ELSE
                    CALL PLA163 ('I-42m  ')
                    CALL PLA163 ('I-4m2  ')
                    CALL PLA163 ('I4mm   ')
                    CALL PLA163 ('I422   ')
                    CALL PLA163 ('I4/mmm ')
                  ENDIF
                ENDIF
              ENDIF
            ENDIF
          ENDIF
        ELSE IF (ILAT1 .EQ. 'P') THEN
          IF (LAUE .EQ. '  4/m') THEN
            IF (EX(15)) THEN
              IF (EX(18)) THEN
                CALL PLA163 ('P42/n  ')
              ELSE
                CALL PLA163 ('P4/n   ')
              ENDIF
            ELSE
              IF (EX(24)) THEN
                CALL PLA163 ('P41    ')
                CALL PLA163 ('P43    ')
              ELSE IF (EX(18)) THEN
                CALL PLA163 ('P42    ')
                CALL PLA163 ('P42/m  ')
              ELSE
                CALL PLA163 ('P-4    ')
                CALL PLA163 ('P4     ')
                CALL PLA163 ('P4/m   ')
              ENDIF
            ENDIF
          ELSE IF (LAUE .EQ. '4/mmm') THEN
            IF (EX(15)) THEN
              IF (EX(9)) THEN
                IF (EX(25) .OR. EX(33)) THEN
                  CALL PLA163 ('P4/nnc ')
                ELSE
                  CALL PLA163 ('P42/nnm')
                ENDIF
              ELSE IF (EX(8)) THEN
                IF (EX(25) .OR. EX(33)) THEN
                  CALL PLA163 ('P4/ncc ')
                ELSE
                  CALL PLA163 ('P42/ncm')
                ENDIF
              ELSE IF (EX(7)) THEN
                IF (EX(25) .OR. EX(33)) THEN
                  CALL PLA163 ('P42/nbc')
                ELSE
                  CALL PLA163 ('P4/nbm ')
                ENDIF
              ELSE
                IF (EX(25) .OR. EX(33)) THEN
                  CALL PLA163 ('P42/nmc')
                ELSE
                  CALL PLA163 ('P4/nmm ')
                ENDIF
              ENDIF
            ELSE
              IF (EX(9)) THEN
                IF (EX(25) .OR. EX(33)) THEN
                  CALL PLA163 ('P4nc   ')
                  CALL PLA163 ('P4/mnc ')
                ELSE
                  CALL PLA163 ('P-4n2  ')
                  CALL PLA163 ('P42nm  ')
                  CALL PLA163 ('P42/mnm')
                ENDIF
              ELSE IF (EX(8)) THEN
                IF (EX(25) .OR. EX(33)) THEN
                  CALL PLA163 ('P4cc   ')
                  CALL PLA163 ('P4/mcc ')
                ELSE
                  CALL PLA163 ('P-4c2  ')
                  CALL PLA163 ('P42cm  ')
                  CALL PLA163 ('P42/mcm')
                ENDIF
              ELSE IF (EX(7)) THEN
                IF (EX(25) .OR. EX(33)) THEN
                  CALL PLA163 ('P42bc  ')
                  CALL PLA163 ('P42/mbc')
                ELSE
                  CALL PLA163 ('P-4b2  ')
                  CALL PLA163 ('P4bm   ')
                  CALL PLA163 ('P4/mbm ')
                ENDIF
              ELSE
                IF (EX(25) .OR. EX(33)) THEN
                  IF (EX(17)) THEN
                    CALL PLA163 ('P-421c ')
                  ELSE
                    CALL PLA163 ('P42mc  ')
                    CALL PLA163 ('P-42c  ')
                    CALL PLA163 ('P42/mmc')
                  ENDIF
                ELSE
                  IF (EX(24)) THEN
                    IF (EX(17)) THEN
                      CALL PLA163 ('P41212 ')
                      CALL PLA163 ('P43212 ')
                    ELSE
                      CALL PLA163 ('P4122  ')
                      CALL PLA163 ('P4322  ')
                    ENDIF
                  ELSE IF (EX(18)) THEN
                    IF (EX(17)) THEN
                      CALL PLA163 ('P42212 ')
                    ELSE
                      CALL PLA163 ('P4222  ')
                    ENDIF
                  ELSE
                    IF (EX(17)) THEN
                      CALL PLA163 ('P4212  ')
                      CALL PLA163 ('P-421m ')
                    ELSE
                      CALL PLA163 ('P-42m  ')
                      CALL PLA163 ('P422   ')
                      CALL PLA163 ('P-4m2  ')
                      CALL PLA163 ('P4mm   ')
                      CALL PLA163 ('P4/mmm ')
                    ENDIF
                  ENDIF
                ENDIF
              ENDIF
            ENDIF
          ENDIF
        ENDIF
C***********************************************************************
C * TRI/HEXAGONAL LAUE CLASSES 6=-3, 7=-3m1, 8=-31m, 9=6/m, 10=6/mmm   *
C***********************************************************************
      ELSE IF (ILAT0 .EQ. 'h') THEN
        IF (LAUE .EQ. '  6/m') THEN
          IF (EX(31)) THEN
            CALL PLA163 ('P61    ')
            CALL PLA163 ('P65    ')
          ELSE IF (EX(39)) THEN
            CALL PLA163 ('P62    ')
            CALL PLA163 ('P64    ')
          ELSE IF (EX(18)) THEN
            CALL PLA163 ('P63    ')
            CALL PLA163 ('P63/m  ')
          ELSE
            CALL PLA163 ('P-6    ')
            CALL PLA163 ('P6     ')
            CALL PLA163 ('P6/m   ')
          ENDIF
        ELSE IF (LAUE .EQ. '6/mmm') THEN
          IF (EX(33) .OR. EX(11) .OR. EX(8)) THEN
            IF (EX(25) .OR. EX(35) .OR. EX(36)) THEN
              CALL PLA163 ('P6cc   ')
              CALL PLA163 ('P6/mcc ')
            ELSE
              CALL PLA163 ('P63cm  ')
              CALL PLA163 ('P-6c2  ')
              CALL PLA163 ('P63/mcm')
            ENDIF
          ELSE
            IF (EX(25) .OR. EX(35) .OR. EX(36)) THEN
              CALL PLA163 ('P63mc  ')
              CALL PLA163 ('P-62c  ')
              CALL PLA163 ('P63/mmc')
            ELSE
              IF (EX(31)) THEN
                CALL PLA163 ('P6122  ')
                CALL PLA163 ('P6522  ')
              ELSE IF (EX(39)) THEN
                CALL PLA163 ('P6222  ')
                CALL PLA163 ('P6422  ')
              ELSE IF (EX(18)) THEN
                CALL PLA163 ('P6322  ')
              ELSE
                CALL PLA163 ('P-62m  ')
                CALL PLA163 ('P6mm   ')
                CALL PLA163 ('P622   ')
                CALL PLA163 ('P-6m2  ')
                CALL PLA163 ('P6/mmm ')
              ENDIF
            ENDIF
          ENDIF
        ELSE
          IF (ILAT1 .EQ. 'R') THEN
            IF (LAUE .EQ. '   -3') THEN
              CALL PLA163 ('R3     ')
              CALL PLA163 ('R-3    ')
            ELSE IF (LAUE .EQ. ' -3m1') THEN
              IF (EX(33) .OR. EX(11) .OR. EX(8)) THEN
                CALL PLA163 ('R3c    ')
                CALL PLA163 ('R-3c   ')
              ELSE
                CALL PLA163 ('R3m    ')
                CALL PLA163 ('R32    ')
                CALL PLA163 ('R-3m   ')
              ENDIF
            ENDIF
          ELSE IF (ILAT1 .EQ. 'P') THEN
            IF (LAUE .EQ. '   -3') THEN
              IF (EX(39)) THEN
                CALL PLA163 ('P31    ')
                CALL PLA163 ('P32    ')
                IF (EXT(5) .EQ. '>') THEN
                  CALL PLA163 ('P-3    ')
                  CALL PLA163 ('R-3    ')
                ENDIF
              ELSE
                CALL PLA163 ('P3     ')
                CALL PLA163 ('P-3    ')
              ENDIF
            ELSE IF (LAUE .EQ. ' -3m1') THEN
              IF (EX(33) .OR. EX(8) .OR. EX(11)) THEN
                CALL PLA163 ('P3c1   ')
                CALL PLA163 ('P-3c1  ')
              ELSE
                IF (EX(39)) THEN
                  CALL PLA163 ('P3121  ')
                  CALL PLA163 ('P3221  ')
                  IF (EXT(47) .NE. '  ') THEN
                    CALL PLA163 ('R-3    ')
                  ENDIF
                ELSE
                  CALL PLA163 ('P321   ')
                  CALL PLA163 ('P3m1   ')
                  CALL PLA163 ('P-3m1  ')
                ENDIF
              ENDIF
            ELSE IF (LAUE .EQ. ' -31m') THEN
              IF (EX(25) .OR. EX(35) .OR. EX(36)) THEN
                CALL PLA163 ('P31c   ')
                CALL PLA163 ('P-31c  ')
              ELSE
                IF (EX(39)) THEN
                  CALL PLA163 ('P3112  ')
                  CALL PLA163 ('P3212  ')
                  IF (EXT(47) .NE. '  ') THEN
                    CALL PLA163 ('R-3    ')
                  ENDIF
                ELSE
                  CALL PLA163 ('P312   ')
                  CALL PLA163 ('P31m   ')
                  CALL PLA163 ('P-31m  ')
                ENDIF
              ENDIF
            ENDIF
          ENDIF
        ENDIF
C***********************************************************************
C * CUBIC   LAUE CLASS 11 : m-3 , 12 : m-3m                            *
C***********************************************************************
      ELSE IF (ILAT0 .EQ. 'c') THEN
        IF (ILAT1 .EQ. 'F') THEN
          IF (EX(19)) THEN
            IF ((EX(25) .OR. EX(33)) .AND. (EX(26) .OR. EX(43))) THEN
              CALL PLA163 ('Fd-3c  ')
            ELSE
              IF (LAUE .EQ. ' m-3m') THEN
                CALL PLA163 ('Fd-3m  ')
              ELSE
                CALL PLA163 ('Fd-3   ')
              ENDIF
            ENDIF
          ELSE
            IF ((EX(25) .OR. EX(33)) .AND. (EX(26) .OR. EX(43))) THEN
              CALL PLA163 ('F-43c  ')
              CALL PLA163 ('Fm-3c  ')
            ELSE
              IF (EX(24)) THEN
                CALL PLA163 ('F4132  ')
              ELSE
                IF (LAUE .EQ. ' m-3m') THEN
                  CALL PLA163 ('F-43m  ')
                  CALL PLA163 ('F432   ')
                  CALL PLA163 ('Fm-3m  ')
                ELSE
                  CALL PLA163 ('F23    ')
                  CALL PLA163 ('Fm-3   ')
                ENDIF
              ENDIF
            ENDIF
          ENDIF
        ELSE IF (ILAT1 .EQ. 'I') THEN
          IF (EX(7) .AND. EX(8)) THEN
            IF (EX(25) .AND. EX(28)) THEN
              CALL PLA163 ('Ia-3d  ')
            ELSE
              CALL PLA163 ('Ia-3   ')
            ENDIF
          ELSE
            IF (EX(25) .AND. EX(28)) THEN
              CALL PLA163 ('I-43d  ')
            ELSE
              IF (EX(24)) THEN
                CALL PLA163 ('I4132  ')
              ELSE
                IF (LAUE .EQ. ' m-3m') THEN
                  CALL PLA163 ('I-43m  ')
                  CALL PLA163 ('I432   ')
                  CALL PLA163 ('Im-3m  ')
                ELSE
                  CALL PLA163 ('I23    ')
                  CALL PLA163 ('I213   ')
                  CALL PLA163 ('Im-3   ')
                ENDIF
              ENDIF
            ENDIF
          ENDIF
        ELSE IF (ILAT1 .EQ. 'P') THEN
          IF (EX(9)) THEN
            IF (LAUE .EQ. ' m-3m') THEN
              IF (EX(25) .OR. EX(33)) THEN
                CALL PLA163 ('Pn-3n  ')
              ELSE
                CALL PLA163 ('Pn-3m  ')
              ENDIF
            ELSE
              CALL PLA163 ('Pn-3   ')
            ENDIF
          ELSE IF (EX(7) .OR. EX(11) .OR. EX(13)) THEN
            CALL PLA163 ('Pa-3   ')
          ELSE IF (EX(8) .OR. EX(10) .OR. EX(14)) THEN
            CALL PLA163 ('Pb-3   ')
          ELSE
            IF (EX(25) .OR. EX(33)) THEN
              CALL PLA163 ('P-43n  ')
              CALL PLA163 ('Pm-3n  ')
            ELSE
              IF (EX(24)) THEN
                CALL PLA163 ('P4132  ')
                CALL PLA163 ('P4332  ')
              ELSE IF (EX(18)) THEN
                IF (LAUE .EQ. ' m-3m') THEN
                  CALL PLA163 ('P4232  ')
                ELSE
                  CALL PLA163 ('P213   ')
                ENDIF
              ELSE
                IF (LAUE .EQ. ' m-3m') THEN
                  CALL PLA163 ('P432   ')
                  CALL PLA163 ('P-43m  ')
                  CALL PLA163 ('Pm-3m  ')
                ELSE
                  CALL PLA163 ('P23    ')
                  CALL PLA163 ('Pm-3   ')
                ENDIF
              ENDIF
            ENDIF
          ENDIF
        ENDIF
      ENDIF
      RETURN
      END
      SUBROUTINE PLA169 (MODE, IRII, IRISIG, SINTL, LU)
      COMMON /STAT9/ ST(20, 3), NSTAT(20, 3), NSTOT(20)
      CHARACTER BALK*40
      COMMON /FSPGR/ CRI(11), PNZ(13, 10), STLS(10)
      IF (MODE .EQ. 0) THEN
        CALL GEN097 (NSTOT, 1, 20, 0)
        CALL GEN097 (NSTAT, 1, 60, 0)
        CALL GEN074 (ST,  0.0, 1, 60)
      ELSE IF (MODE .EQ. 1) THEN
        DO 10 I = 1, 10
          IF (SINTL .LT. STLS(I)) GOTO 20
   10   CONTINUE
        GOTO 30
   20   NSTOT(I) = NSTOT(I) + 1
        RSIG     = IRISIG
        IRI      = IRII
        IF (IRI .LE. 0) IRI = 1
        IF (RSIG .LE. 0.0) RSIG = SQRT(FLOAT(IRI))
        XIDSI = FLOAT(IRI) / RSIG
        IF (XIDSI .GE. 0.25) THEN
          NSTAT(I, 1) = NSTAT(I, 1) + 1
          IF (XIDSI .GT. 1.0) THEN
            NSTAT(I, 2) = NSTAT(I, 2) + 1
            IF (XIDSI .GE. 2.0) THEN
              NSTAT(I, 3) = NSTAT(I, 3) + 1
            ENDIF
          ENDIF
        ENDIF
   30   CONTINUE
      ELSE IF (MODE .EQ. -1) THEN
        DO 50 I = 1, 20
          IF (NSTOT(I) .GT. 0) THEN
            DO 40 J = 1, 3
              ST(I, J) = 100.0 * NSTAT(I, J) / NSTOT(I)
   40       CONTINUE
          ENDIF
   50   CONTINUE
      ELSE IF (MODE .EQ. -2) THEN
        WRITE (LU, 99999)
        DO 70 I = 1, 20
          IF (NSTOT(I) .GT. 0) THEN
            L = NINT (ST(I, 3) * 0.4)
            DO 60 K = 1, 40
              IF (K .GT. L) THEN
                BALK(K:K) = '.'
              ELSE
                BALK(K:K) = '*'
              ENDIF
   60       CONTINUE
            WRITE (LU, 99998) I, STLS(I), 1 / (2 * STLS(I)), NSTOT(I),
     1            (ST(I, J), J = 1, 3), BALK
          ENDIF
   70   CONTINUE
        WRITE (LU, 99997)
      ENDIF
      RETURN
99999 FORMAT (/, 'Intensity Distribution', /, 80('='), //,
     1        'sh st/l  Ang     #  0.25   1.0   2.0  ',
     2        '0 Percent  Distr. for I gt 2.0 s(I)  100',
     3        /, 80('='))
99998 FORMAT (I2, 2F5.2, I6, 3F6.1, 2X, A)
99997 FORMAT (36X, 'I', 19X, 'I', 19X, 'I', /,
     1        36X, '0%',17X, '50%', 16X, '100%')
      END
      SUBROUTINE PLA170 (N, M0, M)
      PARAMETER (NPVD=40000000,NP18=50,NP23=18000,NCS=50,NZM = 200000,
     1           NRS = NPVD - 10 * NZM)
      COMMON // XYZDUM(2, NP23), RS(NRS), TNZ(NZM, 10)
      COMMON /DFSPGR/ SUM(NCS, 5), NUM(NCS, 5), XMFS(NCS), XTL(12),
     1 XNM(12), NNZ(13), ANZ(13), IR(3), IN(24), XN(48), FMN(12),
     2 ITL(12), AVNZ(3), NREF, IPERC, TRMX(3, 3), LU, ISPGRC, ISPGRA,
     3 ISPGRH, IPCNTC, IPCNTA, IPCNTH, IFRQC, IFRQA, IFRQH, RAVERC,
     4 RAVERA, RAVERH
      COMMON /LPLAT/ TLATT(9, NP18), XCELL(7, NP18), LLAUE(NP18),
     1 RVL(12, 3), NTL(12, 3), RVAL(NP18, 3), NRLT0, NRLT, NREXT,
     2 RMAX, AVIOS
      COMMON /HKLMX/ HMAX, KMAX, LMAX, IHM, IHKM, IHKP
      INTEGER HMAX
      FMN(N) = 0.0
      ITL(N) = 0
      NCNT   = 0
      IF (RS(IN(M0)) .GT. -1.5) NTL(N, 1) = NTL(N, 1) + 1
      DO 20 J = M0, M
        DO 10 K = 1, 2
          IF (K .EQ. 1) THEN
            INJ = IN(J)
            L   = J
          ELSE
            INJ = - IN(J) + 2 * IHKP
            L   = J + 24
          ENDIF
          XN(L) = RS(INJ)
          RS(INJ) = -2.0
          IF (XN(L) .GT. - 0.5) THEN
            NCNT = 1
            IF (XN(L) .GT. 0.0) THEN
              FMN(N) = FMN(N) + XN(L)
              ITL(N) = ITL(N) + 1
            ENDIF
          ENDIF
   10   CONTINUE
   20 CONTINUE
      NTL(N, 2) = NTL(N, 2) + NCNT
      IF (ITL(N) .GT. 1) THEN
        FMN(N)    = FMN(N) / ITL(N)
        NTL(N, 3) = NTL(N, 3) + 1
        DO 40 J = M0, M
          DO 30 K = 1, 2
            IF (K .EQ. 1) THEN
            INJ = IN(J)
              L   = J
            ELSE
            INJ = - IN(J) + 2 * IHKP
            L   = J + 24
            ENDIF
            IF (XN(L) .GT. 0.0) THEN
              XTL(N) = XTL(N) + ABS(XN(L) - FMN(N))
              XNM(N) = XNM(N) + XN(L)
            ENDIF
   30     CONTINUE
   40   CONTINUE
      ENDIF
      RETURN
      END
      SUBROUTINE PLA171 (LRET0, TM, LU, ISPR47, YPAR, KNN)
      PARAMETER (NP12=600,NP13=500,NP17=99,NP18=50,NP38=125,NP39=30,
     1 NP45=2048,NSITE=70)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /Q/ ICL, IFL(NP17)
      CHARACTER ICL*(NP45), IFL*7
      COMMON /SLAUE/ NLAUE, XSYST, IBVL, SITE
      CHARACTER NLAUE(14)*5, XSYST(8)*12, IBVL(8)*1, SITE(NSITE)*5
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0
      COMMON /LPLAT/ TLATT(9, NP18), XCELL(7, NP18), LLAUE(NP18),
     1 RVL(12, 3), NTL(12, 3), RVAL(NP18, 3), NRLT0, NRLT, NREXT,
     2 RMAX, AVIOS
      COMMON /LPLATC/ BLATT(NP18), CLATT(NP18)
      CHARACTER BLATT*1, CLATT*1
      COMMON /CGG11/ BCD, SBCD
      CHARACTER BCD*132, SBCD*132
      COMMON /CGGT/ IGGT
      CHARACTER IGGT*80
      CHARACTER LINE*80, LIJN*80, ICH*1
      DIMENSION YPAR(*), TM(3, 3), FNN(9), DUM(3, 3),
     1  AA(3, 3), BB(3, 3)
      CHARACTER NSYS*1
      LOGICAL EXST
      EXST = .FALSE.
      IF (KNN .EQ. 9) THEN
        DO 10 I = 1, 9
          FNN(I) = FN(I)
   10   CONTINUE
      ENDIF
   20 IF (IGBL(50) .EQ. 0) THEN
        BCD(1:16) = 'S.Y.S.T.E.M - S'//CHAR(0)
        CALL GGIP (HORS, VERT, 0.0, 1)
        VRT = VERT - 0.7
        IF (NREXT .GT. 0) THEN
          LIJN = '(Pseudo)Extinctions Found in Input Reflection file'
          CALL GGIP20 (0.0, LIJN, 80, 0.375, 2, 2, 0.1, VRT)
          VRT = VRT - 0.2
          CALL GGIP (0.0,  VRT, 0.0, 3)
          CALL GGIP (HORS, VRT, 0.0, 2)
          VRT = VRT - 0.5
          LIJN = '    Ex. Condition    av[I/sig(I)]  Number of Refl '//
     1           'I/sigI             .T./.F.'
          CALL GGIP20 (0.0, LIJN, 80, 0.375, 5 + IGBL(68), 2, 0.1, VRT)
          VRT = VRT - 0.5
          LIJN = '                    .True. .False. .True. .False.'//
     1           '  Max.F    H  K  L   Ratio'
          CALL GGIP20 (0.0, LIJN, 80, 0.375, 5 + IGBL(68), 2, 0.1, VRT)
          VRT = VRT - 0.2
          CALL GGIP (0.0,  VRT, 0.0, 3)
          CALL GGIP (HORS, VRT, 0.0, 2)
          VRT = VRT - 0.5
   30     READ (LU, 99988, END = 40) LINE
          IF (LINE(1:4) .EQ. 'EXTI') THEN
            CALL GGIP20 (0.0, LINE(6:80), 75, 0.375, 1, 2, 0.1, VRT)
            VRT = VRT - 0.5
          ENDIF
          GOTO 30
   40     VRT = VRT + 0.3
          CALL GGIP (0.0,  VRT, 0.0, 3)
          CALL GGIP (HORS, VRT, 0.0, 2)
          VRT = VRT - 0.5
        ENDIF
        LIJN = 'Cell Transformations to Optional Crystal System, '//
     1         'Lattice Type and Laue Class'
        CALL GGIP20 (0.0, LIJN, 80, 0.375, 2, 2, 0.1, VRT)
        VRT = VRT - 0.3
        CALL GGIP (0.0,  VRT, 0.0, 3)
        CALL GGIP (HORS, VRT, 0.0, 2)
        LIJN = ' # Latt Laue Rav %Ct %Nav       '//
     1   'Transformation Matrix / Cell + Volume'
        VRT = VRT - 0.5
        CALL GGIP20 (0.0, LIJN, 80, 0.375, 5 + IGBL(68), 2, 0.1, VRT)
        VRT = VRT - 0.2
        CALL GGIP (0.0,  VRT, 0.0, 3)
        CALL GGIP (HORS, VRT, 0.0, 2)
        VRT = VRT - 0.2
        PAR(360) = VRT
        PAR(361) = 0.75
        DO 50 K = 1, NRLT0
          VRT = VRT - 0.5
          IF (RVAL(K, 1) .LT. RMAX .AND.
     1        (RVAL(K, 2) .GT. 80 .OR. RVAL(K, 1) .LT. 0.001)) THEN
            ICOL = 3
          ELSE
            ICOL = 2
          ENDIF
          WRITE (LIJN, 99998) K, CLATT(K), BLATT(K),
     1      NLAUE(LLAUE(K)), (NINT(RVAL(K, J)), J = 1, 3),
     2      (TLATT(J, K), J = 1, 9)
          CALL GEN065 (0, LIJN, 80, 5)
          CALL GGIP20 (0.0, LIJN, 80, 0.35, ICOL, 2, 0.1, VRT)
          WRITE (LIJN, 99997) (XCELL(J, K), J = 1, 7)
          VRT = VRT - 0.25
          CALL GGIP20 (0.0, LIJN, 80, 0.20, 1, 1, 9.0, VRT)
   50   CONTINUE
        ISPR47 = 0
        IF (KNN .EQ. 9) THEN
          DO 60 I = 1, 9
            FN(I) = FNN(I)
   60     CONTINUE
          KNN = 0
          KN  = 9
          KL  = 0
        ENDIF
        IF (KN .EQ. 9) GOTO 90
        INQUIRE (FILE = '.newsym.ntr', EXIST = EXST)
        IF (EXST) THEN
          OPEN (LU61, FILE = '.newsym.ntr', STATUS = 'UNKNOWN')
          READ (LU61, 99988) LINE
          CLOSE (LU61, STATUS = 'DELETE')
          ISPR47 = 1
          GOTO 80
        ENDIF
   70   WRITE (SBCD, 99996) NRLT, CHAR(0)
        IGBL(28) = 1
        CALL PLA013 (0, 1)
        IGBL(28) = 0
        IF (IGGT(1:4) .EQ. 'PLOT') GOTO 20
        IF (IGGT(1:4) .EQ. 'EXIT') GOTO 220
        IF (IGGT(1:1) .NE. ' ' .AND. IGGT(1:1) .NE. '!') THEN
          LINE = IGGT
          CALL GEN038 (IGGT, 1, 80)
        ELSE
          WRITE (LINE, 99987) NRLT
        ENDIF
   80   CALL GEN072 (LINE, IFL, FN, KL, KN, 0, LU6, 1, 1, 80, 7, NP17)
   90   IF (KN .EQ. 1 .AND. FN(1) .GT. 0 .AND. FN(1) .LE. NRLT0)  THEN
          NRLT = NINT(FN(1))
        ELSE IF (KN .EQ. 0 .AND. KL .EQ. 0) THEN
          GOTO 150
        ELSE IF (KN .GE. 9) THEN
          CALL GEN003 (FN(1), DUM, DET, 0)
          IF (ABS(DET) .LT. 0.01) THEN
            WRITE (LU6, 99994)
            GOTO 70
          ENDIF
          DO 100 I = 1, 9
            TLATT(I, NP18) = FN(I)
            K = (I - 1) / 3 + 1
            J = MOD (I - 1, 3) + 1
            TM(K, J) = FN(I)
  100     CONTINUE
          CLATT(NP18) = ' '
          BLATT(NP18) = ' '
          LLAUE(NP18)  = 13
          RVAL(NP18, 1)  = 0.0
          RVAL(NP18, 2)  = 0.0
          RVAL(NP18, 3)  = 0.0
          IF (KL .GT. 0 .AND. IFL(KL)(1:4) .NE. 'TRMX') THEN
            CLATT(NP18) = IFL(KL)(1:1)
            BLATT(NP18) = IFL(KL)(2:2)
            CALL GEN020 (-1, CLATT(NP18), 1, 1)
            CALL GEN020 (1,  BLATT(NP18), 1, 1)
          ENDIF
          DO 120 K = 1, NRLT0
            DO 110 I = 1, 9
              IF (TLATT(I, K) .NE. TLATT(I, NP18)) GOTO 120
  110       CONTINUE
            IF (BLATT(K) .NE. BLATT(NP18)) GOTO 120
            IF (CLATT(K) .NE. CLATT(NP18)) GOTO 120
            NRLT = K
            GOTO 70
  120     CONTINUE
          NRLT0 = NRLT0 + 1
          CALL GEN026 (1, AA, YPAR(81), GL(5))
          CALL GEN003 (AA, BB, DET, 0)
          YPAR(95)  = BB(1, 1)
          YPAR(96)  = BB(2, 2)
          YPAR(97)  = BB(3, 3)
          YPAR(98)  = BB(2, 3)
          YPAR(99)  = BB(1, 3)
          YPAR(100) = BB(1, 2)
          CALL GEN001 (1, TM, AA, BB)
          CALL GEN026 (-1, BB, YPAR(101), GL(5))
          CALL GEN003 (BB, AA, DET, 0)
          YPAR(107) = SQRT(DET)
          DO 130 I = 1, 9
            TLATT(I, NRLT0) = TLATT(I, NP18)
  130     CONTINUE
          DO 140 I = 1, 7
            XCELL(I, NRLT0) = YPAR(100 + I)
  140     CONTINUE
          CLATT(NRLT0) = CLATT(NP18)
          BLATT(NRLT0) = BLATT(NP18)
          LLAUE(NRLT0) = 13
          NRLT  = NRLT0
          IF (ISPR47 .EQ. 0) GOTO 20
        ELSE
          CALL PLA015 (0, 24)
          GOTO 70
        ENDIF
      ENDIF
  150 IF (CLATT(NRLT) .EQ. ' ') THEN
        IF (ISPR47 .EQ. 1) THEN
          IFL(1) = IFL(2)
          GOTO 170
        ENDIF
  160   WRITE (BCD, 99993) CHAR(0)
        CALL GGIP (-999.0, 3.0, 80.0, 112)
        NALF = 0
        NBET = 0
        NGAM = 0
        NA12 = 0
        NA13 = 0
        NA23 = 0
        NSYS = 'a'
        IF (ABS(XCELL(4, NRLT) - 90.0)  .LT. 0.05) NALF = 1
        IF (ABS(XCELL(5, NRLT) - 90.0)  .LT. 0.05) NBET = 1
        IF (ABS(XCELL(6, NRLT) - 90.0)  .LT. 0.05) NGAM = 1
        IF (ABS(XCELL(6, NRLT) - 120.0) .LT. 0.05) NGAM = 2
        IF (ABS(XCELL(1, NRLT) - XCELL(2, NRLT)) .LT. 0.01) NA12 = 1
        IF (ABS(XCELL(1, NRLT) - XCELL(3, NRLT)) .LT. 0.01) NA13 = 1
        IF (ABS(XCELL(2, NRLT) - XCELL(3, NRLT)) .LT. 0.01) NA23 = 1
        IF (NALF + NBET + NGAM .EQ. 1) THEN
          NSYS = 'm'
        ELSE IF (NALF .EQ. 1 .AND. NBET .EQ. 1 .AND. NGAM .EQ. 2) THEN
          IF (NA12 .EQ. 1) THEN
            NSYS = 'h'
          ELSE
            NSYS = 'm'
          ENDIF
        ELSE IF (NALF .EQ. 1 .AND. NBET .EQ. 1 .AND. NGAM .EQ. 1) THEN
          IF (NA12 .EQ. 1 .AND. NA13 .EQ. 1 .AND. NA23 .EQ. 1) THEN
            NSYS = 'c'
          ELSE IF (NA12 .EQ. 1) THEN
            NSYS = 't'
          ELSE
            NSYS = 'o'
          ENDIF
        ENDIF
        WRITE (SBCD, 99987) NRLT, NSYS, CHAR(0)
        CALL PLA013 (0, 1)
        IF (IGGT(1:4) .EQ. 'PLOT') GOTO 160
        IF (IGGT(1:4) .EQ. 'EXIT') GOTO 220
        IF (IGGT(1:1) .NE. ' ' .AND. IGGT(1:1) .NE. '!') THEN
          LINE = IGGT
          CALL GEN038 (IGGT, 1, 80)
        ELSE
          LINE = NSYS
        ENDIF
        CALL GEN072 (LINE, IFL, FN, KL, KN, 0, LU6, 1, 1, 80, 7, NP17)
  170   CLATT(NRLT) = IFL(1)(1:1)
        BLATT(NRLT) = IFL(1)(2:2)
        CALL GEN020 (-1, CLATT(NRLT), 1, 1)
        CALL GEN020 ( 1, BLATT(NRLT), 1, 1)
        GOTO 150
      ENDIF
      IF (BLATT(NRLT) .EQ. ' ') THEN
  180   WRITE (BCD, 99990) CHAR(0)
        CALL GGIP (-999.0, 3.0, 80.0, 112)
        WRITE (SBCD, 99992) NRLT, CHAR(0)
        CALL PLA013 (0, 1)
        IF (IGGT(1:4) .EQ. 'PLOT') GOTO 180
        IF (IGGT(1:4) .EQ. 'EXIT') GOTO 220
        IF (IGGT(1:1) .NE. ' ' .AND. IGGT(1:1) .NE. '!') THEN
          LINE = IGGT
          CALL GEN038 (IGGT, 1, 80)
        ELSE
          LINE = 'P '
        ENDIF
        CALL GEN072 (LINE, IFL, FN, KL, KN, 0, LU6, 1, 1, 80, 7, NP17)
        BLATT(NRLT) = IFL(1)(1:1)
        CALL GEN020 (1, BLATT(NRLT), 1, 1)
      ENDIF
      IF (LLAUE(NRLT) .EQ. 13) THEN
        IF (ISPR47 .EQ. 1) THEN
          FN(1) = FN(10)
          GOTO 200
        ENDIF
  190   WRITE (BCD, 99989) CHAR(0)
        CALL GGIP (-999.0, 3.0, 80.0, 112)
        ICH = CLATT(NRLT)
        IF (ICH .EQ. 'a') THEN
          IVAL = 1
        ELSE IF (ICH .EQ. 'm') THEN
          IVAL = 2
        ELSE IF (ICH .EQ. 'o') THEN
          IVAL = 3
        ELSE IF (ICH .EQ. 't') THEN
          IVAL = 4
        ELSE IF (ICH .EQ. 'h') THEN
          IF (BLATT(NRLT) .EQ. 'R') THEN
            IVAL = 6
          ELSE
            IVAL = 9
          ENDIF
        ELSE IF (ICH .EQ. 'c') THEN
          IVAL = 11
        ENDIF
        WRITE (SBCD, 99991) NRLT, IVAL, CHAR(0)
        CALL PLA013 (0, 1)
        IF (IGGT(1:4) .EQ. 'PLOT') GOTO 190
        IF (IGGT(1:4) .EQ. 'EXIT') GOTO 220
        IF (IGGT(1:1) .NE. ' ' .AND. IGGT(1:1) .NE. '!') THEN
          LINE = IGGT
          CALL GEN038 (IGGT, 1, 80)
        ELSE
          WRITE (LINE, 99999) IVAL
        ENDIF
        CALL GEN072 (LINE, IFL, FN, KL, KN, 0, LU6, 1, 1, 80, 7, NP17)
        IF (KN .EQ. 0) FN(1) = 1.0
        IF (NINT(FN(1)) .LT. 1 .OR. NINT(FN(1)) .GT. 12) FN(1) = 1.0
  200   LLAUE(NRLT) = NINT(FN(1))
        DO 210 I = 1, 3
          RVAL(NRLT, I) = RVL(LLAUE(NRLT), I)
  210   CONTINUE
        IF (ISPR47 .EQ. 0) GOTO 20
      ENDIF
      RETURN
  220 LRET0 = 1
      RETURN
99999 FORMAT (I3)
99998 FORMAT (I2, ' = ', A, A, 1X, A, 3I4, 1X, 9F6.3)
99997 FORMAT (3F7.3, 3F7.2, F10.0)
99996 FORMAT ('Enter TRMX Matrix or Click on / Select TRMX #[', I2, ']',
     1         A)
99994 FORMAT (':: Error - Determinant TRMX = 0.0', /)
99993 FORMAT ('a=Anorthic, m=Monoclinic, o=Orthorhombic, ',
     1        't=Tetragonal, h=hexagonal, c=cubic', A)
99992 FORMAT ('Enter Lattice Centering Type for TRMX #', I3, '[P]', A)
99991 FORMAT ('Enter Laue Class for TRMX #', I3, '[', I2, ']', A)
99990 FORMAT ('Options:  P, A, B, C, F, I, R :', A)
99989 FORMAT ('1=-1,2=2/m,3=mmm,4=4/m,5=4/mmm,6=-3,',
     1        '7=-3m1,8=-31m,9=6/m,10=6/mmm,11=m-3,12=m-3m',A)
99988 FORMAT (A)
99987 FORMAT ('Enter Crystal System for TRMX #', I3, '[', A, ']', A)
      END
      SUBROUTINE PLA172
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118,
     1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NPVD=40000000,
     2 NP22=256,NP23=18000,NP25=99,NP29=63,NP38=125,NP39=30,NP41=200,
     3 NP45=2048,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /Q/ ICL, IFL(NP17)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9),
     1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10),
     2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10),
     3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770)
      COMMON // JNSC(2, NP23), VOID(NPVD)
      CHARACTER N113*3
      DIMENSION LV(6)
      NRES  = 0
      K     = 0
      JSORT = 0
      LVK   = 0
      J0    = 0
      ISL   = 0
C * TABLE LIST FUNCTION
C***********************************************************************
C***********************************************************************
C***********************************************************************
      CALL GEN108 (LU2, 0)
      IPR(239) = 0
      IPR(245) = IPR(37)  * 12
      IPR(246) = IPR(245) * 2
      IPR(247) = IPR(246) + IPR(251) * 4
      IPR(248) = IPR(247) + IPR(252) * 5
      IPR(249) = IPR(248) + IPR(253) * 6
      IPR(250) = IPR(249) + IPR(254) * 4
      IPR(233) = IPR(37) * 2
      IPR(234) = IPR(233) + IPR(251) * 2
      IPR(235) = IPR(234) + IPR(252) * 2
      IPR(236) = IPR(235) + IPR(253) * 2
      IF (IPR(236) .GT. NP23) THEN
        IPR(236) = IPR(235)
        IPR(237) = IPR(235)
        IPR(238) = IPR(235)
        IPR(253) = 0
        IPR(254) = 0
        IPR(452) = 0
        WRITE (LU6, 99998)
        WRITE (LU6, 99997)
        WRITE (LU6, 99996)
      ELSE
        IPR(237) = IPR(236) + IPR(254) * 2
        IF (IPR(237) .GT. NP23) THEN
          IPR(237) = IPR(236)
          IPR(238) = IPR(236)
          IPR(254) = 0
          IPR(452) = 0
          WRITE (LU6, 99997)
          WRITE (LU6, 99996)
        ELSE
          IPR(238) = IPR(237) + IPR(452) * 2
          IF (IPR(238) .GT. NP23) THEN
            IPR(238) = IPR(237)
            IPR(452) = 0
            WRITE (LU6, 99996)
          ENDIF
        ENDIF
      ENDIF
      IPR(226) = 0
      IPR(227) = IPR(233)
      IPR(228) = IPR(234)
      IPR(229) = IPR(235)
      IPR(230) = IPR(236)
      IPR(231) = IPR(237)
      LV(1)    = 1
      LV(2)    = IPR(246) + 1
      LV(3)    = IPR(247) + 1
      LV(4)    = IPR(248) + 1
      LV(5)    = IPR(249) + 1
      LV(6)    = IPR(250) + 1
      K0       = 0
   10 IPR53S   = IGBL(5)
      IGBL(5)  = LU2
      CALL PLA006 (0, IS)
      IF (IS .GE. 0) THEN
        IGBL(5) = IPR53S
        N113    = IFL(1)(1:3)
        IF (N113 .EQ. 'RES') THEN
          NRES = NINT(FN(1))
          GOTO 10
        ELSE IF (IS .GT. 24 .AND. IS .LT. 29) THEN
          K0 = 1
          K  = 1
        ELSE IF (N113 .EQ. 'BON') THEN
          K0 = 2
          K  = 2
        ELSE IF (N113 .EQ. 'ANG') THEN
          K0 = 3
          K  = 3
        ELSE IF (N113 .EQ. 'TOR') THEN
          K0 = 4
          K  = 4
        ELSE IF (N113 .EQ. 'NON') THEN
          K0 = 5
          K  = 2
        ELSE IF (N113 .EQ. 'HBO') THEN
          K0 = 6
          K  = 3
        ENDIF
        IF (K0 .GT. 0) THEN
          NQH = 0
          DO 20 I = 1, K
            NQ1 = IFL(I + 1)
            CALL PLA046 (1, NQ1, IENM, LBB, LBC, LBD,
     1                   VOID(LV(K0) + I - 1), V1(I), NIEN)
            IF (NIEN .GE. 0) THEN
              NIEN = IEN(NIEN + 1)
              IF (NIEN .EQ. 1 .OR. NIEN .EQ. 33 .OR.
     1            NIEN .EQ. 113) THEN
                IF (IPR(454) .EQ. 0) GOTO 10
                NQH = IPR(465)
              ENDIF
            ELSE
              WRITE (LU6, 99999) IFL(I + 1), NIEN, NQ1
              GOTO 10
            ENDIF
   20     CONTINUE
          IF (K0 .EQ. 1) THEN
            IF (IS .EQ. 28) THEN
C * ATOM
              JSORT = NINT(V1(2))
              LVK = LV(K0) * 16 + 5
              XJX(1)  = FN(1)
              XJX(2)  = FN(2)
              XJX(3)  = FN(3)
              XJX(10) = 0.0
              CALL SGSM (IDM, 0, XJX, LU6, 19, IERR)
              FN(4)  = FN(4) / XJX(10)
              FN(8)  = FN(8) / XJX(10)
              J0     = 4
              GOTO 50
            ELSE IF (IS .EQ. 25) THEN
C * UIJ
              JNSC(2, IPR(225 + K0)) = LVK + 7
              ISL = LV(K0)
              DO 30 J = 1, 7
                VOID(LV(K0)) = FN(J)
                LV(K0) = LV(K0) + 1
   30         CONTINUE
            ELSE IF (IS .EQ. 26) THEN
C * SUIJ
              DO 40 J = 1, 7
                VOID(ISL + IPR(245)) = FN(J)
                ISL = ISL + 1
   40         CONTINUE
            ELSE IF (IS .EQ. 27) THEN
C * U
              JNSC(2, IPR(225 + K0))  = LVK + 1
              VOID(LV(K0))            = FN(1)
              VOID(LV(K0) + IPR(245)) = FN(2)
              LV(K0)                  = LV(K0) + 1
            ENDIF
            GOTO 10
          ELSE IF (K0 .EQ. 2) THEN
            IF (V1(1) .GT. V1(2)) THEN
              CALL GEN018 (V1(1), V1(2))
              CALL GEN018 (VOID(LV(K0)), VOID(LV(K0) + 1))
            ENDIF
            JSORT = NINT(V1(1))
            J0 = 2
          ELSE IF (K0 .EQ. 3) THEN
            IF (V1(1) .GT. V1(3)) THEN
              CALL GEN018 (V1(1), V1(3))
              CALL GEN018 (VOID(LV(K0)), VOID(LV(K0) + 2))
            ENDIF
            JSORT = NINT(V1(2))
            J0 = 2
          ELSE IF (K0 .EQ. 4) THEN
            IF (V1(2) .GT. V1(3)) THEN
              CALL GEN018 (V1(2), V1(3))
              CALL GEN018 (V1(1), V1(4))
              CALL GEN018 (VOID(LV(K0) + 1), VOID(LV(K0) + 2))
              CALL GEN018 (VOID(LV(K0)), VOID(LV(K0) + 3))
            ENDIF
            JSORT = NINT(V1(2))
            J0    = 2
          ELSE IF (K0 .EQ. 5) THEN
            J0    = 2
            JSORT = NINT(V1(1))
          ELSE IF (K0 .EQ. 6) THEN
            J0    = 8
            JSORT = NINT(V1(1))
            VOID(LV(K0) + 2) = FN(9)
          ENDIF
          LVK = LV(K0)
   50     IF (IPR(225 + K0) .LT. IPR(232 + K0)) THEN
            IPR(225 + K0)          = IPR(225 + K0) + 1
            JNSC(1, IPR(225 + K0)) = JSORT
     1                             + NQH + IPR(240) * IPR(466) * NRES
            JNSC(2, IPR(225 + K0)) = LVK
            DO 60 J = 1, J0
              VOID(LV(K0) + K + J - 1) = FN(J)
              IF (IS .EQ. 28)
     1            VOID(LV(K0) + K + J + IPR(245) - 1) = FN(J + 4)
   60       CONTINUE
            LV(K0) = LV(K0) + K + J0
          ENDIF
        ENDIF
        GOTO 10
C * END OF FILE
      ENDIF
      CALL GEN108 (LU2, 0)
      IF (IPR(226) .GT. 0) THEN
      CALL GEN037 (JNSC, 1, IPR(226))
      CALL GEN037 (JNSC, IPR(233) + 1, IPR(227))
      CALL GEN037 (JNSC, IPR(234) + 1, IPR(228))
      IF (IPR(253) .GT. 0) CALL GEN037 (JNSC, IPR(235) + 1, IPR(229))
      IF (IPR(254) .GT. 0) CALL GEN037 (JNSC, IPR(236) + 1, IPR(230))
C * LIST SECTION
      I = IPR(431)
      IF (I .GE. 0) THEN
C * TITLE PAGE SUPPLEMENTARY MATERIAL
        CALL PLA173 (-1, LU13, 0, 0)
      ELSE
C * CIF - HEADER
        CALL PLA173 (-1, LU2, 0, 0)
      ENDIF
C * CRYSTAL DATA                   PUB
      IF (I .EQ.  2) CALL PLA173 (0, LU12, 1, 0)
      IF (I .EQ.  3) CALL PLA173 (0, LU12, 0, 0)
C * CIF - FILE CRYSTAL DATA
      IF (I .LT.  0) CALL PLA173 (0, LU2, 1, 0)
C * CRYSTAL DATA                   SUP (SU, JA, IC)
      IF (I .EQ. 0 .OR. I .EQ. 3) CALL PLA173 (0, LU13, 1, 0)
C * ATOMS FOR CIF
      IF (I .LT.  0) CALL PLA173 (1, LU2, 1, 0)
C * NON-H ATOMS                    PUB (AC, JA, IC)
      IF (I .EQ. 1 .OR. I .EQ. 2 .OR. I .EQ. 3)
     1    CALL PLA173 (1, LU12, 0, 0)
C * NON-H ATOMS                    SUP (SU, IC)
      IF (I .EQ. 0 .OR. I .EQ. 3) CALL PLA173 (1, LU13, 0, 0)
C * H -ATOMS                       SUP
      IF (IPR(484) .GT. 0) THEN
        IF (I .GE.  0) CALL PLA173 (2, LU13, 1, 0)
        IF (I .LT.  0) CALL PLA173 (2, LU2, 1, 0)
        ENDIF
C * ANISOTROPIC DISPLACEMENT PARAMETERS SUP
        IF (IPR(32) .EQ. 2) THEN
          IF (I .LT.  0) THEN
            CALL PLA173 (3, LU2, 0, 0)
          ELSE
            CALL PLA173 (3, LU13, 0, 0)
          ENDIF
        ENDIF
        IF (IPR(251) .GT. 0) THEN
C * BOND DISTANCES (NON-H)         PUB (AC, JA, IC)
          IF (I .EQ. 1 .OR. I .EQ. 2 .OR. I .EQ. 3)
     1        CALL PLA173 (4, LU12, 0, 2)
C * BOND DISTANCES                 SUP
          IF (I .LT.  0) THEN
            CALL PLA173 (4, LU2,  1, 1)
          ELSE
            CALL PLA173 (4, LU13, 1, 2)
          ENDIF
        ENDIF
        IF (IPR(252) .GT. 0) THEN
C * BOND ANGLES (NON-H)            PUB (AC, JA, IC)
          IF (I .EQ. 1 .OR. I .EQ. 2 .OR. I .EQ. 3)
     1        CALL PLA173 (5, LU12, 0, 2)
C * BOND ANGLES                    SUP
          IF (I .GE.  0) CALL PLA173 (5, LU13, 1, 2)
          IF (I .LT.  0) CALL PLA173 (5, LU2,  1, 1)
        ENDIF
C * TORSION ANGLES                 SUP (SU)
        IF (IPR(253) .GT. 0) THEN
          IF (I .EQ.  0) CALL PLA173 (6, LU13, 0, 1)
          IF (I .EQ. -1) CALL PLA173 (6, LU2,  0, 1)
        ENDIF
C * CONTACT-DISTANCES
        IF (IPR(254) .GT. 0) THEN
          IF (I .EQ.  0) CALL PLA173 (7, LU13, 1, 2)
          IF (I .EQ. -1) CALL PLA173 (7, LU2,  1, 1)
        ENDIF
C * HBONDS
        IF (IPR(452) .GT. 0) THEN
          IF (I .EQ.  0) CALL PLA173 (8, LU13, 0, 1)
          IF (I .EQ. -1) CALL PLA173 (8, LU2,  0, 1)
        ENDIF
C * FINISH
        IF (I .EQ.  0) CALL PLA173 (9, LU13, 0, 0)
        IF (I .LT.  0) CALL PLA173 (9, LU2,  0, 0)
      ENDIF
      RETURN
99999 FORMAT ('Ignored Label Problem in PLA172 for :', A, I10, 1X, A)
99998 FORMAT (':: Too Many Torsions    -> Skipped')
99997 FORMAT (':: Too Many Non-Bonding -> Skipped')
99996 FORMAT (':: Too Many H-Bonds     -> Skipped')
      END
      SUBROUTINE PLA173 (MODE, LU, INCLH, NCOL)
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118,
     1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NPVD=40000000,
     2 NP22=256,NP23=18000,NP25=99,NP29=63,NP34=509,NP38=125,NP39=30,
     3 NP41=200,NP45=2048,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /Q/ ICL, IFL(NP17)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9),
     1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10),
     2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10),
     3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770)
      COMMON // JNSC(2, NP23), VOID(NPVD)
      CHARACTER FORMA*79, FORMB*67, FORMC*120, FORMT*100, FORMHA*75,
     1 FORMHB*75, FORMHT*75, FORMNB*77, FORMBH*79 , CTAB*1, FPARSU*18,
     2 FBOND*82, FANGL*88, FORMAN*88, FORMHC*120, FORMNH*151, FVOLU*40,
     3 FORMCD*104, FORHBF*88, DCHAR*3
      CHARACTER DISOR*1, UTYPE*5, SCTYP*3, ASCF*4, ASRF*1
      COMMON /CIF/ CIFDIR
      CHARACTER CIFDIR(NP34)*36
      CHARACTER CIFTYPE*3
      COMMON /TODAY/ DATIJD
      CHARACTER DATIJD*25
C * PRINT TABLES
C * MODE = -1 - HEADER
C * MODE =  0 - CRYSTAL DATA ETC
C * MODE =  1 - NON-H COORDINATES
C * MODE =  2 - H-ATOM COORDINATES
C * MODE =  3 - DISPLACEMENT PARAMETERS
C * MODE =  4 - BONDS
C * MODE =  5 - ANGLES
C * MODE =  6 - TORSIONS
C * MODE =  7 - INTER CONTACTS
C * MODE =  8 - HBONDS
C * MODE =  9 - FINISH
C * LU7  = LIS-FILE
C * LU12 = PUB-FILE
C * LU13 = SUP-FILE
C * LU2  = CIF-FILE
      DCHAR = '   '
      N     = 1
      IF (IPR(493) .EQ. 0) IPR(493) = 2
      IF (PAR(170) .LT. 0) THEN
        IF (KRAD(1:2) .EQ. 'Mo') THEN
          PAR(170) = 0.35
        ELSE IF (KRAD(1:2) .EQ. 'Cu') THEN
          PAR(170) = 0.14
        ELSE
          PAR(170) = 0.0
        ENDIF
      ENDIF
C * SETUP FORMATS
      FBOND(  1: 28) = '(8X,''a, b, c [Angstrom]'', 9X'
      FBOND( 29: 45) = ', F9.4,''('',I2,'')'''
      FBOND( 46: 82) = FBOND(29:45)//FBOND(29:45)//',A)'
      FANGL(  1: 34) = '(8X,''alpha, beta, gamma [deg]'', 3X'
      FANGL( 35: 88) = FBOND(29:82)
      FVOLU(  1: 40) = '(8X,''V [Ang**3]'',42X,F10.1,''('',I2,'')'',A)'
C * SETUP FORMAT COORDINATES
      FORMC(  1:  7) = '(1X,2A '
      FORMC(  8: 23) = ',F9.0,''('',I2,'')'''
      FORMC( 24: 55) = FORMC(8:23)//FORMC(8:23)
      FORMC( 56:120) = FORMC(24:55)//FORMC(24:55)//')'
C * SETUP FORMAT BONDS
      FORMB(1  :  3) = '(1X'
      FORMB(4  : 33) = ', A ,  A  , A ,F8.4,''('',I2,'')'''
      FORMB(34 : 67) = ',5X'//FORMB(4:33)//')'
C * SETUP FORMAT BOND ANGLES
      FORMA(1  :  3) = '(1X'
      FORMA(4  : 39) = ', A ,  A, A , A , A ,F8.4,''('',I2,'')'''
      FORMA(40 : 79) = ',3X'//FORMA(4:39)//')'
C * SETUP FORMAT TORSION ANGLES
      FORMT(1  :  3) = '(1X'
      FORMT(4  : 38) = ', A ,  A  , A ,  A  , A ,  A  , A ,'
      FORMT(39 : 54) = 'F8.4,''('',I2,'')'')'
C * SETUP FORMAT TABLE HEADERS
      FORMHB(1 : 41) = '  (8X,''Table '',A,I1,'' - Bond Distances '','
      FORMHB(42: 75) = '''(Angstrom) '',A,/,19X,''for: '',A,/)'
      FORMHA(1 : 41) = '  (4X,''Table '',A,I1,'' - Bond Angles    '','
      FORMHA(42: 75) = '''(Degrees)  '',A,/,15X,''for: '',A,/)'
      FORMHT(1 : 41) = '  (9X,''Table '',A,I1,'' - Torsion Angles '','
      FORMHT(42: 75) = '''(Degrees)  '',A,/,20X,''for: '',A,/)'
      FORMNB(1 : 43) = '  (8X,''Table '',A,I1,'' - Contact Distances'','
      FORMNB(44: 77) = '''(Angstrom) '',A,/,19X,''for: '',A,/)'
      FORMBH(1 : 41) = '  (8X,''Table '',A,I1,'' - Hydrogen Bonds '','
      FORMBH(42: 79) = '''(Angstrom, Deg)'',A,/,19X,''for: '',A,/)'
      FORMAN( 1: 40) = '  (4X,''Table '',A,I1,'' - (An)isotropic '','
      FORMAN(41: 72) = ''' Displacement Parameters '',A,/,'
      FORMAN(73: 88) = '15X,''for: '',A,/)'
      FORMHC( 1: 40) = '  (8X,''Table '',A,I1,'' - Hydrogen Atom '','
      FORMHC(41: 85) = '''Positions and Isotropic Displacement'',/,19X,'
      FORMHC(86:104) = '''Parameters  '',A,/,'
      FORMHC(105:120)= '19X,''for: '',A,/)'
      FORMNH( 1: 43) = '  (8X,''Table '',A,I1,'' - Final Coordinates'','
      FORMNH(44: 88) = ''' and Equivalent Isotropic Displacement'',/,19'
      FORMNH(89:133) = 'X,''Parameters of the non-Hydrogen atoms  '',A,'
      FORMNH(134:151)= '/,19X,''for: '',A,/)'
      FORMCD( 1: 43) = '  (8X,''Table '',A,I1,'' - Crystal Data and '','
      FORMCD(44: 88) = '''Details of the Structure Determination'',A,/,'
      FORMCD(89:104) = '19X,''for: '',A,/)'
      FORHBF( 1:38) = '(A,1X,A,1X,A,F7.4,''('',I2,'')'',F7.4,''('','
      FORHBF(39:73) = 'I2,'')'',F7.4,''('',I2,'')'',F7.1,''('',I2,'
      FORHBF(74:88) = ''')'',1X,A,''   '')'
      FPARSU(1:18)  = '(F10.0,''('',I2,'')'')'
      IF (LU .NE. LU2) THEN
        IF (MODE .LT. 4) THEN
          LSTART = 8
        ELSE
          LSTART = 4
        ENDIF
        IF (LU .EQ. LU12) THEN
          IF (MODE .NE. 7) IPR(239) = IPR(239) + 1
          IDOUBL   = 2
          NTAB     = IPR(239)
          CTAB     = ' '
        ELSE IF (LU .EQ. LU13) THEN
          IF (MODE .NE. -1) IGBL(84) = IGBL(84) + 1
          NTAB     = IGBL(84)
          CTAB     = 'S'
          IF (IPR(431) .EQ. 2 .OR. IPR(431) .EQ. 3) THEN
            IDOUBL = 1
          ELSE
            IDOUBL = IPR(274)
          ENDIF
        ELSE IF (LU .EQ. LU7) THEN
          IDOUBL   = 1
          NTAB     = 0
          CTAB     = ' '
        ENDIF
        MXLIN  = IPR(243) / IDOUBL
        LSTART = LSTART   / IDOUBL
        IF (IDOUBL .EQ. 1) THEN
          DCHAR = '   '
        ELSE
          DCHAR = '  '//CHAR(10)
        ENDIF
      ELSE
        MXLIN  = 99999
        LSTART = 1
        IDOUBL = 1
      ENDIF
      IF (MODE .EQ. -1) THEN
C * COVER PAGE SUPPLEMENTARY MATERIAL
        IF (LU .NE. LU2) THEN
          IF (LU .EQ. LU12) THEN
            WRITE (LU, 99983) CHAR(12)
          ELSE IF (LU .EQ. LU13) THEN
            IGBL(85) = IGBL(85) + 1
            WRITE (LU, 99982) CHAR(12), IGBL(85)
          ENDIF
          WRITE (LU, 99999) JID(1:40), DATIJD(5:24)
          J   = IPR(431)
          NTB = IGBL(84)
          IF (J .EQ. 0 .OR. J .EQ. 3) THEN
            CALL PLA176 (0, LU, CTAB, NTB, FORMCD, JID)
            CALL PLA176 (0, LU, CTAB, NTB, FORMNH, JID)
          ENDIF
          IF (IPR(484) .GT. 0)
     1      CALL PLA176 (0, LU, CTAB, NTB, FORMHC, JID)
          IF (IPR(32) .GT. 0) THEN
            FORMAN( 4 :  4) = '8'
            FORMAN(73 : 74) = '19'
            CALL PLA176 (0, LU, CTAB, NTB, FORMAN, JID)
            FORMAN( 4 :  4) = '4'
            FORMAN(73 : 74) = '15'
          ENDIF
          IF (IPR(251) .GT. 0)
     1        CALL PLA176 (0, LU, CTAB, NTB, FORMHB, JID)
          IF (IPR(252) .GT. 0) THEN
            FORMHA( 4 :  4) = '8'
            FORMHA(60 : 61) = '19'
            CALL PLA176 (0, LU, CTAB, NTB, FORMHA, JID)
            FORMHA( 4 :  4) = '4'
            FORMHA(60 : 61) = '15'
          ENDIF
          IF (IPR(253) .GT. 0 .AND. J .EQ. 0) THEN
            FORMHT( 4 :  4) = '8'
            FORMHT(60 : 61) = '19'
            CALL PLA176 (0, LU, CTAB, NTB, FORMHT, JID)
            FORMHT( 4 : 4)  = '9'
            FORMHT(60 : 61) = '20'
          ENDIF
          IF (IPR(254) .GT. 0)
     1      CALL PLA176 (0, LU, CTAB, NTB, FORMNB, JID)
          IF (IPR(452) .GT. 0)
     1      CALL PLA176 (0, LU, CTAB, NTB, FORMBH, JID)
        ELSE
C * CIF - FILE - HEADER
          WRITE (LU, 99300) JID(1:40)
          WRITE (LU, 99299)
          IF (IPR(431) .EQ. -1) THEN
            WRITE (LU, 99298) 'global'
            CIFTYPE = 'ACC'
          ELSE
            WRITE (LU, 99298) DATANM
            CIFTYPE = 'CSD'
          ENDIF
          WRITE (LU, 99299)
          WRITE (LU, 99297)
          WRITE (LU, 99296) CIFDIR(71), DATIJD(5:24), CIFDIR(72),
     1                      CIFTYPE, CIFDIR(73)
          WRITE (LU, 99295)
          WRITE (LU, 99294)
          IF (IPR(399) .EQ. 0) THEN
            WRITE (LU, 99293) CIFDIR(437), CIFDIR(438)
            WRITE (LU, 99292) CIFDIR(325), '?'
            WRITE (LU, 99292) CIFDIR(326), '?'
            WRITE (LU, 99292) CIFDIR(327), '?'
          ELSE
            WRITE (LU, 99278) CIFDIR(437), CIFDIR(438)
            WRITE (LU, 99277)
            WRITE (LU, 99292) CIFDIR(325),
     1                        '''a.l.spek@chem.uu.nl'''
            WRITE (LU, 99292) CIFDIR(326), '''+31 30 2533940'''
            WRITE (LU, 99292) CIFDIR(327), '''+31 30 2532538'''
          ENDIF
          IF (IPR(431) .EQ. -1) THEN
            WRITE (LU, 99291)
            WRITE (LU, 99290) CIFDIR(336), CIFDIR(436)
            WRITE (LU, 99292) CIFDIR(335), '?'
            WRITE (LU, 99291)
            WRITE (LU, 99289) CIFDIR(328)
            WRITE (LU, 99295)
            WRITE (LU, 99288)
            WRITE (LU, 99287) CIFDIR(305), CIFDIR(299), CIFDIR(298),
     1                        CIFDIR(297), CIFDIR(301), CIFDIR(300),
     2                        CIFDIR(303), CIFDIR(302), CIFDIR(294),
     3                        CIFDIR(291), CIFDIR(295), CIFDIR(314),
     4                        CIFDIR(318), CIFDIR(288), CIFDIR(308),
     5                        CIFDIR(321), CIFDIR(320), CIFDIR(307),
     6                        CIFDIR(309), CIFDIR(310), CIFDIR(311),
     7                        CIFDIR(312)
          ELSE IF (IPR(431) .EQ. -2) THEN
            WRITE (LU, '(A, A)') CIFDIR(435), '?'
          ENDIF
          WRITE (LU, 99295)
          WRITE (LU, 99286)
          WRITE (LU, 99285) CIFDIR(337), CIFDIR(439)
          WRITE (LU, 99284)
          WRITE (LU, 99283) CIFDIR(323), CIFDIR(469), CIFDIR(322)
          IF (IPR(399) .EQ. 1) THEN
            WRITE (LU, 99279)
            WRITE (LU, 99277)
          ENDIF
          IF (IPR(431) .EQ. -1) THEN
            WRITE (LU, 99295)
            WRITE (LU, 99282)
            WRITE (LU, 99248) CIFDIR(440), CIFDIR(338)
            WRITE (LU, 99252)
            WRITE (LU, 99281) CIFDIR(339)
            WRITE (LU, 99250) CIFDIR(424), CIFDIR(425)
            WRITE (LU, 99251)
            WRITE (LU, 99259) CIFDIR(344), CHAR(92), CHAR(39)
            WRITE (LU, 99258)
            WRITE (LU, 99257)
            IF (IPR(399) .EQ. 0) THEN
              WRITE (LU, 99265) CIFDIR(343)
            ELSE
              WRITE (LU, 99274) CIFDIR(343)
            ENDIF
            WRITE (LU, 99245) CIFDIR(345)
            WRITE (LU, 99295)
            WRITE (LU, 99298) DATANM
          ENDIF
          WRITE (LU, 99295)
          WRITE (LU, 99280)
        ENDIF
      ELSE IF (MODE .EQ. 0) THEN
        IF (IPR(215) .EQ. 0) THEN
          CALL PLA283 (0, 1, N, IDM)
          CALL PLA283 (2, IPR(260), N1, ICL)
        ELSE
          CALL GEN038 (IDM, 1, 80)
          CALL GEN038 (ICL, 1, 80)
          IDM(80:80) = '?'
          ICL(80:80) = '?'
          N  = 80
          N1 = 80
        ENDIF
        DO 10 I = 1, 3
          IFB = 17 + 17 * I
          FBOND(IFB : IFB) = CHAR(ICHAR('0') + IPR(286 + I))
          IFA = 23 + 17 * I
          FANGL(IFA : IFA) = CHAR(ICHAR('0') + IPR(289 + I))
   10   CONTINUE
        FVOLU(26 : 26) = CHAR(ICHAR('0') + IPR(294))
C * CIF-FILE
        IF (LU .EQ. LU2) THEN
          WRITE (LU, 99281) CIFDIR(116)
          WRITE (LU, 99292) CIFDIR(113), '?'
          WRITE (LU, 99292) CIFDIR(112), '?'
          IF (INDEX (RLWS(4), '?') .EQ. 0) THEN
            WRITE (LU, 99197) CIFDIR(107), RLWS(4)(1:79)
          ELSE
            WRITE (LU, 99397) CIFDIR(107), IDM(N:80)
          ENDIF
          WRITE (LU, 99253)
          WRITE (LU, 99292) CIFDIR(108), '?'
          IF (INDEX (RLWS(5), '?') .EQ. 0) THEN
            WRITE (LU, 99197) CIFDIR(109), RLWS(5)(1:79)
          ELSE
            N1 = MAX (5, N1)
            WRITE (LU, 99397) CIFDIR(109), ICL(N1:80)
          ENDIF
          WRITE (LU, 99292) CIFDIR(482), '?'
          IF (INDEX (RLWS(4), '?') .EQ. 0) THEN
            WRITE (LU, 99396) CIFDIR(110), PAR(308)
          ELSE
            WRITE (LU, 99396) CIFDIR(110), PAR(163) / IPR(260)
          ENDIF
          WRITE (LU, 99399) CIFDIR(94)
          WRITE (LU, 99270) CIFDIR(70), CIFDIR(52), CIFDIR(67),
     1                      CIFDIR(66), CIFDIR(68)
          DO 2 I = 1, IAN
            K = IENS(IAN + 1 - I)
            IF (NINT(CONT(K, 2) / IPR(260)) .GT. 0) THEN
              J = (IEN(K) - 1) * 15
              IF (IPR(493) .EQ. 1) THEN
                J0 = J + 13
              ELSE IF (IPR(493) .EQ. 2) THEN
                J0 = J + 11
              ELSE IF (IPR(493) .EQ. 3) THEN
                J0 = J + 9
              ELSE
                J0 = 0
              ENDIF
              IF (J0 .NE. 0) THEN
                WRITE (LU, 99261) LMT(K, 1)(1:2), LMT(K, 1)(1:2),
     1            (SFAC(J0 + L), L = 1, 2)
              ELSE
                WRITE (LU, 99061) LMT(K, 1)(1:2), LMT(K, 1)(1:2)
              ENDIF
            ENDIF
    2     CONTINUE
          WRITE (LU, 99295)
          WRITE (LU, 99269)
          WRITE (LU, 99376) CIFDIR(418), KRSYST
          CALL GEN039 (0, SPGRNM(3),  1, 17, K03, K3)
          IF (K03 .GE. K3) THEN
            SPGRNM(3)(1:1) = '?'
            K03 = 1
            K3  = 1
          ENDIF
          CALL GEN039 (1, SPGRNM(1), 15, 26, K01, K1)
          IF (K01 .GE. K1) SPGRNM(1)(K01:K01) = '?'
          WRITE (LU, 99375) CIFDIR(421), SPGRNM(3)(K03:K3),
     1                      CIFDIR(422), SPGRNM(1)(K01:K1),
     2                      CIFDIR(420), IPR(202)
          WRITE (LU, 99373) CIFDIR(480), CIFDIR(419)
          NSYM   = IPR(48)
          XJX(4) = 0.0
          XJX(5) = 0.0
          XJX(6) = 0.0
          DO 100 I = 1, NSYM
            ISYM = I
            CALL SGSM (ICL, ISYM, XJX, 0, 20, IERR)
            CALL GEN020 (-1, ICL, 1, 30)
            WRITE (LU, 99984) ISYM, ICL(1:30)
  100     CONTINUE
          WRITE (LU, 99291)
          WRITE (PRBUF, FBOND) PAR(101), IPR(281), PAR(102), IPR(282),
     1                         PAR(103), IPR(283), DCHAR
          CALL GEN065 (0, PRBUF, 80, 1)
          WRITE (LU, 99388) CIFDIR(78), PRBUF(36:48),
     1                      CIFDIR(79), PRBUF(49:61),
     2                      CIFDIR(80), PRBUF(62:74)
          WRITE (PRBUF, FANGL) PAR(104), IPR(284), PAR(105), IPR(285),
     1                         PAR(106), IPR(286), DCHAR
          CALL GEN065 (0, PRBUF, 80, 3)
          WRITE (LU, 99388) CIFDIR(74), PRBUF(36:48),
     1                      CIFDIR(75), PRBUF(49:61),
     2                      CIFDIR(76), PRBUF(62:74)
          WRITE (PRBUF, FVOLU) PAR(98), IPR(293), DCHAR
          CALL GEN065 (0, PRBUF, 80, 1)
          WRITE (LU, 99382) CIFDIR(93), PRBUF(62:74)
          IF (INDEX (RLWS(4), '?') .EQ. 0) THEN
            CALL PLA175 (2, LU,  77, '(A, I6)', IPR(276), 0.0)
          ELSE
            CALL PLA175 (2, LU,  77, '(A, I6)', IPR(260), 0.0)
          ENDIF
          CALL PLA175 (2, LU,  88, '(A, I6)', IPR(261), 0.0)
          CALL PLA175 (1, LU,  87, ' ?', 0, 0.0)
          CALL PLA175 (1, LU,  90, ' ?', 0, 0.0)
          CALL PLA175 (1, LU,  89, ' ?', 0, 0.0)
          IF (IPR(399) .EQ. 1) THEN
            WRITE (LU, 99255) CIFDIR(92)
          ELSE
            WRITE (LU, 99268) CIFDIR(92)
          ENDIF
          WRITE (LU, 99291)
          WRITE (LU, 99243) CIFDIR(239), CCIF(5)(1:NCIF(5)),
     1                      CIFDIR(234), CCIF(14)(1:NCIF(14))
          CALL PLA175 (3, LU, 251, '(A, F10.3)', 0, PAR(302))
          CALL PLA175 (3, LU, 252, '(A, F10.3)', 0, PAR(303))
          CALL PLA175 (3, LU, 253, '(A, F10.3)', 0, PAR(304))
          CALL PLA175 (1, LU, 254, ' ?', 0, 0.0)
          CALL PLA175 (3, LU, 236, '(A, F10.3)', 0, PAR(158))
          IF (INDEX (RLWS(4), '?') .EQ. 0) THEN
            CALL PLA175 (3, LU, 235, '(A, F10.3)', 0, PAR(267))
          ELSE
            CALL PLA175 (3, LU, 235, '(A, F10.3)', 0, PAR(160))
          ENDIF
          CALL PLA175 (1, LU, 238, '''Not Measured''', 0, 0.0)
          CALL PLA175 (2, LU, 240, '(A, I10)', NINT(PAR(157)), 0.0)
          IF (INDEX (RLWS(4), '?') .EQ. 0) THEN
            CALL PLA175 (3, LU, 229, '(A, F10.3)', 0, PAR(301))
          ELSE
            XMUM = PAR(162)
            IF (XMUM .EQ. 0.0) XMUM = -999999.0
            CALL PLA175 (3, LU, 229, '(A, F10.3)', 0, XMUM)
          ENDIF
          CALL PLA175 (1, LU, 237, ' ?', 0, 0.0)
          IF (IPR(485) .EQ. 4) THEN
            WRITE (LU, 99247) CIFDIR(232), CIFDIR(233)
          ELSE
            WRITE (LU, 99244)
            WRITE (LU, 99246) CIFDIR(232), CCIF(15)(1:NCIF(15)),
     1                        CIFDIR(233)
          ENDIF
          CALL PLA175 (3, LU, 231, '(A, F10.3)', 0, PAR(307))
          CALL PLA175 (3, LU, 230, '(A, F10.3)', 0, PAR(306))
          WRITE (LU, 99295)
          WRITE (LU, 99266)
          WRITE (LU, 99265) CIFDIR(256)
          CALL PLA175 (2, LU, 133, '(A, I6)', IPR(310), 0.0)
          CALL PLA175 (3, LU, 164, '(A, F10.5)', 0, PAR(17))
          IF (IPR(493) .LT. 5) THEN
            WRITE (LU, 99362) CIFDIR(481), 'x-ray'
            IF (IPR(493) .LT. 4) THEN
              WRITE (LU, 99362) CIFDIR(163), KRAD(1:3)//CHAR(92)//'a'
            ELSE
              WRITE (LU, 99362) CIFDIR(163), '?'
            ENDIF
          ELSE
            WRITE (LU, 99362) CIFDIR(481), 'neutron'
          ENDIF
          IF (IPR(399) .EQ. 0) THEN
            CALL PLA175 (1, LU, 162, ' ?', 0, 0.0)
            CALL PLA175 (1, LU, 159, ' ?', 0, 0.0)
          ELSE
            WRITE (LU, 99392) CIFDIR(162), CIFDIR(159)
          ENDIF
          WRITE (LU, 99291)
          CALL PLA175 (1, LU, 441, ' ?', 0, 0.0)
          CALL PLA175 (1, LU, 137, ' ?', 0, 0.0)
          IF (IPR(399) .EQ. 1) THEN
            CALL PLA175 (3, LU, 463, '(A, F10.1)', 0, 18.4)
          ELSE
            CALL PLA175 (1, LU, 463, ' ?', 0, 0.0)
          ENDIF
          WRITE (LU, 99291)
          CALL PLA175 (1, LU, 227, ' ?', 0, 0.0)
          CALL PLA175 (1, LU, 225, ' ?', 0, 0.0)
          CALL PLA175 (1, LU, 226, ' ?', 0, 0.0)
          CALL PLA175 (1, LU, 224, ' ?', 0, 0.0)
          WRITE (LU, 99357) CIFDIR(221), CIFDIR(222), CIFDIR(223)
          WRITE (LU, 99291)
          WRITE (LU, 99355)
          CALL PLA175 (2, LU, 204, '(A, I6)', IPR(262), 0.0)
          CALL PLA175 (3, LU, 196, '(A, F8.4)', 0, PAR(197))
          CALL PLA175 (3, LU, 197, '(A, F8.4)', 0, PAR(198))
          CALL PLA175 (2, LU, 199, '(A, I6)', IPR(267), 0.0)
          CALL PLA175 (2, LU, 198, '(A, I6)', IPR(268), 0.0)
          CALL PLA175 (2, LU, 201, '(A, I6)', IPR(269), 0.0)
          CALL PLA175 (2, LU, 200, '(A, I6)', IPR(270), 0.0)
          CALL PLA175 (2, LU, 203, '(A, I6)', IPR(271), 0.0)
          CALL PLA175 (2, LU, 202, '(A, I6)', IPR(272), 0.0)
          CALL PLA175 (3, LU, 207, '(A, F6.2)', 0, PAR(167))
          CALL PLA175 (3, LU, 206, '(A, F6.2)', 0, PAR(168))
          CALL PLA175 (3, LU, 444, '(A, F6.2)', 0, PAR(312))
          CALL PLA175 (3, LU, 458, '(A, F6.3)', 0, PAR(313))
          CALL PLA175 (3, LU, 459, '(A, F6.3)', 0, PAR(314))
          WRITE (LU, 99351) CIFDIR(205)
          WRITE (LU, 99324)
          CALL PLA175 (2, LU, 410, '(A, I8)', IPR(263), 0.0)
          WRITE (LU, 99323)
          CALL PLA175 (2, LU, 442, '(A, I8)', IPR(264), 0.0)
          IF (CCIF(1)(2:3) .EQ. '2s') CCIF(1) = 'I>2'//CHAR(92)//'s(I)'
          WRITE (LU, 99322) CIFDIR(443), CCIF(1)(1:NCIF(1))
          WRITE (LU, 99291)
          IF (IPR(399) .EQ. 1) THEN
            WRITE (LU, 99394) CIFDIR(118), CIFDIR(117), CIFDIR(119)
          ELSE
            WRITE (LU, 99393) CIFDIR(118), CIFDIR(117), CIFDIR(119)
          ENDIF
          WRITE (LU, 99391) CIFDIR(123)
          IF (IPR(400) .EQ. 1) THEN
            WRITE (LU, 99390) CIFDIR(122),
     1                      ' ''SHELXL-97 (Sheldrick, 1997)'''
          ELSE
            WRITE (LU, 99390) CIFDIR(122), ' ?'
          ENDIF
          WRITE (LU, 99264) CIFDIR(120)
          WRITE (LU, 99389) CIFDIR(121)
          WRITE (LU, 99295)
          WRITE (LU, 99263)
          IF (IPR(400) .EQ. 0) THEN
            WRITE (LU, 99332) CIFDIR(373)
          ELSE
            WRITE (LU, 99276) CIFDIR(373)
          ENDIF
          WRITE (LU, 99348) CIFDIR(369), CCIF(2)(1:NCIF(2))
          WRITE (LU, 99347) CIFDIR(358), CCIF(3)(1:NCIF(3))
          WRITE (LU, 99346) CIFDIR(370), CCIF(9)(1:NCIF(9))
          WRITE (LU, 99342) CIFDIR(451), RLWS(1)
          IF (IPR(484) .LE. 0) THEN
            CCIF(12) = ' .'
            CCIF(13) = ' .'
            NCIF(12) = 2
            NCIF(13) = 2
          ENDIF
          WRITE (LU, 99345) CIFDIR(48),  CCIF(10)(1:NCIF(10)),
     1                      CIFDIR(49),  CCIF(11)(1:NCIF(11)),
     2                      CIFDIR(50),  CCIF(12)(1:NCIF(12))
          WRITE (LU, 99301) CIFDIR(357), CCIF(13)(1:NCIF(13))
          WRITE (LU, 99344) CIFDIR(354), CCIF(4)(1:NCIF(4))
          IF (CCIF(4)(1:4) .NE. 'none') THEN
            IF (PAR(229) .GT. 999990) THEN
              PRBUF(1:1) = '?'
              CALL GEN038 (PRBUF, 2, 20)
            ELSE
              FPARSU(6:6) = CHAR(ICHAR('0') + IPR(278))
              WRITE (PRBUF, FPARSU) PAR(229), IPR(277)
              CALL GEN065 (0, PRBUF, 80, 1)
            ENDIF
            WRITE (LU, 99981) CIFDIR(352), PRBUF(1:20)
            WRITE (LU, 99342) CIFDIR(353), RLWS(2)
          ENDIF
          IF (IPR(257) .EQ. 2) THEN
            WRITE (LU, 99341) CIFDIR(349), CIFDIR(350)
          ELSE
            WRITE (LU, 99254) CIFDIR(349)
            IF (PAR(433) .LT. 999999.0) THEN
              FPARSU(6:6) = CHAR(ICHAR('0') + IPR(280))
              WRITE (PRBUF, FPARSU) PAR(433), IPR(279)
              CALL GEN065 (0, PRBUF, 80, 1)
              WRITE (LU, 99981) CIFDIR(350), PRBUF(1:20)
            ELSE
              CALL PLA175 (1, LU, 350, ' ?', 0, 0.0)
            ENDIF
            WRITE (LU, 99060) CIFDIR(478), CCIF(17)(1:NCIF(17))
          ENDIF
          CALL PLA175 (2, LU, 361, '(A, I10)', IPR(265), 0.0)
          CALL PLA175 (2, LU, 360, '(A, I10)', IPR(266), 0.0)
          CALL PLA175 (2, LU, 362, '(A, I10)', IPR(273), 0.0)
          CALL PLA175 (1, LU, 359, ' ?', 0, 0.0)
          CALL PLA175 (3, LU, 363, '(A, F10.4)', 0, PAR(309))
          CALL PLA175 (3, LU, 445, '(A, F10.4)', 0, PAR(173))
          CALL PLA175 (3, LU, 446, '(A, F10.4)', 0, PAR(174))
          CALL PLA175 (3, LU, 460, '(A, F10.4)', 0, PAR(310))
          CALL PLA175 (3, LU, 447, '(A, F10.3)', 0, PAR(299))
          CALL PLA175 (3, LU, 365, '(A, F10.3)', 0, PAR(300))
          CALL PLA175 (3, LU, 448, '(A, F10.3)', 0, PAR(178))
          CALL PLA175 (3, LU, 461, '(A, F10.3)', 0, PAR(179))
          CALL PLA175 (3, LU, 347, '(A, F10.3)', 0, PAR(177))
          CALL PLA175 (3, LU, 348, '(A, F10.3)', 0, PAR(176))
          CALL PLA175 (3, LU, 462, '(A, F10.3)', 0, PAR(175))
          WRITE (LU, 99295)
          WRITE (LU, 99262)
        ENDIF
C * CRYSTAL DATA TABLE  (INCLH = 0: PARTIAL, = 1 : FULL)
        IF (LU .NE. LU2) THEN
          IF (LU .EQ. LU12) THEN
            WRITE (LU, 99983) CHAR(12)
          ELSE IF (LU .EQ. LU7) THEN
            CALL PLA269 (0)
          ELSE IF (LU .EQ. LU13) THEN
            IGBL(85) = IGBL(85) + 1
            WRITE (LU, 99982) CHAR(12), IGBL(85)
          ENDIF
          IF (INCLH .EQ. 0) THEN
            WRITE (LU, 99978)  CTAB, NTAB, DCHAR, JID(1:40), DCHAR
          ELSE
            CALL PLA176 (-1, LU, CTAB, NTAB, FORMCD, JID)
          ENDIF
          IF (INCLH .GT. 0) WRITE (LU, 99977)
          IF (INDEX (RLWS(4), '?') .EQ. 0) THEN
            N2 = INDEX(RLWS(4), CHAR(39))
            CALL GEN038 (PRBUF, 1, 80)
            IF (N2 .GT. 1 .AND. N2 .LT. 59) THEN
              WRITE (LU, 99976) PRBUF(1:59-N2)//RLWS(4)(1:N2-1), DCHAR
            ELSE
              WRITE (LU, 99976) PRBUF(1:57)//'?', DCHAR
            ENDIF
            WRITE (LU, 99975) PAR(308), DCHAR
          ELSE
            WRITE (LU, 99976) IDM(23:80), DCHAR
            WRITE (LU, 99975) PAR(163) / IPR(260), DCHAR
          ENDIF
          IF (INCLH .GT. 0) WRITE (LU, 99974) KRSYST, DCHAR
          WRITE (LU, 99973) SPGRNM(1)(1:7), SPGRNM(1)(8:11),
     1                      IPR(202), DCHAR
          WRITE (PRBUF, FBOND) PAR(101), IPR(281), PAR(102), IPR(282),
     1                         PAR(103), IPR(283), DCHAR
          CALL GEN065 (LU, PRBUF, 80, 1)
          WRITE (PRBUF, FANGL) PAR(104), IPR(284), PAR(105), IPR(285),
     1                         PAR(106), IPR(286), DCHAR
          IF (INDEX (KRSYST, 'Tri') .NE. 0 .OR.
     1        INDEX (KRSYST, 'Mon') .NE. 0) THEN
            CALL GEN065 (LU, PRBUF, 80, 3)
          ENDIF
          WRITE (PRBUF, FVOLU) PAR(98), IPR(293), DCHAR
          CALL GEN065 (LU, PRBUF, 80, 1)
          IF (INDEX (RLWS(4), '?') .EQ. 0) THEN
            WRITE (LU, 99970) IPR(276), DCHAR
            IF (PAR(158) .LT. 10000.0) THEN
              WRITE (LU, 99969) PAR(158), PAR(267), DCHAR
            ELSE
              WRITE (LU, 99948) PAR(160), DCHAR
            ENDIF
            WRITE (LU, 99967) KRAD, PAR(301), DCHAR
          ELSE
            WRITE (LU, 99970) IPR(260), DCHAR
            IF (PAR(158) .LT. 10000.0) THEN
              WRITE (LU, 99969) PAR(158), PAR(160), DCHAR
            ELSE
              WRITE (LU, 99948) PAR(160), DCHAR
            ENDIF
            WRITE (LU, 99967) KRAD, PAR(162), DCHAR
          ENDIF
          IF (INCLH .GT. 0) WRITE (LU, 99968) NINT(PAR(157)), DCHAR
          IF (INCLH .GT. 0) THEN
            WRITE (LU, 99966) MAX (0.0, PAR(304)), MAX(0.0, PAR(303)),
     1                        MAX (0.0, PAR(302)), DCHAR
            WRITE (LU, 99965)
          ENDIF
          WRITE (LU, 99964) IPR(261), DCHAR
          WRITE (LU, 99963) KRAD, MAX (0.0, PAR(17)), DCHAR
          IF (INCLH .GT. 0) THEN
            WRITE (LU, 99962) MAX (0.0, PAR(167)), MAX(0.0, PAR(168)),
     1                        DCHAR
            WRITE (LU, 99957)
     1            (MIN(999, MAX (-99, IPR(I))), I = 267, 272), DCHAR
            WRITE (LU, 99956) MAX (0, IPR(262)), MAX(0, IPR(263)),
     1                        MAX (0.0, PAR(197)), DCHAR
            IF (IPR(400) .EQ. 1) PAR(180) = 2.0
            WRITE (LU, 99955) PAR(180), MAX (0, IPR(264)), DCHAR
            WRITE (LU, 99954)
            WRITE (LU, 99953) MAX (0, IPR(265)),
     1                        MAX (0, IPR(266)), DCHAR
          ENDIF
          WRITE (LU, 99952) MAX (0.0, PAR(173)), MAX (0.0, PAR(174)),
     1                      MAX (0.0, PAR(299)), DCHAR
          IF (INCLH .GT. 0) THEN
            WRITE (LU, 99951) RLWS(1)(9:70), DCHAR
            WRITE (LU, 99950) MAX (0.0, PAR(178)),
     1                        MAX (0.0, PAR(179)), DCHAR
            IF (PAR(433) .LT. 999999.0) THEN
              FPARSU(6:6) = CHAR(ICHAR('0') + IPR(280))
              WRITE (PRBUF, FPARSU) PAR(433), IPR(279)
              CALL GEN065 (0, PRBUF, 80, 1)
              WRITE (LU, 99947) PRBUF(1:14), DCHAR
            ENDIF
            WRITE (LU, 99949) MIN (0.0, PAR(176)), MAX (0.0, PAR(177))
          ENDIF
        ENDIF
      ELSE IF (MODE .LT. 4) THEN
        IF (LU .EQ. LU12) THEN
          WRITE (LU, 99983) CHAR(12)
        ELSE IF (LU .EQ. LU13) THEN
          IGBL(85) = IGBL(85) + 1
          WRITE (LU, 99982) CHAR(12), IGBL(85)
        ENDIF
C * MODE = 1  - COORDINATES AND (AN)ISOTROPIC DISPLACEMENT PARAMETERS
        IF (MODE .EQ. 1) THEN
C * CIF - COORDINATES + (AN)ISO
          IF (LU .EQ. LU2) THEN
            WRITE (LU, 99499) CIFDIR(22), CIFDIR(35), CIFDIR(34),
     1                        CIFDIR(19), CIFDIR(20), CIFDIR(21),
     2                        CIFDIR(30), CIFDIR(36), CIFDIR(11),
     3                        CIFDIR(31)
          ELSE
            CALL PLA176 (-1, LU, CTAB, NTAB, FORMNH, JID)
            WRITE (LU, 99998)
          ENDIF
C * MODE =  2 - H-ATOM COORDINATES
        ELSE IF (MODE .EQ. 2) THEN
          IF (LU .NE. LU2) THEN
            CALL PLA176 (-1, LU, CTAB, NTAB, FORMHC, JID)
            WRITE (LU, 99995)
          ENDIF
C * MODE =  3 - DISPLACEMENT PARAMETERS
        ELSE IF (MODE .EQ. 3) THEN
          IF (LU .EQ. LU2) THEN
            WRITE (LU, 99799)
     1      CIFDIR(1), CIFDIR(3),  CIFDIR(6), CIFDIR(8),  CIFDIR(7),
     2      CIFDIR(5), CIFDIR(4)
          ELSE
            CALL PLA176 (-1, LU, CTAB, NTAB, FORMAN, JID)
            WRITE (LU, 99997)
          ENDIF
        ENDIF
        ITEL = LSTART
        NAT  = IPR(226)
        IF (IPR(240) .EQ. 0) THEN
          NRO = 0
        ELSE
          NRO = 1
        ENDIF
        NDISO = 0
        DO 380 I = 1, NAT
          DISOR = ' '
          NR = JNSC(1, I) / IPR(466)
          N4 = JNSC(2, I)
          N1 = N4 / 16
          N4 = N4 - N1 * 15 - 1
          N1 = N1 + 1
          N2 = N1 + 2
          N3 = N1 + 4
          IF (LU .EQ. LU2) N2 = N2 + 1
          IF (N4 .NE. N3) THEN
            UTYPE = 'Uani '
            IF (MODE .EQ. 3) THEN
              N4 = N4 - 1
            ELSE
              N3 = N4
            ENDIF
          ELSE
            UTYPE = 'Uiso '
          ENDIF
          IF (MODE .EQ. 3 .AND. N4 .EQ. N3) GOTO 380
          CALL PLA047 (VOID(N1 - 1), NQ1, IDUM, IENR, IPR(119),
     1                 IGBL(55), 0, 1)
          N = IEL(IENR)
          M = N / 100
          SCTYP = CHAR (ICHAR('A') + M - 1)//'  '
          N = N - M * 100
          IF (N .GT. 0) SCTYP(2 : 2) = CHAR (ICHAR('a') + N - 1)
          IF (IENR .EQ. 1 .OR. IENR .EQ. 33 .OR. IENR .EQ. 113) THEN
            IF (MODE .EQ. 1) GOTO 380
          ELSE
            IF (MODE .EQ. 2) GOTO 380
          ENDIF
          N   =  0
          IPS = -4
          FORMC(5 : 5) = '2'
          IF (LU .EQ. LU2) THEN
            FORMC(2 : 2) = '1'
          ELSE
            FORMC(2 : 2) = '3'
          ENDIF
          IF (MODE .LT. 3) THEN
            IF (LU .EQ. LU2) THEN
              FORMC(2 : 2) = '1'
              FORMC(5 : 5) = '3'
            ELSE
              FORMC(2 : 2) = '7'
              FORMC(5 : 5) = '2'
            ENDIF
            IF (VOID(N2 + 1) .LT. 1.0) THEN
              DISOR = '*'
              NDISO = NDISO + 1
            ENDIF
            DO 350 M = N1, N2
              N         = N + 1
              IPS   = IPS + 16
              IF (M - N1 .EQ. 3) THEN
                FORMC(IPS - 2 : IPS - 2) = '6'
                MDEC = 3
              ELSE
                FORMC(IPS - 2 : IPS - 2) = '9'
                MDEC = MIN (IPR(183), 5)
              ENDIF
              STDV = MAX (0.0, VOID(IPR(245) + M))
              CALL GEN041 (VOID(M), STDV, ISDV(N), MDEC, IDEC, IPR(68))
              FORMC(IPS : IPS) = CHAR(ICHAR('0') + IDEC)
              DEV(N)  = VOID(M)
  350       CONTINUE
          ENDIF
C * UEQ, U OR UIJ
          DO 360 M = N3, N4
            N    = N + 1
            STDV = MAX (0.0, VOID(IPR(245) + M))
            CALL GEN041 (VOID(M), STDV, ISDV(N), 4, IDEC, IPR(68))
            IPS   = IPS + 16
            IF (MODE .EQ. 3) THEN
              IF (LU .EQ. LU2 .AND. IPS .GE. 60) THEN
                FORMC(IPS - 2 : IPS - 2) = '8'
              ELSE
                FORMC(IPS - 2 : IPS - 2) = '7'
              ENDIF
            ENDIF
            FORMC(IPS : IPS) = CHAR(ICHAR('0') + IDEC)
            DEV(N) = VOID(M)
  360     CONTINUE
          IF (LU .NE. LU2) THEN
            ITEL = ITEL + 1
            IF (NR .GT. NRO) THEN
              ITEL = ITEL + 1
              NRO  = NR
              WRITE (LU, 99985)
              IF (IDOUBL .EQ. 2) WRITE (LU, 99985)
            ENDIF
            IF (ITEL .GT. MXLIN) THEN
              ITEL = LSTART + 1
              IF (LU .EQ. LU12) THEN
                WRITE (LU, 99983) CHAR(12)
              ELSE
                IGBL(85) = IGBL(85) + 1
                WRITE (LU, 99982) CHAR(12), IGBL(85)
              ENDIF
              IF (MODE .EQ. 1) THEN
                CALL PLA176 (1, LU, CTAB, NTAB, FORMNH, JID)
                WRITE (LU, 99998)
              ELSE IF (MODE .EQ. 2) THEN
                CALL PLA176 (1, LU, CTAB, NTAB, FORMHC, JID)
                WRITE (LU, 99995)
              ELSE IF (MODE .EQ. 3) THEN
                CALL PLA176 (1, LU, CTAB, NTAB, FORMAN, JID)
                WRITE (LU, 99997)
              ENDIF
            ENDIF
          ENDIF
          IF (LU .EQ. LU2) THEN
            IF (MODE .EQ. 1 .OR. MODE .EQ. 2) THEN
              ASCF = '.'
              ASRF = '.'
              NQ4  = NQ1
              CALL PLA046 (2, NQ4, IX, LBB, LBC, LBD, XNQNR, YNQNR, NR)
              IF (NR .GT. 0) THEN
                CALL GEN048 (-1, JFG(NR), 29, IVL)
                IF (IVL .GT. 0) ASCF = 'calc'
                CALL GEN048 (-1, JFG(NR), 30, IVL)
                IF (IVL .GT. 0) ASRF = 'R'
                CALL GEN048 (-1, JFG(NR), 31, IVL)
                IF (IVL .GT. 0) ASRF = 'G'
              ENDIF
              WRITE (PRBUF, FORMC) NQ1, SCTYP, UTYPE,
     1          (DEV(M), ISDV(M), M = 1, N)
              PRBUF(82:) = ASCF//' '//ASRF
            ELSE IF (MODE .EQ. 3) THEN
              WRITE (PRBUF, FORMC) DISOR, NQ1,
     1          (DEV(M), ISDV(M), M = 1, N)
            ENDIF
            CALL GEN065 (0, PRBUF, 90, 1)
            CALL GEN103 (PRBUF, 90)
            WRITE (LU, 99983) PRBUF(1:80)
          ELSE
            WRITE (PRBUF, FORMC) DISOR, NQ1,
     1          (DEV(M), ISDV(M), M = 1, N)
            CALL GEN065 (LU, PRBUF, 80, 3)
            IF (IDOUBL .EQ. 2) WRITE (LU, 99985)
          ENDIF
  380   CONTINUE
        IF (LU .NE. LU2) THEN
          IF (MODE .EQ. 1) THEN
            WRITE (LU, 99993)
            IF (NDISO .GT. 0) WRITE (LU, 99996)
          ELSE IF (MODE .EQ. 2) THEN
            WRITE (LU, 99989)
            WRITE (LU, 99988)
            WRITE (LU, 99987)
          ELSE IF (MODE .EQ. 3) THEN
            WRITE (LU, 99989)
            WRITE (LU, 99988)
            WRITE (LU, 99987)
            WRITE (LU, 99986)
          ENDIF
        ENDIF
C * BOND TABLE
      ELSE IF (MODE .EQ. 4) THEN
        CALL PLA174 (MODE, FORMB, FORMHB, LU, CTAB, NTAB, MXLIN,
     1    LSTART, NCOL, INCLH, 33, 11, 4, IDOUBL)
C * ANGLE TABLE
      ELSE IF (MODE .EQ. 5) THEN
        CALL PLA174 (MODE, FORMA, FORMHA, LU, CTAB, NTAB, MXLIN,
     1    LSTART, NCOL, INCLH, 39, 11, 2, IDOUBL)
C * TORSION TABLE
      ELSE IF (MODE .EQ. 6) THEN
        CALL PLA174 (MODE, FORMT, FORMHT, LU, CTAB, NTAB, MXLIN,
     1    LSTART, NCOL, INCLH, 42, 0, 2, IDOUBL)
C * INTER-CONTACTS
      ELSE IF (MODE .EQ. 7) THEN
        CALL PLA174 (MODE, FORMB, FORMNB, LU, CTAB, NTAB, MXLIN,
     1    LSTART, NCOL, INCLH, 33, 11, 4, IDOUBL)
C * H-BONDS
      ELSE IF (MODE .EQ. 8) THEN
        CALL PLA174 (MODE, FORHBF, FORMBH, LU, CTAB, NTAB, MXLIN,
     1    LSTART, NCOL, INCLH, 42, 0, 4, IDOUBL)
C * FINISH
      ELSE IF (MODE .EQ. 9) THEN
        IF (LU .EQ. LU13) THEN
          IGBL(85) = IGBL(85) + 1
          WRITE (LU, 99982) CHAR(12), IGBL(85)
          WRITE (LU, 99249)
          CALL PLA043 (0, -1, LU, 0)
        ENDIF
        IF (LU .EQ. LU2) THEN
          WRITE (LU, 99001)
          WRITE (LU, 99002)
          WRITE (LU, 99003)
          WRITE (LU, 99004)
          WRITE (LU, 99005)
          WRITE (LU, 99006)
          WRITE (LU, 99007)
          WRITE (LU, 99260)
        ENDIF
      ENDIF
      RETURN
99999 FORMAT (
     1 8X,  A, ' : ', A, ////,
     2 17X, 43('='), /,
     3 17X, 'S U P P L E M E N T A R Y   M A T E R I A L', /,
     4 17X, 43('='), //,
     2 17X, 'B E L O N G I N G   TO   T H E   P A P E R', /////////,
     3 35X, 'b y', //////////,
     4 29X, 'C o n t e n t s', /, 29X, 15('='), /)
99998 FORMAT (8X, 'Atom', 10X, 'x', 12X, 'y', 12X, 'z', 6X,
     1 'U(eq) [Ang^2]', /, 8X, '----', 4X, 3(5X, '---', 5X),
     2  11('-'), /)
99997 FORMAT (4X, 'Atom', 4X, 'U(1,1) or U',
     1 2X, 'U(2,2)', 5X, 'U(3,3)', 5X, 'U(2,3)', 5X, 'U(1,3)',
     2 5X, 'U(1,2)', /, 4X, '----',  6X, 6('------',5X))
99996 FORMAT (/, 11X, 'Starred Atom sites have a S.O.F less ',
     1 'than 1.0')
99995 FORMAT (8X, 'Atom', 10X, 'x', 12X, 'y', 12X, 'z', 5X,
     1 'U(iso) [Ang^2]', /, 8X, '----', 4X, 3(5X, '---', 5X), 11('-'))
99993 FORMAT (/, 10X,
     1 'U(eq) = 1/3 of the trace of the orthogonalized U Tensor')
99989 FORMAT (/, 11X, 55('='), /)
99988 FORMAT (9X,'The Temperature Factor has the Form of Exp(-T) Where')
99987 FORMAT (8X,'T = 8*(Pi**2)*U*(Sin(Theta)/Lambda)**2  for Isotr',
     1 'opic Atoms')
99986 FORMAT (8X, 'T = 2*(Pi**2)*Sumij(h(i)*h(j)*U(i,j)*Astar(i)*Astar',
     1 '(j)), for', /, 6X, 'Anisotropic Atoms. Astar(i) are Reciprocal',
     2 ' Axial Lengths and', /, 10X, 'h(i) are the Reflection Indices.')
99985 FORMAT (1X)
99984 FORMAT (I4, 1X, A)
99983 FORMAT (A)
99982 FORMAT (A, 35X, '-', I3, ' -', /)
99981 FORMAT (A, 2X, A)
99978 FORMAT (8X, 'Table ', A, I2, ' - Crystallographic Data', /, A,
     1        19X, 'for: ', A, /, A)
99977 FORMAT (35X, 'Crystal Data', /)
99976 FORMAT (8X, 'Formula', 1X, A, A)
99975 FORMAT (8X, 'Formula Weight', 43X, F9.2, A)
99974 FORMAT (8X, 'Crystal System', 40X, A, A)
99973 FORMAT (8X, 'Space group', 34X, A, 1X, A, ' (No.', I3, ')', A)
99970 FORMAT (8X, 'Z', 60X, I5, A)
99969 FORMAT (8X, 'D(obs), D(calc) [g/cm**3]', 29X, F5.3, ', ', F5.3, A)
99968 FORMAT (8X, 'F(000)', 52X, I8, A)
99967 FORMAT (8X, 'Mu(', A, ') [ /mm ]', 43X, F7.3, A)
99966 FORMAT (8X, 'Crystal Size [mm]', 27X, 2(F6.2, ' x'), F6.2, A)
99965 FORMAT (31X, 'Data Collection', /)
99964 FORMAT (8X, 'Temperature (K)',46X, I5, A)
99963 FORMAT (8X, 'Radiation [Angstrom]', 29X, A, 5X, F8.5, A)
99962 FORMAT (8X, 'Theta Min-Max [Deg]', 35X, F5.1, ',', 1X, F5.1, A)
99957 FORMAT (8X, 'Dataset', 32X, I3, ':', I3, ' ;', I4, ':', I3,
     1            ' ;', I4, ':', I3, A)
99956 FORMAT (8X, 'Tot., Uniq. Data, R(int)', 20X, I6, ', ', I6,
     1        ', ', F6.3, A)
99955 FORMAT (8X, 'Observed data [I > ', F3.1, ' sigma(I)]', 26X, I8, A)
99954 FORMAT (34X, 'Refinement', /)
99953 FORMAT (8X, 'Nref, Npar', 45X, I5, ',', I5, A)
99952 FORMAT (8X, 'R, wR2, S', 36X, F7.4, ',', F7.4, ',', F5.2, A)
99951 FORMAT (8X, 'w = ', A, A)
99950 FORMAT (8X, 'Max. and Av. Shift/Error', 31X, F5.2, ',', F5.2, A)
99949 FORMAT (8X, 'Min. and Max. Resd. Dens. [e/Ang^3]', 20X,
     1        F5.2, ',', F5.2)
99948 FORMAT (8X, 'D(calc) [g/cm**3]', 44X, F5.3, A)
99947 FORMAT (8X, 'Flack x', 45X, A, A)
99799 FORMAT (/, 'loop_', 7(/, A))
99499 FORMAT (/, 'loop_', 10(/, A))
99399 FORMAT (A, '''see text''')
99397 FORMAT (A, /, '''', A, '''')
99197 FORMAT (A, /, '''', A)
99396 FORMAT (A, F10.2)
99394 FORMAT (A, /,
     1        '''Locally modified CAD4 Software (Enraf-Nonius, 1989)''',
     1        /, A, '''SET4 (de Boer & Duisenberg, 1984)''',
     2        /, A, '''HELENA (Spek, 1997)''')
99393 FORMAT (A, ' ?', /, A, ' ?', /, A, ' ?')
99392 FORMAT (A, ' ''Rotating Anode'' ', /, A, ' ''graphite'' ')
99391 FORMAT (A, ' ?')
99390 FORMAT (A, A)
99389 FORMAT (A, ' ''PLATON (Spek, 2003)'' ')
99388 FORMAT (A, 1X, A, /, A, 1X, A, /, A, 1X, A)
99382 FORMAT (A, 1X, A)
99376 FORMAT (A, 1X, A)
99375 FORMAT (A, 1X, '''', A, '''', /, A, 1X, '''', A, '''', /, A, I10)
99373 FORMAT (/, 'loop_', 2(/, A))
99362 FORMAT (A, 1X, '''', A, '''')
99357 FORMAT (/, 'loop_', /, A, /, A, /, A, /,
     1 ' ? ? ?')
99355 FORMAT ('# number of measured reflections (redundant set)')
99351 FORMAT (A, /, ';', /, ';')
99348 FORMAT (A, 1X, A)
99347 FORMAT (A, 1X, A)
99346 FORMAT (A, 1X, '''', A, '''', /, A, /, A)
99345 FORMAT (3(A, '''', A, '''', /))
99344 FORMAT (A, 1X, '''', A, '''')
99342 FORMAT (A, /, A)
99341 FORMAT (A, ' ?', /, A, '.')
99332 FORMAT (A, ' ?')
99324 FORMAT (/, '# number of unique reflections')
99323 FORMAT ('# number of observed reflections (> n sig(I))')
99322 FORMAT (A, 1X, A)
99300 FORMAT ('# CIF-file generated for ', A, /)
99299 FORMAT ('#', 78('='))
99298 FORMAT ('data_', A)
99297 FORMAT (/, '# 0. AUDIT DETAILS', /)
99296 FORMAT (A, 1X, '''',A, '''', /,
     2        A, ' ''PLATON <TABLE ', A, '> option'' ', /,
     3        A, /, ';', /, ';')
99295 FORMAT (/, '#', 79('='), /)
99294 FORMAT ('# 1. SUBMISSION DETAILS', /)
99293 FORMAT (A, '# Name of author for correspondence',
     1        /, ';', / ';', /,
     2        A, '# address of author for correspondence',
     3        /, ';', /, ';', /)
99292 FORMAT (A, 1X, A)
99291 FORMAT (1X)
99290 FORMAT (A, ' ''Acta Crystallographica C'' ', /,
     1 '# Publication choise FI, CI or EI for Inorganic', /,
     2 '#                    FM, CM or EM for Metal-organic', /,
     3 '#                    FO, CO or EO for Organic', /, A, ' ?')
99289 FORMAT (A, '# Include date of submission', /, ';', /,
     1 'Date of submission ?', //,
     2 'Please consider this CIF submission for publication as a', /,
     3 'Regular Structural Paper in Acta Crystallographica C. ', /, ';')
99288 FORMAT ('# 2. PROCESSING SUMMARY (JOURNAL OFFICE ONLY)', /)
99287 FORMAT (A, ' ?', //, 3(A, ' ?', /), /, 4(A, ' ?', /), /,
     1        2(A, ' ?', /), A, /, ';', /, ';', //, A, ' ?', /,
     2        A, /, ';', /, ';', //, 7(A, ' ?', /), //,
     3        2(A, ' ?', /))
99286 FORMAT ('# 3. TITLE AND AUTHOR LIST', /)
99285 FORMAT (A, /, ';', /, ';', /,
     1        A, /, ';', /, ';')
99284 FORMAT (/, '# The loop structure below should contain the ',
     1        'names and adresses of all', /, '# authors, in the ',
     2        'required order of publication. Repeat as necessary.', /)
99283 FORMAT (/, 'loop_', 3(/, A), /, '''?'' # author name',
     1        /, ';   # author related footnote', /, ';',
     2        /, ';   # Address of this author', /, ';')
99282 FORMAT ('# 4. TEXT', /)
99281 FORMAT (A, /, ';', /, ';')
99280 FORMAT ('# 5. CHEMICAL DATA', /)
99279 FORMAT ('   ''Spek, Anthony L.''', /,
     1        ';  # author related footnote', /, ';')
99278 FORMAT (A, '# Name  of author for correspondence',
     1        /, ';   Prof. Dr. A.L. Spek', /, ';', /,
     2        A, '# Address of author for correspondence')
99277 FORMAT (';   Bijvoet Center for Biomolecular Research', /,
     1        '    Crystal and Structural Chemistry', /,
     2        '    Utrecht University', /,
     3        '    Padualaan 8', /,
     4        '    3584 CH Utrecht', /,
     5        '    The Netherlands', /, ';')
99276 FORMAT (A, /, ';', /,
     1      ' Refinement on F^2^ for ALL reflections except those', /
     2    , ' flagged by the user for potential systematic errors.',
     3   /, ' Weighted R-factors wR and all goodnesses of fit S', /,
     4      ' are based on F^2^, conventional R-factors R are based',
     5   /, ' on F, with F set to zero for negative F^2^. The', /,
     6      ' observed criterion of F^2^ > 2sigma(F^2^) is used only',
     7   /, ' for calculating -R-factor-obs etc. and is not', /,
     8      ' relevant to the choice of reflections for refinement.'
     9 , /, ' R-factors based on F^2^ are statistically about twice',
     *   /, ' as large as those based on F, and R-factors based on',
     1   /, ' ALL data will be even larger.', /, ';')
99274 FORMAT (A, /, ';', /, 'This work was supported in part (ALS) ',
     1        'by the Council for the Chemical', /, 'Sciences of the ',
     2        'Netherlands Organization for Scientific Research ',
     3        '(CW-NWO).', /, ';')
99270 FORMAT (/, 'loop_', 5(/, A))
99269 FORMAT ('# 6. CRYSTAL DATA', /)
99268 FORMAT (A, /, ';', /, ';')
99266 FORMAT ('# 7. EXPERIMENTAL DATA', /)
99265 FORMAT (A, /, ';', /, ';')
99264 FORMAT (A, ' ?')
99263 FORMAT ('# 8. REFINEMENT DATA', /)
99262 FORMAT ('# 9. ATOMIC COORDINATES AND DISPLACEMENT PARAMETERS')
99261 FORMAT (A, 2X, A, 2F10.4, /,
     1 ' ''International Tables Vol C Tables 4.2.6.8 and 6.1.1.4''')
99260 FORMAT (/, '#===END')
99259 FORMAT (A, /, ';', /, ' Allen, F.H. (2002).', /,
     1 '   Acta Cryst. B58, 380-388.', //,
     2 ' Altomare, A., Burla, M.C., Camalli, M., Cascarano, G.L.,',
     3 ' Giacovazzo, C.', /, '   Guagliardi, A., Moliterni, A.G.G.,',
     4 ' Polidori, G. & Spagna, R.', /,
     5 '   (1999) J. Appl. Cryst. 32, 115-119.', //,
     6 ' Beurskens, P.T., Beurskens, G., de Gelder, R.,',
     7 ' Garc', A, A, 'ia-Granda, S.,', /, ' Gould, R.O., Israel, R.',
     8 ' & Smits, J.M.M. (1999) The DIRDIF99 Program System,', /,
     9 '   Technical Report of the Crystallography Laboratory,', /,
     1 '   University of Nijmegen, The Netherlands.', //,
     2 ' Boer, J.L. de & Duisenberg, A.J.M. (1984). Acta Cryst.',
     3 ' A40, C-410.', //,
     4 ' Boeyens, J.C.A. (1978). J.Cryst.Mol.Struct. 8, 317-320.', //,
     5 ' Cremer, D. & Pople, J.A. (1975). J. Am. Chem. Soc. 97,',
     6 ' 1354-1358.', //,
     7 ' Duisenberg, A.J.M. (1992). J. Appl. Cryst. 25, 92-96.', /)
99258 FORMAT (' Duisenberg, A.J.M., Kroon-Batenburg, L.M.J. &',
     1 ' Schreurs, A.M.M. (2003).', /,
     2 '   J. Appl. Cryst. 36, 220-229.', //,
     3 ' Enraf-Nonius (1989). CAD-4 Software. Version 5.',
     4 ' Enraf-Nonius, Delft,', /, '   The Netherlands.', //,
     5 ' Flack, H.D. (1983). Acta Cryst. A39, 876-881.', //,
     6 ' Hooft, R.W.W. (1998). Collect Software, Nonius',
     7 ' B.V., Delft, The Netherlands.', //,
     8 ' LePage, Y. (1987). J. Appl. Cryst. 20, 264-269.', //,
     9 ' Mackay, A.L. (1984). Acta Cryst. A40, 165-166.', //,
     * ' Meulenaer, J. de & Tompa, H. (1965). Acta Cryst. 19,',
     1 ' 1014-1018.', //, ' North, A.C.T.,',
     2 ' Phillips, D.C. & Mathews, F.S. (1968).', /, '  Acta Cryst.',
     3 ' A24, 351-359.', //, ' Otwinowski, Z. & Minor, W. (1997).',
     4 ' Methods in Enzymology, Vol. 276,', /, 3X, 'Macromolecular',
     5 ' Crystallography, Part A, edited by C.W. Carter &', /, 3X,
     6 ' R.M. Sweet, pp. 307-326. London: Academic Press.', //,
     7 ' Sheldrick, G.M. (1986). SHELXS86.',
     8 ' University of G\"ottingen, Germany.', /)
99257 FORMAT (' Sheldrick, G.M. (1993). SHELXL93.',
     1 ' University of G\"ottingen, Germany.', //,
     2 ' Sheldrick, G.M. (1997). SHELXS97.',
     3 ' University of G\"ottingen, Germany.', //,
     4 ' Sheldrick, G.M. (1997). SHELXL97.',
     5 ' University of G\"ottingen, Germany.', //,
     6 ' Sluis, P. van der & Spek, A.L. (1990). Acta Cryst. A46,',
     7 ' 194-201.', //,
     8 ' Spek, A.L. (1987). Acta Cryst. C43, 1233-1235.', //,
     9 ' Spek, A.L. (1988). J. Appl. Cryst. 21, 578-579.', //,
     * ' Spek, A.L. (1994). Am. Crystallogr. Assoc.-Abstracts,',
     1 ' 22, 66.', //,
     2 ' Spek, A.L. (1997). HELENA, Program for Datareduction,',
     3 ' Utrecht', /, '   University, The Netherlands.', //,
     4 ' Spek, A.L. (2003). J. Appl. Cryst. 36, 7-13.', //,
     5 ' Wilson, A.J.C. (1992). Ed. International Tables for',
     6 ' Crystallography,', /, '   Volume C, Kluwer Academic',
     7 ' Publishers, Dordrecht, The Netherlands.',
     8 /, ';')
99255 FORMAT (A, /, ';', /,
     1 'Least Squares Treatment of 25 SET4 setting angles.', /,
     2 ';')
99254 FORMAT (A, /, ' ''Flack H.D. (1983), Acta Cryst. A39, 876-881'' ')
99060 FORMAT (/, '# Permitted for _chemical_absolute_configuration:', /,
     1 '# Absolute configuration details', /,
     2 '# rm   = Det. by chiral ref. mol. with known abs.conf', /,
     3 '# ad   = Det. by anomalous dispersion', /,
     4 '# rmad = Det. by ''rm'' and ''ad'' ', /,
     5 '# syn  = Det. with reference to synthesis', /,
     6 '# unk  = Unknown/Arbitrary', /, A, A, /)
99253 FORMAT ('# Ex: ''C12 H16 N2 O6, H2 O'' and',
     1 ' ''(Cd 2+)3, (C6 N6 Cr 3-)2, 2(H2 O)'' ')
99252 FORMAT (/, '# Insert blank lines between paragraphs', /)
99251 FORMAT (/, '# Insert blank lines between references', /)
99250 FORMAT (A, /, ';', /, ' ?', /, ';', /,
     1        A, /, ';', /, ' ?', /, ';')
99249 FORMAT (/, ' Translation of Symmetry Code to Equiv.Pos', //)
99248 FORMAT (A, /, ';', /, ' ?', /, ';', /,
     1        A, /, ';', /, ' ?', /, ';')
99247 FORMAT (A, ' '' psi-scan'' ', /, A, /,
     1        ' ''(North et al., 1968)'' ')
99246 FORMAT (A, '''', A, '''', /,
     1        '# Example: ''(North et al., 1968)''', /,
     2        A, ' ?')
99245 FORMAT (A, /,
     1 '; View of the title compound with the atom numbering scheme.',
     2 /, 'Displacement ellipsoids for non-H atoms are drawn at the',
     3 ' 50% probability level.', /, ';')
99244 FORMAT (/, '# Permitted for _exptl_absorpt_correction_type :', /,
     1        '# analytical     ''analytical from crystal shape''', /,
     2        '#                Example: de Meulenaer&Tompa: ABST', /,
     3        '# cylinder       ''cylindrical''', /,
     4        '# gaussian       ''Gaussian from crystal shape''', /,
     5        '#                Example: PLATON/ABSG', /,
     6        '# integration    ''integration from crystal shape''', /,
     7        '# multi-scan     ''symmetry-related measurements''', /,
     8        '#                Example: SADABS, MULABS', /,
     9        '# none           ''no absorption corr. applied''', /,
     *        '# numerical      ''numerical from crystal shape''', /,
     1        '# psi-scan       ''psi-scan corrections''', /,
     2        '#                Example: PLATON/ABSP', /,
     3        '# refdelf        ''refined from delta-F''', /,
     4        '#                Example: SHELXA, DIFABS, DELABS', /,
     5        '# sphere         ''spherical''', /,
     6        '#                Example: PLATON/ABSS')
99243 FORMAT (2(A, '''', A, '''', /))
99301 FORMAT (/, '# Permitted for _refine_ls_hydrogen_treatment :', /,
     1           '# refall  - refined all H parameters', /,
     2           '# refxyz  - refined H coordinates only', /,
     3           '# refU    - refined H U only', /,
     4           '# noref   - no refinement of H parameters', /,
     5           '# constr  - H parameters constrained', /,
     6           '# mixed   - some constrained, some independent', /,
     7           '# undef   - H-atom parameters not defined', /,
     8        A, '''', A, '''', /)
99061 FORMAT (A, 2X, A, 2(' ?'), /,
     1 ' ''International Tables Vol C Tables 4.2.6.8 and 6.1.1.4''')
99001 FORMAT (/, '# Loop Mechanism for Extra Tables(s)', /,
     1        /, '#loop_',
     2        /, '#_publ_manuscript_incl_extra_item',
     3        /, '#''_geom_extra_tableA_col_1''',
     4        /, '#''_geom_extra_tableA_col_2''',
     5        /, '#''_geom_extra_tableA_col_3''',
     6        /, '#''_geom_extra_table_head_A''',
     7        /, '#''_geom_table_footnote_A''',
     8        /, '#''_geom_extra_tableB_col_1''',
     9        /, '#''_geom_extra_tableB_col_2''',
     *        /, '#''_geom_extra_tableB_col_3''',
     1        /, '#''_geom_extra_table_head_B''',
     2        /, '#''_geom_table_footnote_B''', /)
99002 FORMAT (/, '#',
     1        /, '#loop_',
     2        /, '#_geom_extra_tableA_col_1',
     3        /, '#_geom_extra_tableA_col_2',
     4        /, '#_geom_extra_tableA_col_3',
     5        /, '# ? ? ?', /)
99003 FORMAT (/, '#',
     1        /, '#loop_',
     2        /, '#_geom_extra_tableB_col_1',
     3        /, '#_geom_extra_tableB_col_2',
     4        /, '#_geom_extra_tableB_col_3',
     5        /, '# ? ? ?', /)
99004 FORMAT (/, '#',
     1        /, '#_geom_table_footnote_A',
     2        /, '#;', /, '# ?', /, '#;', /)
99005 FORMAT (/, '#',
     1        /, '#_geom_table_footnote_B',
     2        /, '#;', /, '# ?', /, '#;', /)
99006 FORMAT (/, '#',
     1        /, '#_geom_table_footnote_A',
     2        /, '#;', /, '# ?', /, '#;', /)
99007 FORMAT (/, '#',
     1        /, '#_geom_table_footnote_B',
     2        /, '#;', /, '# ?', /, '#;', /)
      END
      SUBROUTINE PLA174 (MODE, FORM, FORMH, LU, CTAB, NTAB, MXLIN,
     1 LSTART, NCOL, INCLH, IPS1, IPS2, IDECM, IDOUBL)
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16,
     1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NPVD=40000000,
     2 NP22=256,NP23=18000,NP25=99,NP29=63,NP34=509,NP38=125,NP39=30,
     3 NP41=200,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /CIF/ CIFDIR
      CHARACTER CIFDIR(NP34)*36
      COMMON // JNSC(2, NP23), VOID(NPVD)
      DIMENSION DHA(4), IDHA(4)
      CHARACTER CTAB*1
      CHARACTER FORM*(*), FORMH*(*), DASH*1, GSS(4)*8
      ISPACE = 0
      JMX    = 0
      NHATS  = 0
      NHET   = 0
      IF (MODE .EQ. 4) THEN
        ISPACE = 8
        IF (LU .EQ. LU2) THEN
          WRITE (LU, 99995)
          WRITE (LU, 99994)
          WRITE (LU, 99993) CIFDIR(277)
          WRITE (LU, 99998) CIFDIR(265), CIFDIR(266), CIFDIR(267),
     1                      CIFDIR(269), CIFDIR(270), CIFDIR(268)
          ISPACE = 1
        ENDIF
      ELSE IF (MODE .EQ. 5) THEN
        ISPACE = 4
        IF (LU .EQ. LU2) THEN
          WRITE (LU, 99997) CIFDIR(258), CIFDIR(259), CIFDIR(260),
     1                      CIFDIR(257), CIFDIR(262), CIFDIR(263),
     2                      CIFDIR(264), CIFDIR(261)
          ISPACE = 1
        ENDIF
      ELSE IF (MODE .EQ. 6) THEN
        ISPACE = 9
        IF (LU .EQ. LU2) THEN
          WRITE (LU, 99996) CIFDIR(279), CIFDIR(280), CIFDIR(281),
     1                      CIFDIR(282), CIFDIR(278), CIFDIR(284),
     2                      CIFDIR(285), CIFDIR(286), CIFDIR(287),
     3                      CIFDIR(283)
          ISPACE = 1
        ENDIF
      ELSE IF (MODE .EQ. 7) THEN
        ISPACE = 8
        IF (LU .EQ. LU2) THEN
          WRITE (LU, 99998) CIFDIR(271), CIFDIR(272), CIFDIR(273),
     1                      CIFDIR(275), CIFDIR(276), CIFDIR(274)
          ISPACE = 1
        ENDIF
      ELSE IF (MODE .EQ. 8) THEN
        ISPACE = 1
        IF (LU .EQ. LU2) THEN
          WRITE (LU, 99992)
     1      CIFDIR(426)(1:29), CIFDIR(427)(1:29), CIFDIR(428)(1:29),
     2      CIFDIR(429)(1:23), CIFDIR(430)(1:23), CIFDIR(431)(1:23),
     3      CIFDIR(432)(1:21), CIFDIR(433)(1:27), CIFDIR(434)(1:21)
            FORM(84:86) = 'yes'
        ENDIF
      ENDIF
      IN01 = IPR(229 + MODE) + 1
      IN02 = IPR(223 + MODE)
      IF (MODE .LT. 7) THEN
        JMX  = MODE - 2
      ELSE IF (MODE .EQ. 7) THEN
        JMX = 2
      ENDIF
      IF (LU .EQ. LU12) THEN
        WRITE (LU, 99990) CHAR(12)
      ELSE IF (LU .EQ. LU13) THEN
        IGBL(85) = IGBL(85) + 1
        WRITE (LU, 99999) CHAR(12), IGBL(85)
      ENDIF
      DASH = ' '
      IF (LU .NE. LU2) THEN
        CALL PLA176 (-1, LU, CTAB, NTAB, FORMH, JID)
        IF (MODE .EQ. 7) THEN
          DASH = '.'
        ELSE
          DASH = '-'
        ENDIF
      ENDIF
      IF (MODE .EQ. 8) THEN
        DO 20 J = IN01, IN02
          L = JNSC(2, J)
          CALL PLA047 (  VOID(L),     NQ1, ISOP, IENR, IPR(119),
     1                 IGBL(55), 0, 1)
          CALL PLA047 (  VOID(L + 1), NQ2, ISOP, IENR, IPR(119),
     1                 IGBL(55), 0, 1)
          CALL PLA047 (- VOID(L + 2), NQ3, ISOP, IENR, IPR(119),
     1                 IGBL(55), 0, 1)
          IF (LU .EQ. LU13) THEN
            NQ1(6:7) = '--'
            NQ2(6:7) = '..'
          ENDIF
          IF (ISOP .EQ. 1) THEN
            GSS(3) = '    .   '
          ELSE
            MISOP  = MOL(ISOP) / NINT(PAR(42))
            MISOPH = MISOP / 1000
            MISOPT = MISOP - MISOPH * 1000
            WRITE (GSS(3)(1:8), 99991) MISOPH, MISOPT
          ENDIF
          NDECM = IDECM
          M = 0
          DO 10 K = 1, 7, 2
            M = M + 1
            IF (K .EQ. 7) NDECM = 2
            DHA(M) = VOID(L + K + 2)
            CALL GEN041 (DHA(M), VOID(L + K + 3), IDHA(M), NDECM,
     1           IDEC, IPR(68))
            IPS = 1 + M * 16
            FORM(IPS:IPS) = CHAR(ICHAR('0') + IDEC)
   10     CONTINUE
          WRITE (PRBUF, FORM) NQ1, NQ2, NQ3,
     1           (DHA(M), IDHA(M), M = 1, 4), GSS(3)
          IF (IDOUBL .EQ. 2) WRITE (LU, '(1X)')
          CALL GEN065 (LU, PRBUF, 80, 1)
   20   CONTINUE
        GOTO 110
      ENDIF
      IF (IDOUBL .EQ. 2) WRITE (LU, '(1X)')
      FORM(2 : 2) = CHAR(ICHAR('0') + ISPACE)
      NLIN        = MXLIN - LSTART
      ITEL        = LSTART
      IN3         = IPR(231)
      IN1         = IN3 + 1
      IN2         = IN3
      DO 30 J = IN01, IN02
        MJNSC = MOD(JNSC(1, J), IPR(466))
        IF (INCLH .NE. 0 .OR. MJNSC .LE. IPR(465)) THEN
          IN2          = IN2 + 1
          JNSC(1, IN2) = MJNSC
          JNSC(2, IN2) = JNSC(2, J)
        ENDIF
   30 CONTINUE
      IC  = NLIN * NCOL
      ICP2 = NCOL
      IN   = IN2 - IN1 + 1
      INP  = (IN + NCOL - 1) / NCOL
      INP  = INP * NCOL
      INM  = INP - IN
      IN2P = IN2 + INM
      DO 40 J = 1, INM
        JNSC(2, J + IN2) = 0
   40 CONTINUE
      IM = (INP + IC - 1) / IC
      IC3 = INP - (IM - 1) * IC
      DO 70 M = 1, IM
        I = (M - 1) * NLIN * NCOL + IN1 - 1
        IF (M .GE. IM) IC = IC3
        ICS = IC / NCOL
        DO 60 J = 1, NCOL
          DO 50 K = 1, ICS
            IND = I + (J - 1) * ICS + K
            JNSC(1, IND) = (K - 1) * NCOL + J
   50     CONTINUE
   60   CONTINUE
        CALL GEN037 (JNSC, I + 1, I + IC)
   70 CONTINUE
      K = 0
      DO 100 I = IN1, IN2P
        K = K + 1
        L = JNSC(2, I)
        IF (L .LE. 0) THEN
          ICP2 = ICP2 - 1
        ELSE
          NHATS = 0
          NHET  = 0
          DO 80 J = 1, JMX
            VOIDLJ = VOID(L + J - 1)
            IF (LU .EQ. LU2) VOIDLJ = - VOIDLJ
            CALL PLA047 (VOIDLJ, NQ1, ISOP, IENR, IPR(119), IGBL(55),
     1                   0, 1)
            IF (IENR .EQ. 1) NHATS = NHATS + 1
            IF (IENR .GT. 2) NHET  = NHET  + 1
            NAMS(K, J) = NQ1//' '
            IF (LU .EQ. LU2) THEN
              IF (ISOP .EQ. 1) THEN
                GSS(J) = '    .   '
              ELSE
                MISOP  = MOL(ISOP) / NINT(PAR(42))
                MISOPH = MISOP / 1000
                MISOPT = MISOP - MISOPH * 1000
                WRITE (GSS(J), 99991) MISOPH, MISOPT
              ENDIF
            ENDIF
   80     CONTINUE
          V2(K) = VOID(L + JMX)
          CALL GEN041 (V2(K), VOID(L + JMX + 1), ISDV(K),
     1                IDECM, IDEC, IPR(68))
          IPS = K * IPS1 - IPS2
          FORM(IPS : IPS) = CHAR(ICHAR('0') + IDEC)
        ENDIF
        IF (K .GE. NCOL) THEN
          ITEL = ITEL + 1
          IF (ITEL .GT. MXLIN) THEN
            ITEL = LSTART + 1
            IF (LU .EQ. LU12) THEN
              WRITE (LU, 99990) CHAR(12)
            ELSE IF (LU .EQ. LU13) THEN
              IGBL(85) = IGBL(85) + 1
              WRITE (LU, 99999) CHAR(12), IGBL(85)
            ENDIF
            IF (LU .NE. LU2) THEN
              CALL PLA176 (1, LU, CTAB, NTAB, FORMH, JID)
            ENDIF
            IF (IDOUBL .EQ. 2) WRITE (LU, '(1X)')
          ENDIF
          WRITE (PRBUF, FORM) ((NAMS(M, J)(1:7), DASH, J = 1, JMX - 1),
     1      NAMS(M, JMX)(1:7), V2(M), ISDV(M), M = 1, ICP2)
          IF (LU .EQ. LU2) THEN
            DO 90 M = 1, JMX
              J = 38 + M * 8
              PRBUF(J : J + 8) = GSS(M)
   90       CONTINUE
            IF (MODE .LT. 7 .AND. NHATS .EQ. 0 .AND.
     1        NHET .GT. 0 .AND. JMX .LT. 4) THEN
              PRBUF(78:80) = 'yes'
            ELSE
              PRBUF(78:80) = 'no '
            ENDIF
          ENDIF
          CALL GEN065 (LU, PRBUF, 80, 1)
          IF (IPR(431) .GE. 0 .AND. IDOUBL .EQ. 2) WRITE (LU, '(1X)')
          K    = 0
          ICP2 = NCOL
        ENDIF
  100 CONTINUE
  110 RETURN
99999 FORMAT (A, 35X, '-', I3, ' -', /)
99998 FORMAT (/, 'loop_',  6(/, A))
99997 FORMAT (/, 'loop_',  8(/, A))
99996 FORMAT (/, 'loop_', 10(/, A))
99995 FORMAT (/, '#', 79('='), /)
99994 FORMAT ('# 10. MOLECULAR GEOMETRY', /)
99993 FORMAT (A, /, ';', /,
     1 ' Bond distances, angles etc. have been calculated using the',
     2 /,
     3 ' rounded fractional coordinates. All su''s are estimated', /,
     4 ' from the variances of the (full) variance-covariance matrix'
     5 , '.', /, ' The cell esds are taken into account in the',
     6 ' estimation of', /,
     7 ' distances, angles and torsion angles', /,
     7 ';')
99992 FORMAT (/, 'loop_', 9(/, A), /, '#', /,
     1 '#D   H   A   D - H  H...A   D...A    D - H...A  symm(A)', /,
     2 '#')
99991 FORMAT (I3, '_', I3, 1X)
99990 FORMAT (A)
      END
      SUBROUTINE PLA175 (MODE, LU, NCIFDIR, STR, IVAR, VAR)
      PARAMETER (NP34=509)
      COMMON /CIF/ CIFDIR
      CHARACTER CIFDIR(NP34)*36, STR*(*)
      IF (MODE .EQ. 1) THEN
        WRITE (LU, 99999) CIFDIR(NCIFDIR), STR
      ELSE IF (MODE .EQ. 2) THEN
        IF (IABS(IVAR) .LT. 999999) THEN
          WRITE (LU, STR) CIFDIR(NCIFDIR), IVAR
        ELSE
          WRITE (LU, 99999) CIFDIR(NCIFDIR), ' ?'
        ENDIF
      ELSE IF (MODE .EQ. 3) THEN
        IF (ABS(VAR) .LT. 10000.0) THEN
          WRITE (LU, STR) CIFDIR(NCIFDIR), VAR
        ELSE
          WRITE (LU, 99999) CIFDIR(NCIFDIR), ' ?'
        ENDIF
      ENDIF
      RETURN
99999 FORMAT (2A)
      END
      SUBROUTINE PLA176 (MODE, LU, CTAB, NTB, FORM, JID)
      CHARACTER CTAB*1, FORM*(*), JID*(*), CHCON*11
      IF (MODE .LE. 0) THEN
        N     = 1
        CHCON = ' '
      ELSE
        N     = 11
        CHCON = '(continued)'
      ENDIF
      IF (MODE .EQ. 0) NTB = NTB + 1
      IF (NTB .GT. 9) FORM(19:19) = '2'
      WRITE (LU, FORM) CTAB, NTB, CHCON(1:N), JID(1:40)
      RETURN
      END
      SUBROUTINE PLA178 (NPC, LU)
      PARAMETER (NP12=600,NP13=500,NP17=99,NP38=125,NP39=30)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      INTEGER KJ(3), NCL(30), SKI(8, 30), INC(3, 7), IG(4, 4), NQ(7),
     1 MQ(7), GC(4, 4), Q(27), NVV(8), MVV(8), LVV(8), TR(3, 3, 85),
     2 IV(7, 7), NL(4), TP(4, 4, 7), SB(30), IDT(13), TT(20, 14)
      REAL G(4, 4), GN(4, 4), A(4, 4), AW(3, 3), AV(4, 4), PP(4, 4, 6),
     1 GW(3, 3), GG(3, 3), AC(6), E(4,4), GV(4, 4), GS(7, 7), AD(4, 4),
     2 O(7, 7)
      CHARACTER Y(6)*1, HT(7)*1, NPC*1, PRBUF*132
      COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0
      COMMON /PAGENM/ PAGET, PAGEIND(25)
      CHARACTER PAGET*8, PAGEIND*8
      COMMON /CGG11/ BCD, SBCD
      CHARACTER BCD*132, SBCD*132
      COMMON /CGGT/ IGGT
      CHARACTER IGGT*80
      DATA Y/ 'a', 'm', 'o', 't', 'h', 'c'/
      DATA HT/ 'P', 'A', 'B', 'C', 'F', 'I', 'R'/
      DATA GC /0,12,13,14,12,0,23,24,13,23,0,34,14,24,34,0/
      DATA Q /1,1,4,1,1,2,3,2,2,1,1,3,1,1,4,4,3*2,3,3,4,2,3,4,4,1/
      DATA PP /-1.0,3*0.0,1.0,0.0,1.0,2*0.0,1.0,2*0.0,1.0,2*0.0,1.0,
     1 -1.0,3*0.0,2*1.0,4*0.0,1.0,0.0,1.0,2*0.0,1.0,-1.0,3*0.0,2*1.0,
     2 5*0.0,2*1.0,0.0,1.0,2*0.0,-1.0,2*0.0,2*1.0,4*0.0,1.0,2*0.0,
     3 1.0,0.0,1.0,0.0,-1.0,2*0.0,2*1.0,5*0.0,1.0,0.0,2*1.0,3*0.0,
     4 -1.0,0.0,1.0,0.0,1.0, 4*0.0,1.0,0.0,2*1.0,0.0/
      DATA NVV /14,15,19,14,14,17,18,16/
      DATA IV /0,5,6,7,2,3,4,5,0,7,6,1,4,3,6,7,0,5,4,1,2,7,6,5,0,3,2,1,
     1 2,1,4,3,0,0,0,3,4,1,2,3*0,4,3,2,1,3*0/
      DATA AD /1.0,4*0.0,1.0,4*0.0,1.0,4*0.0,1.0/
      DATA INC /1,3*0,1,3*0,1,3*-1,1,1,0,1,0,1,0,1,1/
      DATA SKI /0,0,14,0,2*14,1,61,0,0,3*14,0,2,61,0,4*13,0,3,65,6*12,4,
     1 66,12,0,12,0,12,34,1,51,0,3*13,24,0,5,57,2*12,14,12,2*14,6,57,0,
     2 0,14,0,14,34,1,41,0,0,2*14,24,0,2,41,0,0,14,23,0,23,13,41,0,4*13,
     3 34,7,46,12,4*13,12,4,46,0,0,14,0,24,34,1,31,0,0,14,23,24,0,2,31,
     4 0,13,2*14,13,0,4,36,0,2*13,2*23,0,7,36,12,0,14,0,12,34,8,34,12,0,
     5 14,0,14,34,9,34,0,2*13,2*23,34,7,36,12,13,2*14,13,12,4,36,12,
     6 4*13,34,3,35,0,13,14,0,24,34,1,21,0,13,14,2*23,0,10,26,0,13,14,
     7 23,13,0,28,26,0,13,2*14,13,34,11,26,0,13,14,13,14,34,12,26,0,13,
     8 14,2*23,34,10,26,12,13,2*14,13,34,11,26,12,13,14,13,14,34,12,26,
     9 12,13,14,23,24,34,1,11/
      DATA (((TR(I, J, K), I = 1, 3), J = 1, 3), K = 1, 21) /
     1 1, 0, 0, 0, 1, 0, 0, 0, 1, 1, 0, 0, 0, 0, 1, 0, 1, 1,
     2 1, 1, 0,-1, 1, 0, 1, 1, 2, 0, 1, 1, 1, 0, 1, 1, 1, 0,
     3 1, 0, 0, 0, 0, 1, 1, 3, 2, 1,-1, 0, 0, 1,-1, 1, 1, 1,
     4 1, 0, 0, 0, 1, 0, 1, 1, 2, 2, 1, 0, 0, 1, 0, 0, 0, 1,
     5 1,-1, 0, 1, 1, 0, 0, 0, 1,-1,-1,-2, 0, 1, 0, 1, 0, 0,
     6 0, 1, 1, 1, 1, 0,-1, 0,-1,-1,-1,-1, 1,-1, 0, 0, 0, 1,
     7 0, 1, 0, 0, 1, 1, 1, 0, 0, 1, 0, 0, 0, 1, 0, 0, 0, 1,
     8 0,-1, 0,-1, 0, 0, 0, 0,-1, 0, 0,-1, 0,-1, 0,-1, 0, 0,
     9 0, 1, 0, 0, 0, 1, 1, 0, 0, 0, 0, 1, 1, 0, 0, 0, 1, 0,
     *-1, 0, 0, 0, 0,-1, 0,-1, 0, 1, 0, 0, 0,-1, 0,-1, 0,-1,
     1 0, 0,-1, 0, 1, 0, 1, 0, 1/
      DATA (((TR(I, J, K), I = 1, 3), J = 1, 3), K = 22, 85) /
     1 1,0,1,0,1,0,-1,2*0,1,0,1,0,-1,3*0,-1,1,3*0,1,3*0,2*1,
     1 3*0,-1,3*0,2*-1,3*0,1,3*0,2*-1,3*0,-1,3*0,3*1,0,0,3*-1,0,-1,1,1,
     2 0,0,-1,1,1,4*-1,0,0,1,1,-1,1,2*-1,1,0,0,4*-1,1,1,0,1,1,0,-1,0,1,
     3 0,0,1,1,0,-1,1,1,4*0,3*1,0,-1,1,-1,0,0,1,1,-1,0,1,1,-1,1,3*0,1,
     4 1,2*-1,1,1,3*0,-1,1,3*-1,0,1,0,1,0,1,1,2*-1,0,1,0,1,0,5*-1,1,3*0,
     5 1,1,0,0,1,3*0,1,0,-1,0,1,0,-1,1,1,4*0,1,0,1,3*0,1,1,-1,0,0,3*1,
     6 4*0,-1,1,0,-1,0,1,3*0,1,1,0,0,1,2,3*0,1,0,1,0,-2,-1,3*0,1,1,2,1,
     7 1,4*0,-1,1,0,-1,1,2,3*0,1,-1,4*1,3*0,-1,1,1,2*-1,1,3*0,1,2,1,1,0,
     8 1,3*0,1,0,0,1,2,1,0,0,1,-1,6,-6,0,0,6,-6,3*3,6,6,0,0,-6,6,3,2*-3,
     9 2*-6,0,0,6,6,-3,3,-3,-6,6,0,0,2*-6,2*-3,3,3,-3,3,6,6,0,-3,3,3,
     * 2*-3,3,6,-6,0,3*3,-3,3,3,6,0,6,3,3,-3,3*3,6,0,-6,-3,3,-3,3,3,-3,
     1 0,6,6,3,-3,3,3,2*-3,0,6,-6,4*3,-3,0,3,3,3*0,6,3,0,3,3,0,-3,0,6,
     2 0,0,3,3,0,-3,3,6,0,0,3,-3,0,0,3,-3,3*6,3,3,0,0,-3,3,6,2*-6,2*-3,
     3 0,0,3,3,-6,6,-6,-3,3,0,0,2*-3,2*-6,6,0,0,6,3,3,0,-3,3,3*0,6,3,
     4 -3,0,3,3,0,6,3*0,3,3,0,-3,3,6,3*0,-3,3,0,2*-3,0,6,0,3,0,3,3,0,-3,
     5 0,6,0,3,0,2*-3,0,-3,0,0,6,6,0,0,2,4,-2,2,2*-2,6,6,3*0,6,4,2,-4,0,
     6 6,3*0,6,0,-3,3,6,3*0,3,3,3,0,-3,0,6,0,3,0,3*3,3*0,6,3,-3,0,-4,-8,
     7 -2,6,0,0,-2,-4,2,2,2*-2,6,6,0,4,-4,2,8,4,-2,0,6,0,4,2,2/
      DATA MVV/ 14, 15, 14, 17, 19, 14, 18, 16/
      DATA LVV/ 14, 14, 20, 22, 16, 21, 14, 23/
      DATA TT /141,1741,1841,657,2957,3057,3157,131,934,3234,3334,121,
     1 1721,1821,3426,3526,3626,3726,3826,3926,146,1746,1846,5457,5557,
     2 5657,5757,136,935,3235,3335,126,1726,1826,5826,5926,6026,6126,
     3 6226,6326,6446,6546,6646,6757,6857,6957,7057,135,6436,6536,6636,
     4 6426,6526,6626,7126,7226,7326,7426,7526,7626,131,934,121,1721,
     5 1821,3426,3526,13*0,136,935,126,1726,1826,5826,5926,13*0,4634,
     6 934,4734,121,4826,4926,5026,5126,5226,5326,10*0,7726,7826,
     7 7926,17*0,121,1721,1821,17*0,8021,4026,4126,17*0,8121,4226,4326,
     8 17*0,8221,4426,4526,17*0,8026,8126,8226,17*0,126,1726,1826,17*0,
     9 8326,8426,8526,17*0/
      DATA SB/21, 21, 21, 21, 11, 4, 4, 8, 8, 8, 8, 8, 4, 4, 4, 4, 4,
     1 4, 4, 4, 4, 1, 1, 1, 1, 1, 1, 1, 1, 1/
      DATA IDT /61,66,65,41,46, 51,57,31,32,33,34,35,36/
      DATA TP /6,4*0,6,4*0,6,4*0,6,6,4*0,3,3,0,0,-3,3,0,0,6,0,6,3,0,-3,
     1 0,0,6,0,0,3,0,3,3*0,6,6,3,3,0,0,-3,3,4*0,6,0,6,0,0,6,0,3,3,0,3,
     2 0,3,0,3,3,5*0,6,-3,3,3,0,3,-3,3,0,3,3,-3,0,3*3,6,4,2,2,0,-2,2,2,
     3 0,-2,-4,2,0,6,6,0,6/
      BCD(1:24) = 'Delaunay Cell Reduction'//CHAR(0)
      CALL GGIP (HORS, VERT, 0.0, 1)
      CALL GGIP20 (0.0,  BCD, 24, 1.2, 4, 8, 0.6, VERT - 1.8)
      CALL GGIP20 (0.0,  BCD, 24, 1.2, 2, 8, 0.5, VERT - 1.9)
      PAGET   = 'DELRED'
      M     = 0
      ZW4   = 0.0
      AAC   = PAR(381)
      ACL   = PAR(382)
      ISYS  = 1
      NBR   = 1
      ISE   = 1
      NCP   = 0
      IZ    = 1
      INO   = 0
      IK    = 0
      CALL GEN074 (AW, 0.0, 1, 9)
      CALL GEN074 (GW, 0.0, 1, 9)
      CALL GEN097 (NCL, 1, 30, 0)
      DO 1 I = 1, 6
        AC(I) = PAR(100 + I)
    1 CONTINUE
      DO 2 I = 1, 7
        NQ(I) = I
    2 CONTINUE
      CALL PLA269 (0)
      VRT  = VERT - 5.0
      WRITE (PRBUF, 99999) PAR(382), PAR(381)
      WRITE (LU, '(A, /, 80(''=''), /)') PRBUF(1:80)
      CALL GGIP20 (0.0, PRBUF, 80, 0.45, 1, 2, 0.2, VRT)
      WRITE (PRBUF, 99998)
      WRITE (LU, '(A, /)') PRBUF(1:80)
      VRT = VRT - 1.5
      CALL GGIP20 (0.0, PRBUF, 80, 0.40, 1, 2, 0.2, VRT)
      WRITE (PRBUF, 99997) NPC, AC
      WRITE (LU, 99987) PRBUF(1:80)
      VRT = VRT - 1.5
      CALL GGIP20 (0.0, PRBUF, 80, 0.40, 5 + IGBL(68), 2, 0.2, VRT)
      CALL GEN026 (1, GG, PAR(101), GL(5))
      DO 101 I = 1, 7
        IF (NPC .EQ. HT(I)) M = I
  101 CONTINUE
      DO 1112 I = 1, 4
        DO 1111 J = 1, 4
          G(I, J)  = 0.0
          AV(I, J) = 0.0
          AD(I, J) = TP(I, J, M) / 6.0
 1111   CONTINUE
 1112 CONTINUE
      DO 1024 I = 1, 3
        DO 1023 J = 1, 3
          DO 1022 K = 1, 3
            DO 1021 L = 1, 3
              G(I, J) = G(I, J) + GG(K, L) * AD(K, I) * AD(L, J)
 1021       CONTINUE
 1022     CONTINUE
 1023   CONTINUE
 1024 CONTINUE
      DO 105 I = 1, 3
        DO 108 J = 1, 3
          G(4, 4) = G(4, 4) + G(I, J)
          G(I, 4) = G(I, 4) - G(I, J)
  108   CONTINUE
        G(4, I) = G(I, 4)
  105 CONTINUE
  104 MC = 0
      DO 1062 I = 1, 4
        DO 1061 J = 1, 4
          A(I, J)  = AD(I, J)
          GN(I, J) = G(I, J)
          IF (ABS(G(I, J)) .LT. 0.00006) G(I, J) = 0.0
          IF (MC .EQ. 0 .AND. J .GT. I .AND. G(I, J) .GT. 0.0)
     1        MC = J + 2 * I - 3 - I / 3
 1061   CONTINUE
 1062 CONTINUE
      IF (MC .EQ. 0) GOTO 109
      DO 1074 I = 1, 4
        DO 1073 J = 1, 4
          G(I, J) = 0.0
          AD(I, J) = 0.0
          DO 1072 K = 1, 4
            AD(I, J) = AD(I, J) + A(I, K) * PP(K, J, MC)
            DO 1071 L = 1, 4
              G(I, J) = G(I, J) + GN(K, L) * PP(K, I, MC) * PP(L, J, MC)
 1071       CONTINUE
 1072     CONTINUE
 1073   CONTINUE
 1074 CONTINUE
      GO TO 104
  109 CONTINUE
      DO 2033 IST = 0, 10
        DO 1102 I = 1, 4
          DO 1101 J = 1, 4
            IG(I, J) = GC(I, J)
            A(I, J)  = AD(I, J)
 1101     CONTINUE
 1102   CONTINUE
        DO 2012 I = 1, 3
          DO 2011 J = I, 4
            ZW1 = 0.0025 * (G(I, I) + G(J, J)) * IST
            IF (ABS(G(I, J)) .LT. ZW1) IG(I, J) = 0
            DO 2022 K = 1, 3
              DO 2021 L = K, 4
                IF (IG(K, L) .EQ. 10 * K + L .AND.
     1              (K .GT. I .OR. L .GT. J) .AND.
     2              ABS(G(I, J) - G(K, L)) .LT. 3.0 *
     3             (ZW1 + 0.0025 * (G(K, K) + G(L, L)) * IST))
     4              IG(K, L) = IG(I, J)
 2021         CONTINUE
 2022       CONTINUE
            IG(J, I) = IG(I, J)
 2011     CONTINUE
 2012   CONTINUE
        DO 2032 IC = 1, 30
          DO 2031 INL1 = 1, 4
            NL(1) = INL1
            DO 205 INL2 = 1, 4
              NL(2) = INL2
              IF (NL(1) .EQ. NL(2)) GOTO 205
              DO 206 INL3 = 1, 4
                NL(3) = INL3
                IF (NL(3) .EQ. NL(1) .OR. NL(3) .EQ. NL(2)) GOTO 206
                NL(4) = 10 - NL(1) - NL(2) - NL(3)
                DO 207 MX = 1, 6
                  M1 = NL(1 + MX / 4 + MX / 6)
                  M2 = NL(1 + MX - 2 * (MX / 4) - MX / 6)
                  IYUNK = IG(M1, M2) - 5 * SKI(MX, IC)
                  IF (IYUNK .GT. 0) THEN
                    GOTO 206
                  ELSE IF (IYUNK .LT. 0) THEN
                    N1 = NL(SKI(MX, IC) / 10)
                    N2 = NL(SKI(MX, IC) - 10 * (SKI(MX, IC) / 10))
                    IF (IG(M1, M2) .NE. IG(N1, N2)) GOTO 206
                  ENDIF
  207           CONTINUE
                IF (NCP .GT. 0) THEN
                  DO 210 I = 1, NCP
                    IF (IC .EQ. NCL(I)) GOTO 206
  210             CONTINUE
                ENDIF
                NCP = NCP + 1
                NCL(NCP) = IC
                ISE = SB(IC)
                DO 501 IS = 1, ISE
                  IF (IC .NE. 30) GOTO 220
                  DO 1304 I = 1, 7
                    DO 1303 J = 1, 7
                      IF (I .LT. 4 .AND. J .LT. 4) A(I, J) =
     1                                   A(I, J) - A(4, J)
                      GS(I, J) = 0.0
                      DO 1302 K = 1, 3
                        DO 1301 L = 1, 3
                          GS(I, J) = GS(I, J) + G(K, L)
     1                             * INC(K, I) * INC(L, J)
 1301                   CONTINUE
 1302                 CONTINUE
 1303               CONTINUE
 1304             CONTINUE
                  DO 3022 I = 1, 6
                    DO 3021 J = I, 7
                      O(I, J) = GS(I, I) * GS(J, J)
     1                        - GS(I, J) * GS(I, J)
                      IF (GS(I, I) .GT. GS(J, J)) THEN
                        NQ(I) = NQ(I) + 1
                        NQ(J) = NQ(J) - 1
                      ENDIF
                      O(J, I) = O(I, J)
 3021               CONTINUE
 3022             CONTINUE
                  DO 303 I = 1, 7
                    MQ(NQ(I)) = I
  303             CONTINUE
                  ZW1 = GS(MQ(1), MQ(1))
                  ZW2 = GS(MQ(2), MQ(2))
                  ZW3 = GS(MQ(3), MQ(3))
                  IF (IV(MQ(1), MQ(2)) .EQ. MQ(3))
     1                ZW3 = GS(MQ(4), MQ(4))
                  DO 304 I = 1, 5
                    ID = MQ(I)
                    IF (ZW1 .LT. GS(ID, ID)) GOTO 304
                    DO 305 J = I, 6
                      JD = MQ(J)
                      IF (J .EQ. I .OR. ZW2 .LT. GS(JD, JD)) GOTO 305
                      DO 306 K = J, 7
                        KD = MQ(K)
                        IF (K .EQ. J .OR. ZW3 .LT. GS(KD, KD) .OR.
     1                      KD .EQ. IV(ID, JD)) GOTO 306
                        IF (O(ID, JD) + O(JD, KD)
     1                                + O(ID, KD) .GE. ZW4) THEN
                          KJ(1) = ID
                          KJ(2) = JD
                          KJ(3) = KD
                          ZW4   = O(ID, JD) + O(ID, KD) + O(JD, KD)
                        ENDIF
  306                 CONTINUE
  305               CONTINUE
  304             CONTINUE
                  DO 3073 M = 1, 3
                    DO 3072 L = 1, 3
                      GV(M, L) = GS(KJ(M), KJ(L))
                      GN(M, L) = 0.0
                      IF (GV(M, L) .NE. 0.0) GN(M, L) =
     1                    GV(M, L) / ABS(GV(M, L))
                      DO 3071 J = 1, 3
                        AV(L, M) = AV(L, M) + A(L, J) * INC(J, KJ(M))
 3071                 CONTINUE
 3072               CONTINUE
 3073             CONTINUE
                  N = INT(14.5 + GN(1, 2) + 3.0 * GN(1, 3)
     1              + 9.0 * GN(2, 3))
                  IF (GV(1, 1) .EQ. GV(2, 2) .AND.
     1                ABS(GV(2, 3)) .GT. ABS(GV(1, 3))) IZ = IZ + 1
                  IF (GV(3, 3) .EQ. GV(2, 2) .AND.
     1                ABS(GV(1, 3)) .GT. ABS(GV(1, 2))) IZ = IZ + 2
                  IF (GV(1, 1) .EQ. GV(3, 3) .AND.
     1                ABS(GV(2, 3)) .GT. ABS(GV(1, 2))) IZ = IZ + 4
                  DO 3103 I = 1, 3
                    DO 3102 J = 1, 3
                      E(I, J) = 0.0
                      DO 3101 K = 1, 3
                        E(I, J) = E(I, J) + TR(I, K, 23 + Q(N))
     1                           * TR(K, J, NVV(IZ))
 3101                 CONTINUE
 3102               CONTINUE
 3103             CONTINUE
                  GOTO 380
  220             IF (IS .LE. 1) THEN
                    DO 222 I = 1, 4
                      DO 225 J = 1, 4
                        GV(J, I) = 0.0
                        E(J, I)  = 0.0
  225                 CONTINUE
                      E(NL(I), I) = 1.0
  222               CONTINUE
                    DO 2214 I = 1, 4
                      DO 2213 J = 1, 4
                        A(I, J) = AD(I, 1) * E(1, J)
     1                          + AD(I, 2) * E(2, J)
     1                          + AD(I, 3) * E(3, J)
     3                          + AD(I, 4) * E(4, J)
                        DO 2212 K = 1, 4
                          DO 2211 L = 1, 4
                            GV(I, J) = GV(I, J)
     1                               + G(K, L) * E(L, J) * E(K, I)
 2211                     CONTINUE
 2212                   CONTINUE
 2213                 CONTINUE
 2214               CONTINUE
                    DO 2232 I = 1, 3
                      DO 2231 J = 1, 3
                        GN(I, J) = GV(I, J)
                        A(I, J) = A(I, J) - A(4, J)
 2231                 CONTINUE
 2232               CONTINUE
                  ENDIF
                  ISYS = SKI(8, IC) / 10
                  NBR  = SKI(8, IC) - 10 * ISYS
                  N    = SKI(7, IC)
                  IF (IS .NE. 1) THEN
                    DO 2512 I = 1, 3
                      DO 2511 J = 1, 3
                        A(I, J)  = AW(I, J)
                        GN(I, J) = GW(I, J)
 2511                 CONTINUE
 2512               CONTINUE
                    N = TT(IS - 1, IK) / 100
                    ISYS = (TT(IS - 1, IK) - 100 * N) / 10
                    NBR  = TT(IS - 1, IK) - 100 * N - 10 * ISYS
                 ENDIF
                 ZW1 = 1.0 - 0.83333333 * FLOAT(N / 54)
                 DO 2244 I = 1, 3
                   DO 2243 J = 1, 3
                     AV(I, J) = 0.0
                     GV(I, J) = 0.0
                     DO 2242 K = 1, 3
                       AV(I, J) = AV(I, J)
     1                          + A(I, K) * ZW1 * TR(K, J, N)
                       DO 2241 L = 1, 3
                         GV(I, J) = GV(I, J) + ZW1 * ZW1 * GN(K, L) *
     1                              TR(L, J, N) * TR(K, I, N)
 2241                  CONTINUE
 2242                CONTINUE
 2243              CONTINUE
 2244            CONTINUE
                 IZ = 1
                 IF (ISYS .LT. 3) THEN
                   GOTO 324
                 ELSE IF (ISYS .GT. 3) THEN
                   GOTO 400
                 ENDIF
                 IF (GV(1, 1) .GT. GV(2, 2)) IZ = IZ + 1
                 IF (GV(1, 1) .GT. GV(3, 3)) IZ = IZ + 2
                 IF (GV(2, 2) .GT. GV(3, 3)) IZ = IZ + 4
                 DO 3432 L = 1, 3
                   DO 3431 M = 1, 3
                     E(L, M) = TR(L, M, MVV(IZ))
3431               CONTINUE
3432             CONTINUE
                 IF (NBR .GT. 1 .AND. NBR .LT. 5) NBR = 4 - IZ / 3
                  GOTO 380
  324             ZW = GV(1, 1) + GV(3, 3) - GV(1, 3)
     1               * SIGN(2.0, GV(1, 3))
                  IF (ZW .LT. GV(1, 1)) IZ = IZ + 1
                  IF (ZW .LT. GV(3, 3)) IZ = IZ + 2
                  IF (GV(3, 3) .LT. GV(1, 1)) IZ = IZ + 4
                  IF (NBR .EQ. 6) NBR = 2 * (MOD(IZ + 2, 4)
     1                                + (IZ / 6) * (6 / IZ))
                  DO 3232 I = 1, 3
                    DO 3231 J = 1, 3
                      E(I, J) = TR(I, J, LVV(IZ))
                      IF (I .NE. 3) E(I, J) = - E(I, J)
     1                                      * SIGN(1.0, GV(1, 3))
 3231               CONTINUE
 3232             CONTINUE
  380             DO 3822 I = 1, 3
                    DO 3821 J = 1, 3
                      A(I, J)  = AV(I, J)
                      GN(I, J) = GV(I, J)
 3821               CONTINUE
 3822             CONTINUE
                  DO 3814 I = 1, 3
                    DO 3813 J = 1, 3
                      AV(I, J) = A(I, 1) * E(1, J) + A(I, 2) * E(2, J)
     1                         + A(I, 3) * E(3, J)
                      GV(I, J) = 0.0
                      DO 3812 K = 1, 3
                        DO 3811 L = 1, 3
                          GV(I, J) = GV(I, J)
     1                             + GN(K, L) * E(L, J) * E(K, I)
 3811                   CONTINUE
 3812                 CONTINUE
 3813               CONTINUE
 3814             CONTINUE
                  IF (ISYS .NE. 2 .OR. GV(1, 3) .LE. 0.0) GOTO 400
                  DO 325 I = 1, 3
                    AV(I, 3) = - AV(I, 3)
  325             CONTINUE
                  GV(1, 3) = - GV(1, 3)
                  GV(3, 1) =   GV(1, 3)
  400             DO 4042 I = 1, 2
                    II = I + 1
                    DO 4041 J = II, 3
                      N = 6 - I - J
                      A(N, N) = AV(I, I) * AV(J, J)
     1                        - AV(I, J) * AV(J, I)
                      A(J, I) = AV(N, I) * AV(J, N)
     1                        - AV(N, N) * AV(J, I)
                      A(I, J) = AV(N, J) * AV(I, N)
     1                        - AV(N, N) * AV(I, J)
 4041               CONTINUE
 4042             CONTINUE
                  ZW1 = A(1, 1) * AV(1, 1) + A(1, 2) * AV(2, 1)
     1                + A(1, 3) * AV(3, 1)
                  DO 401 I = 1, 3
                    DO 406 J = 1, 3
                      AV(I, J) = AV(I, J) * SIGN(1.0, ZW1)
                      IF (IS .EQ. 1) AW(I, J) = AV(I, J)
                      IF (IS .EQ. 1) GW(I, J) = GV(I, J)
                      A(J, I) = A(J, I) / ABS(ZW1)
  406               CONTINUE
                    AC(I) = SQRT(GV(I, I))
                    J = I + 1 - 3 * (I / 3)
                    ZW = GV(I, J) / SQRT(GV(I, I) * GV(J, J))
                    AC(9 - I - J) = 57.29578
     1                            * ATAN2(SQRT(1.0 - ZW * ZW), ZW)
  401             CONTINUE
                  IF (ISYS .NE. 2) GOTO 407
                  XM = GV(1, 1) / GV(2, 2)
                  YM = GV(3, 3) / GV(2, 2)
                  ZM = XM + YM + 2.0 * GV(1, 3) / GV(2, 2)
                  IF (NBR .EQ. 1) GOTO 407
                  ZW = GV(3, 3) + FLOAT(NBR / 4) * (GV(1, 1) - GV(3, 3))
     1               + FLOAT(NBR / 6) * (GV(3, 3) + GV(1, 3) * 2.0)
                  ZM = (GV(1, 1) + FLOAT((NBR / 4) - (NBR / 6)) *
     1                 (GV(3, 3) - GV(1, 1))) / ZW
                  YM = GV(2, 2) / ZW
                  XM = ((GV(1, 1) + GV(3, 3) + GV(1, 3) * 2.0) *
     1                 FLOAT((NBR / 2) - (NBR / 4)) *
     2                 FLOAT(1 - (NBR / 6))
     2               + FLOAT(NBR / 6) * GV(3, 3)) / ZW
  407             IF (IS .EQ. 1) THEN
 1407               CALL PLA015 (0, 39)
                    CALL PLA013 (1, 1)
                    CALL GEN020 (1, IGGT, 1, 80)
                    IF (IGGT(1:4) .EQ. 'PLOT') THEN
                      GOTO 1407
                    ELSE IF (IGGT(1:4) .EQ. 'EXIT' .OR.
     1                       IGGT(1:1) .EQ. 'N') THEN
                      CALL GEN038 (IGGT, 1, 80)
                      GOTO 5000
                    ENDIF
                    CALL PLA269 (0)
                    CALL GGIP (HORS, VERT, 0.0, 1)
                    WRITE (PRBUF, 99993) NCP, IC, IST, Y(ISYS), HT(NBR)
                    WRITE (LU, 99987) PRBUF(1:80)
                    VRT = VERT - 0.7
                    CALL GGIP20 (0.0, PRBUF, 80, 0.40, 5 + IGBL(68),
     1                           2, 0.2, VRT)
                    VRT = VRT - 0.2
                  ENDIF
                  ISJ = IS - 1
                  IF (IS .NE. 1) THEN
                    WRITE (PRBUF, 99991) ISJ, Y(ISYS), HT(NBR)
                    WRITE (LU, 99988) PRBUF(1:80)
                    VRT = VRT - 0.7
                    CALL GGIP20 (0.0, PRBUF, 80, 0.40, 3, 2, 0.2, VRT)
                  ENDIF
                  IF (ISYS .EQ. 2) THEN
                    WRITE (PRBUF, 99989) XM, YM, ZM
                    WRITE (LU, 99988) PRBUF(1:80)
                  ENDIF
                  IF ((ISYS .NE. 1 .AND. ISYS .NE. 5 .AND.
     1              (ABS(AC(4) - 90.0) .GE. AAC .OR.
     2               ABS(AC(6) - 90.0) .GE. AAC)) .OR.
     3               (ISYS .GT. 2 .AND. ABS(AC(5) - 90.0) .GE. AAC) .OR.
     4              (ISYS .EQ. 5 .AND. (ABS(AC(6) - 120.0) .GE. AAC .OR.
     5              ABS(AC(4) - 90.0) .GE. AAC)) .OR. (ISYS .GT. 3 .AND.
     6              ABS(AC(1) - AC(2)) .GE. ACL) .OR. (ISYS .EQ. 6 .AND.
     7              (ABS(AC(1) - AC(3)) .GE. ACL .OR.
     8               ABS(AC(2) - AC(3)) .GE. ACL))) GOTO 503
  505             WRITE (PRBUF, 99996) (AC(I), I = 1, 3)
                  VRT = VRT - 0.7
                  CALL GGIP20 (0.0, PRBUF, 80, 0.40, 1, 2, 0.2, VRT)
                  WRITE (LU, 99988) PRBUF(1:80)
                  WRITE (PRBUF, 99995) (AC(I), I = 4, 6)
                  VRT = VRT - 0.55
                  CALL GGIP20 (0.0, PRBUF, 80, 0.40, 1, 2, 0.2, VRT)
                  WRITE (LU, 99987) PRBUF(1:80)
                  WRITE (PRBUF, 99994)
                  VRT = VRT - 0.7
                  CALL GGIP20 (0.0, PRBUF, 80, 0.40, 5 + IGBL(68),
     1                         2, 0.2, VRT)
                  WRITE (LU, 99988) PRBUF(1:80)
                  DO 410 I = 1, 3
                    WRITE (PRBUF, 99992) (GV(I, J), J = 1, 3),
     1                    (AV(I, K), K = 1, 3), (A(I, L), L = 1, 3)
                    WRITE (LU, 99987) PRBUF(1:80)
                    VRT = VRT - 0.55
                    CALL GGIP20 (0.0, PRBUF, 80, 0.40, 1, 2, 0.2, VRT)
  410             CONTINUE
                  GOTO 504
  503             WRITE (PRBUF, 99990) (AC(I), I = 1, 6)
                  VRT = VRT - 0.40
                  CALL GGIP20 (0.0, PRBUF, 80, 0.30, 2, 2, 0.2, VRT)
                  WRITE (LU, 99988) PRBUF(1:80)
                  IF (INO .EQ. 1) GOTO 505
  504             DO 502 I = 1, 13
                    IF (IS .EQ. 1 .AND. 10 * ISYS + NBR .EQ. IDT(I))
     1                  IK = I
  502             CONTINUE
                  IF (IK .EQ. 7 .AND. IC .EQ. 6) IK = 14
  501           CONTINUE
  206         CONTINUE
  205       CONTINUE
 2031     CONTINUE
 2032   CONTINUE
 2033 CONTINUE
      CALL PLA015 (0, 39)
      CALL PLA013 (1, 1)
 5000 RETURN
99999 FORMAT ('Delaunay Cell Reduction [Tol-Axis =', F5.2,
     1        ', Tol-Angle =', F5.2, ']')
99998 FORMAT ('See: H. Zimmermann & H. Burzlaff, ',
     1        'Z. fur Krist. (1985) 170, 241-246')
99997 FORMAT ( 'INPUT CELL:   ', A, 6F9.3)
99996 FORMAT (9X, 'a =', F9.3, 11X, 'b =', F9.3, 11X, 'c =', F9.3)
99995 FORMAT ( 5X, 'alpha =', F9.3, 8X, 'beta =', F9.3, 7X,
     1       'gamma =', F9.3)
99994 FORMAT (7X, 'Metric Tensor', 12X, 'Transf.-Matrix', 6X,
     1        'Inverse Matrix')
99993 FORMAT (2X, ' Proposal', I3, '   Delaunay Case',
     1        I3, 4X, 'Cycle', I3, 6X, 'Lattice Type: ', 2A)
99992 FORMAT (3(F9.2), 2X, 3(F6.2), 2X, 3(F6.2))
99991 FORMAT (4X, 'Subgroup Cell No.', I3, 24X, 'Lattice Type: ', 2A)
99990 FORMAT (5X, 'Out of Range [', 6F9.3, ']')
99989 FORMAT (' Reduced Monoclinic Lattice Coordinates:',
     1        3X, 'xm = ', F6.3, 1X, 'ym = ', F6.3, 1X, 'zm = ', F6.3)
99988 FORMAT (/, A)
99987 FORMAT (A)
      END
      SUBROUTINE PLA179
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16,
     1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NPVD=40000000,
     2 NP22=256,NP23=18000,NP25=99,NP29=63,NP38=125,NP39=30,NP41=200,
     3 NP45=2048,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /Q/ ICL, IFL(NP17)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON // JNSC(2, NP23), VOID(NPVD)
      COMMON /ISCR/ RIK(3, 3), UKL(3, 3), INSCR(3)
      COMMON /FNAME/ KNM(8), KXT, KNM16
      COMMON /NAMES/ NAME(8), EXTENS, PROGNM, FNLU1, FNLU16, RDTYPE
      CHARACTER NAME*80, EXTENS*9, PROGNM*28, FNLU1*80, FNLU16*80,
     1          RDTYPE*7
      COMMON /SFCLC/ NATO, NNG(3), NGRID
      COMMON /PL138/ IHKLS(5, 48), PHIS(48), NSYM, NSYMH, MHK, MPH,
     1  ICNTR, IND1, IND2, IND3
      DIMENSION ORO(3, 3)
      INTEGER HMAX
      COMMON /PAGENM/ PAGET, PAGEIND(25)
      CHARACTER PAGET*8, PAGEIND*8
      NSYMH = IPR(255)
      ICNTR = IPR(257)
      AN0   = 0.0
      NATO  = 0
      IND1  = 1
      IND2  = 2
      IND3  = 3
      CALL PLA130 (NATO, 0)
      IF (NATO .LT. 0) THEN
        IPR(1) = 1
        IPR(2) = 42
        GOTO 150
      ENDIF
      IF (IPR(210) .EQ. -2) THEN
        IF (IGBL(29) .EQ. 1) THEN
          IPR(1) = 1
          IPR(2) = 44
          GOTO 150
        ENDIF
        IF (IPR(16) .EQ. 0) THEN
          CALL GEN044 (PAR(241), ORO)
          CALL GEN021 (RIK, 0)
          WRITE (LU6, 99999) NAME(4)(1:KNM(4))
          CALL GEN108 (LU16, 0)
   10     READ (LU16, 99992, END = 30)
     1          IH, IK, IL, (V2(I), V3(I), I = 1, 3)
          IF (IH .EQ. 0 .AND. IK .EQ. 0 .AND. IL .EQ. 0) GOTO 30
          DO 20 I = 1, 3
            V4(I) = PAR(134 + I) * V2(I)
            V5(I) = PAR(134 + I) * V3(I)
   20     CONTINUE
          CALL GEN002 (2, ORO, V4, V2, DUM)
          CALL GEN002 (2, ORO, V5, V3, DUM)
          XX  = V3(1) - V2(1)
          YY  = V3(2) - V2(2)
          ZZ  = V3(3) - V2(3)
          XSQ = XX**2
          YSQ = YY**2
          ZSQ = ZZ**2
          RIK(1, 1) = RIK(1, 1) + YSQ + ZSQ
          RIK(1, 2) = RIK(1, 2) - XX  * YY
          RIK(1, 3) = RIK(1, 3) - XX  * ZZ
          RIK(2, 2) = RIK(2, 2) + ZSQ + XSQ
          RIK(2, 3) = RIK(2, 3) - YY  * ZZ
          RIK(3, 3) = RIK(3, 3) + XSQ + YSQ
          GOTO 10
   30     CALL GEN024 (RIK, UKL, V8, DUMV)
          QM(1, 1) = DUMV(1, 2)
          QM(1, 2) = DUMV(2, 2)
          QM(1, 3) = DUMV(3, 2)
          QM(2, 1) = DUMV(1, 3)
          QM(2, 2) = DUMV(2, 3)
          QM(2, 3) = DUMV(3, 3)
          QM(3, 1) = DUMV(1, 1)
          QM(3, 2) = DUMV(2, 1)
          QM(3, 3) = DUMV(3, 1)
          CALL GEN004 (QM, ORO, RIK)
        ELSE
          DO 40 I = 1, 9
            J        = MOD (I - 1, 3) + 1
            K        = ((I - 1) / 3)  + 1
            QM(J, K) = PAR(180 + I)
   40     CONTINUE
          CALL GEN003 (QM, RIK, DET, 0)
        ENDIF
      ENDIF
      NREF  = 0
      SOMXO = 0.0
      SOMXC = 0.0
      IF (IPR(259) .EQ. 5 .OR. IPR(259) .EQ. 6) THEN
        IHEXL = 1
      ELSE
        IHEXL = 0
      ENDIF
      CALL GEN108 (LU9, 0)
      HMAX = -999
      KMAX = -999
      LMAX = -999
      CALL PLA290 (0)
      IEND = -1
   50 CALL PLA133 (IH, IK, IL, IHT, IKT, ILT, XOBS, SIGI,
     1  UCINT, ACALS, BCALS, ABSCOR, IEND)
      IF (IEND .EQ. 1) THEN
        PAR(166) = ASIN(SQRT(PAR(166)) * PAR(17)) * GL(5)
        IF (IPR(259) .EQ. 4) THEN
          HMAX = MAX (HMAX, KMAX)
          KMAX = HMAX
        ELSE IF (IPR(259) .EQ. 7) THEN
          HMAX = MAX (HMAX, KMAX, LMAX)
          KMAX = HMAX
          LMAX = HMAX
        ENDIF
        IF (NREF .EQ. 0) THEN
          WRITE (LU6, 99998)
          IPR(210) = 0
          GOTO 150
        ELSE
          GOTO 70
        ENDIF
      ENDIF
      HMAX = MAX (HMAX, IABS(IHT))
      KMAX = MAX (KMAX, IABS(IKT))
      LMAX = MAX (LMAX, IABS(ILT))
      IF (IHEXL .EQ. 1) THEN
        HMAX = MAX (KMAX, HMAX, IABS(IHT + IKT))
        KMAX = HMAX
      ENDIF
      IF (IPR(259) .EQ. 4) THEN
        HMAX = MAX (HMAX, KMAX)
        KMAX = HMAX
      ELSE IF (IPR(259) .EQ. 7) THEN
        HMAX = MAX (HMAX, KMAX, LMAX)
        KMAX = HMAX
        LMAX = HMAX
      ENDIF
      NREF = NREF + 1
      ACAL = 0.0
      BCAL = 0.0
      IF (IGBL(29) .EQ. -1) THEN
        IF (IPR(210) .EQ. -1) THEN
          ACAL = ACALS
          BCAL = BCALS
          XOBS = UCINT * ABSCOR
        ELSE IF (IPR(210) .EQ. -4) THEN
          IF (IPR(414) .EQ. 4) THEN
            ACAL = ACALS
            BCAL = BCALS
            XOBS = ACAL **2 + BCAL ** 2
          ENDIF
        ENDIF
      ENDIF
      CALL PLA131 (IHT, IKT, ILT, ACAL, BCAL, ACALA, BCALA, SNTHA)
      ACAL = ACAL + ACALA
      BCAL = BCAL + BCALA
      XCAL = ACAL ** 2 + BCAL ** 2
      IF (IPR(193) .EQ. 2) THEN
        IH2 = NINT (PAR(332) * IHT + PAR(333) * IKT + PAR(334) * ILT)
        IK2 = NINT (PAR(335) * IHT + PAR(336) * IKT + PAR(337) * ILT)
        IL2 = NINT (PAR(338) * IHT + PAR(339) * IKT + PAR(340) * ILT)
        ACL = 0.0
        BCL = 0.0
        CALL PLA131 (IH2, IK2, IL2, ACL, BCL, ACLA, BCLA, SNTHA)
        ACL = ACL + ACLA
        BCL = BCL + BCLA
        XCL = ACL ** 2 + BCL ** 2
        XCAL = (1.0 - PAR(341)) * XCAL + PAR(341) * XCL
      ENDIF
      IF (PAR(229) .LT. 99999.0) THEN
        SN2TH = 2 * SNTHA * SQRT(1.0 - SNTHA ** 2)
        XOBS = XOBS *
     1    (1.0 + 0.001 * PAR(229) * XCAL * PAR(17)**3 / SN2TH) ** 0.25
      ENDIF
      IF (XOBS .GT. 2 * SIGI) THEN
        SOMXO = SOMXO + XOBS
        SOMXC = SOMXC + XCAL
      ENDIF
      IF (IPR(210) .EQ. -2) THEN
        SUMT = 0
        DO 60 I = 1, 3
          V4(I) = PAR(134 + I) * V2(I)
          V5(I) = PAR(134 + I) * V3(I)
          SUMT  = SUMT + ABS(V2(I)) + ABS(V3(I))
   60   CONTINUE
        TPRIM = IH * V4(1) + IK * V4(2) + IL * V4(3)
        TDIFF = IH * V5(1) + IK * V5(2) + IL * V5(3)
        THHKL = ASIN(SNTHA) * GL(5)
        CALL GEN002 (2, RIK, V4, V2, DUM)
        CALL GEN002 (2, RIK, V5, V3, DUM)
        THETA = 90.0 - GEN027 (V2, V3, GL(5)) / 2.0
        CALL PLA291 (TPRIM, TDIFF, THETA, THHKL, ITEST)
        IF (ITEST .NE. 0) THEN
          IPR(210) = 0
          GOTO 150
        ENDIF
        IF (SUMT .LT. 0.001) THEN
          WRITE (LU6, 99997)
          IPR(210) = 0
          GOTO 150
        ENDIF
        PMU   = 90.0 - ACOS(V2(3)) * GL(5)
        SMU   = 90.0 - ACOS(V3(3)) * GL(5)
        VXY   = SQRT(V2(1)**2     + V2(2)**2)
        PHIP  = ACOS(V2(1) / VXY) * GL(5)
        IF (V2(2) .LT. 0.0) PHIP = 360.0 - PHIP
        PHIP  = MOD(PHIP, 360.0)
        VXY   = SQRT(V3(1)**2     + V3(2)**2)
        PHISE = ACOS(V3(1) / VXY) * GL(5)
        IF (V3(2) .LT. 0.0) PHISE = 360.0 - PHISE
        PHISE = MOD(PHISE, 360.0)
      ENDIF
      IF (ACAL .NE. 0.0 .AND. BCAL .NE. 0) THEN
        PCAL = ATAN2 (BCAL, ACAL) * GL(5)
      ELSE
        PCAL = 0.0
      ENDIF
      WRITE (LU9) IH, IK, IL, IHT, IKT, ILT, XOBS, XCAL, SIGI,
     1 PCAL, PMU, SMU, PHIP, PHISE, THETA
      GOTO 50
   70 IF (IPR(414) .EQ. 5 .AND. IPR(210) .EQ. -4) THEN
        SCF = 1.0
        SCF = 100.0 / (SOMXO * PAR(240))
      ELSE IF (IPR(414) .EQ. 4 .AND. IPR(210) .EQ. -4) THEN
        SCF = 1.0 / PAR(240)
      ELSE
        SCF = SOMXC / (SOMXO * PAR(240))
      ENDIF
      IF (IPR(210) .EQ. -2) THEN
        PAGET = 'DELABS'
        CALL PLA269 (0)
        WRITE (LU7, 99989)
        CALL PLA290 (-1)
      ENDIF
      CALL GEN108 (LU9,  0)
      CALL GEN108 (LU17, 0)
      FCLM = 0.0
      NR7  = 0
      DO 80 I = 1, NREF
        READ (LU9) IH, IK, IL, IHT, IKT, ILT, XOBS, XCAL, SIGI,
     1   PCAL, PMU, SMU, PHIP, PHISE, THETA
        XOBS = XOBS * SCF
        SIGI = SIGI * SCF
        XCAL = XCAL / PAR(240)
        IF (IPR(210) .EQ. -2) THEN
          WRITE (LU17, 99994) IH, IK, IL, XOBS, XCAL, SIGI, PMU, SMU,
     1                        PHIP, PHISE, THETA
        ELSE
          VOID(NR7 + 1) = IHT
          VOID(NR7 + 2) = IKT
          VOID(NR7 + 3) = ILT
          VOID(NR7 + 4) = XOBS * PAR(240)
          VOID(NR7 + 5) = XCAL * PAR(240)
          VOID(NR7 + 6) = SIGI * PAR(240)
          VOID(NR7 + 7) = PCAL
          FCLM          = MAX (FCLM, SQRT(XCAL * PAR(240)))
          NR7           = NR7  + 7
        ENDIF
   80 CONTINUE
      IF (IPR(210) .EQ. -2) THEN
        IF (IGBL(37) .GT. 0) THEN
          CALL PLA180
        ELSE
          WRITE (LU6, 99993)
          GOTO 150
        ENDIF
      ELSE IF (IPR(210) .EQ. -1 .OR. IPR(210) .EQ. -4) THEN
        SUM1     = 0.0
        SUM2     = 0.0
        SUM3     = 0.0
        SUM4     = 0.0
        IPR(411) = HMAX
        IPR(412) = KMAX
        IPR(413) = LMAX
        MPH      = 2 * HMAX + 1
        MPK      = 2 * KMAX + 1
        MPL      = 2 * LMAX + 1
        MHK      = MPH * MPK
        MHKL     = MPL * MHK
        MHKLH    = (MHKL - 1) / 2
        IADR     = NPVD - MHKLH
        IADR1    = NPVD - MHKL
        IF (IADR1 .LT. NR7) THEN
          WRITE (LU6, 99985)
          GOTO 150
        ENDIF
        DO 90 I = 1, MHKL
          VOID(IADR1 + I) = - 1.0
   90   CONTINUE
        NR7 = 0
        DO 100 I = 1, NREF
          IHT  = NINT(VOID(NR7 + 1))
          IKT  = NINT(VOID(NR7 + 2))
          ILT  = NINT(VOID(NR7 + 3))
          IHKL = ILT * MHK + IKT * MPH + IHT
          N = NINT (VOID(IADR + IHKL))
          IF (N .LT. 0) THEN
            VOID(IADR + IHKL) = I
          ELSE
            XOBS1 = VOID((N - 1) * 7 + 4)
            SIGI1 = VOID((N - 1) * 7 + 6)
            IF (SIGI1 .GT. 0.0) THEN
              WGTI1 = 1.0 / SIGI1**2
            ELSE
              WGTI1 = 1.0
            ENDIF
            XOBS2 = VOID(NR7 + 4)
            SIGI2 = VOID(NR7 + 6)
            IF (SIGI2 .GT. 0.0) THEN
              WGTI2 = 1.0 / SIGI2**2
            ELSE
              WGTI2 = 1.0
            ENDIF
            WGTIS = WGTI1 + WGTI2
            VOID((N - 1) * 7 + 4) =
     1           (WGTI1 * XOBS1 + WGTI2 * XOBS2) / WGTIS
            VOID((N - 1) * 7 + 6) = 1.0 / SQRT(WGTIS)
          ENDIF
          NR7  = NR7 + 7
  100   CONTINUE
        IF (IPR(210) .EQ. -1) THEN
          NSYMC = NSYMH * ICNTR
        ELSE
          NSYMC = NSYMH * 2
        ENDIF
        IF (NSYMC .GT. 1) THEN
          DO 120 I = 1, MHKL
            J = MHKL + 1 - I
            K = NINT(VOID(IADR1 + J))
            IF (K .GT. 0) THEN
              VOID(IADR1 + J) = -1
              IHT   = NINT(VOID((K - 1) * 7 + 1))
              IKT   = NINT(VOID((K - 1) * 7 + 2))
              ILT   = NINT(VOID((K - 1) * 7 + 3))
              XOBS  =      VOID((K - 1) * 7 + 4)
              SIGI  =      VOID((K - 1) * 7 + 6)
              PCAL  =      VOID((K - 1) * 7 + 7)
              IHKL0 = ILT * MHK + IKT * MPH  + IHT
              IHKLN = IHKL0
              PCALN = PCAL
              IHTN  = IHT
              IKTN  = IKT
              ILTN  = ILT
              IF (SIGI .NE. 0.0) THEN
                SUMT  = XOBS / SIGI**2
                SUMN  = 1.0  / SIGI**2
              ELSE
                SUMT = XOBS
                SUMN = 1.0
              ENDIF
              DO 110 L = 2, NSYMC
                XJX(1) = IHT
                XJX(2) = IKT
                XJX(3) = ILT
                XJX(4) = PCAL
                IF (L .GT. NSYMH) THEN
                  NS = L - NSYMH
                  IS = -1
                ELSE
                  NS = L
                  IS = 1
                ENDIF
                CALL SGSM (ICL, NS, XJX, LU7, 5, IERR)
                IH   = NINT(XJX(7))
                IK   = NINT(XJX(8))
                IL   = NINT(XJX(9))
                IHKL = (IL * MHK + IK * MPH  + IH) * IS
                IF (IHKL .GT. IHKLN) THEN
                  IHKLN = IHKL
                  IHTN  = IH
                  IKTN  = IK
                  ILTN  = IL
                  PCALN = XJX(10)
                ENDIF
                IF (IHKL .NE. IHKL0) THEN
                  NR = NINT(VOID(IADR + IHKL))
                  IF (NR .GT. 0) THEN
                    XOBS = VOID((NR - 1) * 7 + 4)
                    SIGI = VOID((NR - 1) * 7 + 6)
                    IF (SIGI .NE. 0.0) THEN
                      WGHT = 1.0 / SIGI**2
                    ELSE
                      WGHT = 1.0
                    ENDIF
                    SUMT = SUMT + XOBS * WGHT
                    SUMN = SUMN + WGHT
                    VOID(IADR + IHKL) = - 1.0
                  ENDIF
                ENDIF
  110         CONTINUE
              VOID(IADR + IHKLN) = K
              NR = (K - 1) * 7
              VOID(NR + 1) = IHTN
              VOID(NR + 2) = IKTN
              VOID(NR + 3) = ILTN
              VOID(NR + 4) = SUMT / SUMN
              VOID(NR + 6) = 1.0  / SQRT(SUMN)
              VOID(NR + 7) = PCALN
            ENDIF
  120     CONTINUE
        ENDIF
        FCLS = 1.0
        IF (FCLM .LT. 250.0) FCLS = 100.0
        IF (IPR(210) .EQ. -1) THEN
          WRITE (LU17, 99995) DATANM, JID(1: 50), FCLM, PAR(157),
     1                        1.0 / (2.0 * PAR(287))
          NSYM   = IPR(48)
          XJX(4) = 0.0
          XJX(5) = 0.0
          XJX(6) = 0.0
          DO 130 K = 1, NSYM
            ISYM = K
            CALL SGSM (ICL, ISYM, XJX, 0, 20, IERR)
            CALL GEN020 (-1, ICL, 1, 30)
            WRITE (LU17, 99991) ICL(1:30)
  130     CONTINUE
          WRITE (LU17, 99988) (PAR(K), K = 101, 106), 1.0 / FCLS
        ENDIF
        NRF  = 0
        NRF1 = 0
        CALL GEN108 (LU9, 0)
        DO 140 I = 1, MHKL
          NR0 = NINT(VOID(IADR1 + I))
          IF (NR0 .GT. 0) THEN
            IHT  = NINT(VOID((NR0 - 1) * 7 + 1))
            IKT  = NINT(VOID((NR0 - 1) * 7 + 2))
            ILT  = NINT(VOID((NR0 - 1) * 7 + 3))
            XCAL =      VOID((NR0 - 1) * 7 + 5)
            IF (IPR(408) .LE. 0) THEN
              XOBS =    VOID((NR0 - 1) * 7 + 4)
              SIGI =    VOID((NR0 - 1) * 7 + 6)
            ELSE
              XOBS = XCAL
              SIGI = SQRT (XOBS)
            ENDIF
            PCAL = VOID((NR0 - 1) * 7 + 7)
            CALL PLA139 (IHT, IKT, ILT, IEXT, IASM)
            IF (IEXT .NE. 0) GOTO 140
            NRF1 = NRF1 + 1
            IF (XOBS .GT. 2 * SIGI) THEN
              SUM1 = SUM1 + ABS(SQRT(XOBS) - SQRT(XCAL))
              SUM2 = SUM2 + SQRT(XOBS)
              NRF  = NRF  + 1
            ENDIF
            PXX  = (MAX(0.0, XOBS) + 2.0 * XCAL) / 3.0
            SGIK = SIGI**2 + (PAR(227) * PXX)**2 + PAR(228) * PXX
            SUM3 = SUM3 + ((XOBS - XCAL) ** 2) / SGIK
            SUM4 = SUM4 + XOBS ** 2 / SGIK
            STHL = SQRT(GEN095 (PAR(191), IHT, IKT, ILT))
            IF (IPR(210) .EQ. -1) THEN
              WRITE (LU17, 99987) IHT, IKT, ILT, XCAL * FCLS,
     1          XOBS * FCLS, SIGI * FCLS, STHL
            ELSE
              FOBS = SQRT(MAX(0.0, XOBS))
              FCAL = SQRT(MAX(0.0, XCAL))
              IF (FOBS .GT. 0.0) THEN
                IF (FCAL / FOBS .GT. PAR(270) .OR. IPR(414) .EQ. 5) THEN
                  IF (ICNTR .EQ. 2) THEN
                    SINA = 0.0
                    IF (ABS(PCAL) .LT. 90.0) THEN
                      COSA = 1.0
                    ELSE
                      COSA = -1.0
                    ENDIF
                  ELSE
                    PHI = PCAL / GL(5)
                    SINA = SIN (PHI)
                    COSA = COS (PHI)
                  ENDIF
                  IF (IPR(414) .EQ. 5) THEN
                    AN0  = FOBS **2
                    COSA = 1.0
                    SINA = 0.0
                  ELSE IF (IPR(414) .EQ. 1) THEN
                    AN0 = FOBS
                  ELSE IF (IPR(414) .EQ. 2) THEN
                    AN0 = 2 * FOBS - FCAL
                  ELSE IF (IPR(414) .EQ. 3) THEN
                    AN0 = FOBS - FCAL
                  ELSE IF (IPR(414) .EQ. 4) THEN
                    AN0 = FOBS
                  ENDIF
                  AI0 = AN0 * COSA
                  BI0 = AN0 * SINA
                  IF (AI0 .NE. 0.0 .OR. BI0 .NE. 0)
     1                WRITE (LU9) IHT, IKT, ILT, AI0, BI0,
     2                            XOBS / SIGI, STHL
                ENDIF
              ENDIF
            ENDIF
          ENDIF
  140   CONTINUE
        IF (IPR(210) .NE. -4 .AND. IPR(408) .LE. 0) THEN
          CALL PLA269 (3)
          WRITE (LU6, 99990)
          WRITE (LU7, 99990)
        ENDIF
        IF (IPR(414) .LT. 4) THEN
          N = 0
          IF (PAR(227) .GT. 0) THEN
            N = INDEX (RLWS(1)(2:80), '''')
            IF (N .GE. 2) WRITE (LU6, 99986) RLWS(1)(2:N)
          ENDIF
          WRITE (LU6, 99996) SUM1 / SUM2, NRF, SQRT(SUM3 / SUM4), NRF1,
     1      SQRT(SUM3 / (NREF - IPR(226)))
          IF (N .GE. 2) THEN
            CALL PLA269 (2)
            WRITE (LU7, 99986) RLWS(1)(2:N)
          ENDIF
          CALL PLA269 (6)
          WRITE (LU7, 99996) SUM1 / SUM2, NRF, SQRT(SUM3 / SUM4), NRF1,
     1      SQRT (SUM3 / (NREF - IPR(226)))
        ENDIF
      ENDIF
      IF (IPR(210) .EQ. -1) WRITE (LU17, '(1X)')
  150 CONTINUE
      RETURN
99999 FORMAT (/, ':: Reflection Data will be READ from File : ', A,
     1        '.hkl', /)
99998 FORMAT (/, ':: However, no reflection data found', /)
99997 FORMAT (/, ':: No Direction Cosines Found on Reflection File',/)
99996 FORMAT (':: R1   =', F7.3, ' for', I6,
     1        ' Refl. with I > 2 s(I) and', /,
     2        ':: wR2  =', F7.3, ' for', I6, ' reflections', /,
     3        ':: S    =', F7.3, /)
99995 FORMAT ('#', /, '# h,k,l, Fc-squared, Fo-squared,',
     1 ' sigma(Fo-squared) and status flag', /, '#', /,
     2 'data_', A, /, '_shelx_title '' ', A, ' ''', /,
     3 '_shelx_refln_list_code   4', /,
     4 '_shelx_F_calc_maximum', F10.2, /,
     5 '_exptl_crystal_F_000 ', F10.2, /,
     6 '_reflns_d_resolution_high', F10.4, //,
     6 'loop_', /,
     7 ' _symmetry_equiv_pos_as_xyz')
99994 FORMAT (3I4, 2F15.2, F10.2, 5F9.2)
99993 FORMAT (':: No Direction Cosines !!')
99992 FORMAT (3I4, 20X, 6F8.5)
99991 FORMAT (1X, A)
99990 FORMAT (/, ':: Structure Factor Calculation including SQUEEZE',
     1           ' Contribution', /)
99989 FORMAT ('Preparation for DELABS - Correction', /, 132('='), //,
     1        'Anisotropic Displacement Parameters converted to ',
     2        'the Isotropic Equivalent (When appropriate)', //,
     3        'Structure Factors calculated with the current Model-',
     4        'Parameters (i.e. x,y,z and U(eq))', //)
99988 FORMAT (/, '_cell_length_a', F9.5,/,
     1        '_cell_length_b', F9.4, /,
     2        '_cell_length_c', F9.4, /,
     3        '_cell_angle_alpha', F9.3, /,
     4        '_cell_angle_beta', F9.3, /,
     5        '_cell_angle_gamma', F9.3, //,
     6 '_shelx_F_squared_multiplier', F10.3, //,
     7 'loop_', /,
     8 ' _refln_index_h', /,
     9 ' _refln_index_k', /,
     * ' _refln_index_l', /,
     1 ' _refln_F_squared_calc', /,
     2 ' _refln_F_squared_meas', /,
     3 ' _refln_F_squared_sigma', /,
     4 ' _refln_observed_status', /,
     5 ' _refln_sint/lambda')
99987 FORMAT (3I4, 2F12.2, F10.2, ' o', F10.5)
99986 FORMAT (/, ':: ', A)
99985 FORMAT (/, 'NPVD too Small in PLA179', /)
      END
      SUBROUTINE PLA180
      PARAMETER (NP12=600,NP13=500,NP17=99,NPVD=40000000,NP23=18000,
     1 NP38=125,NP39=30,NP45=2048)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON // JNSC(2, NP23), VOID(NPVD - 15444), BUFF(11000),
     1 ANORM(44, 44), ATB(44), ROWJ(88), TERMS(44), VEC(44, 44),
     2 EIG(44), UM1(44), WORK(220), RDASH(44), SDASH(44)
      COMMON /REFL/ FC, FO, FM, PHI(2), MU(2), SINTH, COSTH
      COMMON /DRVR/ NCY, NSHAPE, NACOEF, NBCOEF, SFMU, ITCOR
      COMMON /SRES/ NUMREF, SUMRES, SUMFS, SUMRSQ, SUMFSQ
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /Q/ ICL, IFL(NP17)
      CHARACTER ICL*(NP45), IFL*7
      REAL MU, MUMIN, MUMAX, A(18)
      INTEGER NP(16)
      CHARACTER THCOR*3
      COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0
      COMMON /CGG11/ BCD, SBCD
      CHARACTER BCD*132, SBCD*132
      EXTERNAL PLA182
C *
C *            EMPIRICAL ABSORPTION CORRECTION ROUTINE
C *   THIS VERSION USES NON-LINEAR LEAST-SQUARES WITH UNIT WEIGHTS
C * Reference - WALKER, N. & STUART, D. (1983) Acta Cryst. A39, 158-166.
C *
C *               ADAPTED FOR INCLUSION IN PLATON
C *
      IGBL(23) = 16
      IF (IGBL(25) * IGBL(32) .EQ. 1) THEN
        BCD  = 'DELABS'//CHAR(0)
        CALL GGIP (HORS, VERT, 0.0, 1)
        CALL GGIP20 (0.0,  BCD, 7, 1.4, 4, 8, 10.6, VERT - 1.8)
        CALL GGIP20 (0.0,  BCD, 7, 1.4, 2, 8, 10.4, VERT - 1.9)
        CALL GGIP (0.0, 0.0, 0.0, 6)
      ENDIF
      ITCOR    = IPR(398)
      IF (ITCOR .GT. 0) THEN
        THCOR = 'YES'
      ELSE
        THCOR = 'NO '
      ENDIF
      WRITE (LU6, 99987) THCOR
      WRITE (LU6, 99984) (NINT(PAR(331 + I)), I = 1, 9), PAR(341)
      CALL PLA269 (0)
      WRITE (LU7, 99991)
      IF (IPR(16) .EQ. 0) THEN
        WRITE (LU6, 99988)
        WRITE (LU7, 99988)
      ENDIF
      NACOEF = 34
      NBCOEF = 10
      NCO    = NACOEF + NBCOEF
      MUMIN  = 100.0
      MUMAX  = -100.0
      NCYCLE = 4 + ITCOR
      NREF   = 0
      NTOT   = 0
      NCUTO  = 0
      NCUTC  = 0
      NLOW   = 0
      THMAX  = 0.0
      SFMU   = PAR(17) * 7.0
      NSHAPE = NACOEF
      FILTER = 0.00005
      FILSTA = 0.0001
      FILDEC = 0.00005
      FILEND = 0.0
      CALL GEN097 (NP, 1, 16, 0)
      CALL GEN074 (TERMS, 0.0, 1, NCO)
      CALL GEN108 (LU9, 0)
      CALL GEN108 (LU17, 0)
  50  READ (LU17, 99983, END = 70)
     1  IH, IK, IL, FOBS2, FCALC2, SIGF2, MU(1), MU(2),
     2  PHI(1), PHI(2), THETA, UCINT, ACALS, BCALS
      IF (IH .EQ. 0 .AND. IK .EQ. 0 .AND. IL .EQ. 0) GOTO 70
      FO    = SQRT(MAX(0.0, FOBS2))
      FC    = SQRT(FCALC2)
      SINTH = SIN(THETA / GL(5))
      COSTH = COS(THETA / GL(5))
      THMAX = MAX (THETA, THMAX)
      MUMIN = MIN (MUMIN, MU(1))
      MUMIN = MIN (MUMIN, MU(2))
      MUMAX = MAX (MUMAX, MU(1))
      MUMAX = MAX (MUMAX, MU(2))
      MU(1) = SIGN(SQRT(ABS(MU(1))) * SFMU, MU(1))
      MU(2) = SIGN(SQRT(ABS(MU(2))) * SFMU, MU(2))
      NREF  = NREF + 1
      IUSE  = 0
      IF (FOBS2 .GT. 0.0) THEN
        NTOT  = NTOT + 1
        DO 60 J = 1, 2
          JJ = (J - 1) * 4
          M  = 0
          IF (MU(J) .LT. 0.0) M = 8
          N        = INT(PHI(J) / 90.0 + 1.0)
          IOCT     = N + JJ + M
          NP(IOCT) = NP(IOCT) + 1
   60   CONTINUE
        IF (FOBS2 .LT. 1.5 * SIGF2) THEN
          NCUTO = NCUTO + 1
        ELSE
          IF (FCALC2 .LT. 1.5 * SIGF2) THEN
            NCUTC = NCUTC + 1
          ELSE
            IF (FC .GE. FO * 2.0) THEN
              NLOW = NLOW + 1
            ELSE
              IUSE = 1
            ENDIF
          ENDIF
        ENDIF
      ENDIF
      WRITE (LU9) IUSE, FC, FO, PHI, MU, SINTH, COSTH,
     1     IH, IK, IL, FOBS2, SIGF2, UCINT, ACALS, BCALS
      GOTO 50
   70 ENDFILE LU9
      DO 180 NCY = 1, NCYCLE
        NUMREF = 0
        SUMRES = 0.0
        SUMFS  = 0.0
        SUMRSQ = 0.0
        SUMFSQ = 0.0
        DO 40 I = 1, NCO
          ATB(I) = 0.0
          DO 30 J = 1, I
            ANORM(I, J) = 0.0
 30       CONTINUE
 40     CONTINUE
        CALL GEN108 (LU9, 0)
        IF (NCY .GT. 1 .AND. ITCOR .EQ. 1) NSHAPE = NCO
        DO 80 I = 1, NREF
          READ (LU9) IUSE, FC, FO, PHI, MU, SINTH, COSTH,
     1       IH, IK, IL, FOBS2, SIGF2
          IF (IUSE .EQ. 1) THEN
            CALL PLA181 (PS1, PS2, PS3)
            FM  = FO * PS1 * PS2 * PS3
            NUMREF = NUMREF + 1
            SUMFS  = SUMFS  + FC
            SUMFSQ = SUMFSQ + FC**2
            RESID  = ABS(FC - FM)
            SUMRES = SUMRES + RESID
            SUMRSQ = SUMRSQ + RESID**2
            DEL    = FC - FM
            DCONST = FO * PS3
            DO 310 J = 1, NACOEF
              JJ = J + NACOEF
              ROWJ(J) = DCONST * (ROWJ(J) * PS2 + PS1 * ROWJ(JJ))
  310       CONTINUE
            IF (ITCOR .EQ. 1 .AND. NCY .NE. 1) THEN
              NSTART = NACOEF + 1
              DCONST = FO * PS1 * PS2
              DO 320 J = NSTART, NSHAPE
                JJ = J + NACOEF
                ROWJ(J) = DCONST * ROWJ(JJ)
  320         CONTINUE
            ENDIF
            DO 340 K = 1, NSHAPE
              DO 350 L = 1, K
                ANORM(K, L) = ANORM(K, L) + ROWJ(K) * ROWJ(L)
 350          CONTINUE
              ATB(K) = ATB(K) + ROWJ(K) * DEL
 340        CONTINUE
          ENDIF
  80    CONTINUE
        IF (NREF .LT. 400) THEN
          WRITE (LU6, 99985)
          WRITE (LU7, 99985)
          GOTO 250
        ENDIF
        IF (NCY .EQ. 1) THEN
          NZERO = NREF - NTOT
          WRITE (LU6, 99992) NREF, NZERO, NCUTO, NCUTC, NLOW,
     1                       THMAX, MUMIN, MUMAX, NP
          WRITE (LU7, 99992) NREF, NZERO, NCUTO, NCUTC, NLOW,
     1                       THMAX, MUMIN, MUMAX, NP
          WRITE (LU6, 99990)
          WRITE (LU7, 99990)
          RM  = SUMRES / SUMFS
          RMS = SQRT(SUMRSQ / SUMFSQ)
          WRITE (LU6, 99986) NUMREF, RM , RMS
          WRITE (LU7, 99986) NUMREF, RM , RMS
        ENDIF
        AINFL  = FILSTA - (NCY - 1) * FILDEC
        IF (AINFL .LT. FILEND) AINFL = FILEND
        DO 90 I = 1, NSHAPE
          UM1(I) = 1.0
          IF (ANORM(I, I) .NE. 0.0) UM1(I) = 1.0 / SQRT(ANORM(I, I))
   90   CONTINUE
        DO 110 J = 1, NSHAPE
          UM1J = UM1(J)
          ATB(J) = ATB(J) * UM1J
          DO 100 K = 1, J
            ANORM(J, K) = ANORM(J, K) * UM1(K) * UM1J
  100     CONTINUE
  110   CONTINUE
        CALL GEN029 (ANORM, EIG, VEC, NSHAPE, NCO, NCO, WORK)
        DO 130 I = 1, NSHAPE
          SUM = 0.0
          DO 120 J = 1, NSHAPE
            SUM = SUM + VEC(J, I) * ATB(J)
  120     CONTINUE
          RDASH(I) = SUM
  130   CONTINUE
        DO 140 I = 1, NSHAPE
          SDASH(I) = 0.0
          IF (EIG(I) .GT. FILTER)
     1        SDASH(I) = RDASH(I) / (EIG(I) + AINFL)
  140   CONTINUE
        DO 160 J = 1, NSHAPE
          SUM = 0.0
          DO 150 I = 1, NSHAPE
            SUM = SUM + VEC(J, I) * SDASH(I)
  150     CONTINUE
          ATB(J) = SUM * UM1(J)
  160   CONTINUE
        DO 170 J = 1, NSHAPE
          TERMS(J) = TERMS(J) + ATB(J)
  170   CONTINUE
  180 CONTINUE
      AMIN   =  100.0
      AMAX   = -100.0
      NTOT   = 0
      ATOT   = 0.0
      NSET   = 1
      SFMUSQ = SFMU**2
      NUMREF = 0
      SUMRES = 0.0
      SUMFS  = 0.0
      SUMRSQ = 0.0
      SUMFSQ = 0.0
      CALL GEN108 (LU17, 0)
      CALL GEN108 (LU9, 0)
      DO 190 I = 1, NREF
        READ (LU9) IUSE, FC, FO, PHI, MU, SINTH, COSTH,
     1       IH, IK, IL, FOBS2, SIGF2, UCINT, ACALS, BCALS
        NTOT = NTOT + 1
        CALL PLA181 (PS1, PS2, PS3)
        ACR  = PS1 * PS2 * PS3
        ACR2 = ACR ** 2
        IF (ACR2 .LE. AMIN) THEN
          AMIN   = ACR2
          APHINP = PHI(1)
          APHINS = PHI(2)
          AMUNP  = MU(1) * ABS(MU(1)) / SFMUSQ
          AMUNS  = MU(2) * ABS(MU(2)) / SFMUSQ
          IHMN   = IH
          IKMN   = IK
          ILMN   = IL
        ENDIF
        IF (ACR2 .GE. AMAX) THEN
          AMAX   = ACR2
          APHIXP = PHI(1)
          APHIXS = PHI(2)
          AMUXP  = MU(1) * ABS(MU(1)) / SFMUSQ
          AMUXS  = MU(2) * ABS(MU(2)) / SFMUSQ
          IHMX   = IH
          IKMX   = IK
          ILMX   = IL
        ENDIF
        ATOT = ATOT + ACR2
        IF (IUSE .EQ. 1) THEN
          FM = FO * ACR
          NUMREF = NUMREF + 1
          SUMFS  = SUMFS  + FC
          SUMFSQ = SUMFSQ + FC**2
          RESID  = ABS(FC - FM)
          SUMRES = SUMRES + RESID
          SUMRSQ = SUMRSQ + RESID**2
        ENDIF
        FOBS2 = FOBS2 * ACR2
        SIGF2 = SIGF2 * ACR2
        WRITE (LU17, '(3I4, 2I8, I4, 48X, I8, 2F8.2, F8.4)')
     1    IH, IK, IL, NINT(FOBS2), NINT(SIGF2), NSET,
     2    NINT(UCINT), ACALS, BCALS, ACR2
  190 CONTINUE
      WRITE (LU17, '(1X)')
      WRITE (LU6, 99995)
      WRITE (LU7, 99995)
      RM  = SUMRES / SUMFS
      RMS = SQRT(SUMRSQ / SUMFSQ)
      WRITE (LU6, 99986) NUMREF, RM , RMS
      WRITE (LU7, 99986) NUMREF, RM , RMS
      AVER = ATOT / NTOT
      TVER = (AMIN / AMAX) ** 0.3333
      TMIN = TVER * (AMIN / AMAX)
      WRITE (LU7, 99994) NTOT, AMIN, IHMN, IKMN, ILMN, APHINP, AMUNP,
     1       APHINS, AMUNS, AMAX, IHMX, IKMX, ILMX, APHIXP, AMUXP,
     2       APHIXS, AMUXS, AVER, TMIN, TVER
      WRITE (LU7, 99993) (TERMS(J), J = 1, NSHAPE)
      WRITE (LU6, 99989) NTOT, TMIN, TVER
      MAXM   = INT(MUMAX / 5.0 + 0.8)
      MINM   = INT(MUMIN / 5.0 - 0.8)
      MRANGE = MAXM - MINM + 1
      MUS    = MAXM * 5
      MUF    = MINM * 5
      CALL PLA269 (0)
      DO 220 J = 1, 2
        NPS = (J - 1) * 180
        NPF = NPS + 170
        WRITE (LU7, 99996) NPS, NPF, MUF, MUS, (JJ, JJ = NPS, NPF, 10)
        DO 210 I = 1, MRANGE
          II  = (MAXM - (I - 1)) * 5
          RMU = II
          IF (II .GT. 0) RMU =  SQRT(RMU) * SFMU
          IF (II .LT. 0) RMU = -SQRT(ABS(RMU)) * SFMU
          MU(1) = RMU
          MU(2) = RMU
          DO 200 K = 1, 18
            KK = (K - 1) * 10 + NPS
            PHI(1) = KK
            PHI(2) = KK
            CALL PLA181 (PS1, PS2, PS3)
            A(K) = PS1 * PS2
  200     CONTINUE
          WRITE (LU7, 99999) II, A
  210   CONTINUE
  220 CONTINUE
  225 CALL PLA200 (7, 1, 0, 0)
      VERT = 25.0
      HORS = 4.0 * VERT / 3.0
      CALL GGIP20 (0.0, 'Absorption Surface A*(mu,phi)', 29, 0.7,
     1     1, 2, 6.0, 22.0)
      CALL GGIP20 (0.0, '+ .... Mu - Range .... -', 24, 0.4,
     1     1, 2, 9.0, 2.5)
      CALL GGIP20 (90.0, '0 .... Phi - Range ... 360', 26, 0.4,
     1     1, 2, 32.5, 6.5)
      CALL GGIP (1.25, 1.25, 0.0, -3)
      CALL GGIP30 (PLA182, BUFF, 0.0, FLOAT(MUF),  0.0, 360.0,
     1             FLOAT(MUS), 5.0,
     1     1.0, 1.0, 12.0, 0.0, 0.0, HORS * 0.9, VERT * 0.9, 0.1)
      CALL GGIP (-1.25, -1.25, 0.0, -3)
  226 CALL GGIP20 (0.0, 'Click on END to Proceed', 23,
     1            0.75, 2, 2, 15.0, 1.0)
      CALL PLA013 (0, 1)
      CALL PLA006 (0, IS)
      IF (IFL(1)(1:4) .EQ. 'NEXT') THEN
        GOTO 229
      ELSE IF (IFL(1)(1:3) .EQ. 'END') THEN
        GOTO 229
      ELSE IF (IFL(1)(1:4) .EQ. 'EXIT') THEN
        GOTO 229
      ELSE IF (IFL(1)(1:4) .EQ. 'PLOT') THEN
        GOTO 225
      ELSE
        GOTO 226
      ENDIF
  229 CALL GGIP (0.0, 0.0, 0.0, -1)
      IF (ITCOR .EQ. 1) THEN
        MAXM   = INT(THMAX / 5.0 + 0.8)
        MRANGE = MAXM + 1
        MEND   = MAXM * 5
        DO 230 I = 1, MRANGE
          THET  = (I - 1) * 5.0
          SINTH = SIN(THET / GL(5))
          COSTH = COS(THET / GL(5))
          CALL PLA181 (PS1, PS2, PS3)
          A(I) = PS3
  230   CONTINUE
        WRITE (LU7, 99998) MEND, (I, I = 0, MEND, 5)
        WRITE (LU7, 99997) (A(I), I = 1, MRANGE)
      ENDIF
  250 RETURN
99999 FORMAT (I4, 1X, 18F5.2)
99998 FORMAT (/, 'Curve for THETA = 0 --->', I3, /, 2X, 18(I7))
99997 FORMAT (5X, 18F7.3)
99996 FORMAT (/, 'Absorption Surface for PHI =', I4, ' --->', I4,
     1  ' WITH MU RANGE =', I3, ' --->', I3, /, 5X, 18(I3, 2X))
99995 FORMAT (/, ':: Residuals After Correction')
99994 FORMAT (/, I6, ' Reflections corrected (Corrections on F**2)',
     1       /, 'Min. absorption corr. =', F6.3, ' for ', 3I4,
     2       2X, 'at  Phi(P)=', F6.1, ' Mu(P)=', F6.1,
     3       '   Phi(S)=', F6.1, ' Mu(S)=', F6.1,
     4       /, 'Max. absorption corr. =', F6.3, ' for ', 3I4,
     5       2X, 'at  PHI(P)=', F6.1, ' MU(P)=', F6.1,
     6       '   PHI(S)=', F6.1, ' MU(S)=', F6.1,
     7       /, 'Average absorption correction =', F6.3,
     8       //, 'Minimum, Maximum Virtual Transmission: ', 2F6.3)
99993 FORMAT (/, 10X, 'Values for the Fourier Expansion Coefficients',
     1        //, 2(6F10.4, /), /, 2(4F10.4, /), /,
     2            2(7F10.4, /), /, 2(5F10.4, /), /)
99992 FORMAT (/, I6, ' Reflections on Input',
     1        /, I6, ' Rejected with I(obs) <= 0',
     2        /, I6, ' Rejected with I(obs) / Sig(Iobs) < 1.5',
     3        /, I6, ' Rejected with I(calc)/ Sig(Iobs) < 1.5',
     4        /, I6, ' Rejected with Fcalc .GT. 2*Fobs', /,
     5        /, 'Maximum THETA =', F6.2, ' degrees',
     6        /, 'Minimum MU    =', F6.2, ' degrees',
     7        /, 'Maximum MU    =', F6.2, ' degrees', /,
     8        /, 'NUMBER OF REFLECTION PATHS IN EACH OCTANT',
     9        /, 11X, 'Primary', 20X, 'Secondary', /,
     *        2(4X, '0-90 -180 -270 -360', 5X)
     1        /, '+MU', 4I5, 8X, 4I5, /, '-MU', 4I5, 8X, 4I5)
99991 FORMAT ('DELABS: Empirical Absorption/Extinction Correction ',
     1        'with the DIFABS Strategy', /, 132('='), //,
     2        '(See: Walker, N. & Stuart, D. (1983) Acta Cryst. A39,',
     3        ' 158-166)', /)
99990 FORMAT (/, ':: Residuals Before Correction')
99989 FORMAT (//, I6, ' Reflections corrected',
     1       /, 'Minimum Transmission =', F6.3,
     2       /, 'Maximum Transmission =', F6.3)
99988 FORMAT (':: Mu & Phi Based on Pseudo-Orientation Matrix', /)
99987 FORMAT (/, ':: DELABS Style Absorption Corr. THCOR = ', A, /)
99986 FORMAT (/, 'For the', I6, ' reflections R = ', F6.4,
     1           ' and R2 = ', F6.4)
99985 FORMAT (/,':: Too Few Data to Fit Transmission Surface')
99984 FORMAT (/, ':: TWIN MATRIX & BASF:', 9I4, F10.3, /)
99983 FORMAT (3I4, 2F15.2, F10.2, 5F9.2, 1X, 3F8.0)
      END
      SUBROUTINE PLA181 (PS1, PS2, PS3)
      PARAMETER (NP12=600,NP13=500,NP17=99,NPVD=40000000,NP23=18000,
     1 NP38=125,NP39=30)
      REAL MU
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON // JNSC(2, NP23), VOID(NPVD - 15444), BUFF(11000),
     1 ANORM(44, 44),  ATB(44), ROWJ(88), TERMS(44), VEC(44, 44),
     2 EIG(44), UM1(44), WORK(220), RDASH(44), SDASH(44)
      COMMON /REFL/ FC, FO, FM, PHI(2), MU(2), ST, CT
      COMMON /DRVR/ NCY, NSHAPE, NACOEF, NBCOEF, SFMU, ITCOR
      DTOR = 1.0 / GL(5)
      INC  = -34
      DO 1 I = 1, 2
        INC = INC + 34
        SP      = SIN(PHI(I) * DTOR)
        CP      = COS(PHI(I) * DTOR)
        SM      = SIN(MU(I)  * DTOR)
        CM      = COS(MU(I)  * DTOR)
        SP2     = CP  * SP  * 2.0
        CP2     = CP  ** 2   - SP  ** 2
        SP3     = CP  * SP2 + CP2 * SP
        CP3     = CP  * CP2 - SP  * SP2
        SP4     = CP2 * SP2 * 2.0
        CP4     = CP2 ** 2   - SP2 ** 2
        SP5     = CP2 * SP3 + CP3 * SP2
        CP5     = CP2 * CP3 - SP2 * SP3
        SP6     = CP3 * SP3 * 2.0
        CP6     = CP3 ** 2   - SP3 ** 2
        SM2     = CM  * SM  * 2.0
        CM2     = CM  ** 2   - SM  ** 2
        SM3     = CM2 * SM  + CM  * SM2
        CM3     = CM2 * CM  - SM2 * SM
        SM4     = CM2 * SM2 * 2.0
        CM4     = CM2 ** 2   - SM2 ** 2
        ROWJ(INC + 1)  = SP
        ROWJ(INC + 2)  = SP2
        ROWJ(INC + 3)  = SP3
        ROWJ(INC + 4)  = SP4
        ROWJ(INC + 5)  = SP5
        ROWJ(INC + 6)  = SP6
        ROWJ(INC + 7)  = CP
        ROWJ(INC + 8)  = CP2
        ROWJ(INC + 9)  = CP3
        ROWJ(INC + 10) = CP4
        ROWJ(INC + 11) = CP5
        ROWJ(INC + 12) = CP6
        ROWJ(INC + 13) = SM
        ROWJ(INC + 14) = SM2
        ROWJ(INC + 15) = SM3
        ROWJ(INC + 16) = SM4
        ROWJ(INC + 17) = CM
        ROWJ(INC + 18) = CM2
        ROWJ(INC + 19) = CM3
        ROWJ(INC + 20) = CM4
        ROWJ(INC + 21) = CP  * SM  + SP  * CM
        ROWJ(INC + 22) = CP2 * SM  + SP2 * CM
        ROWJ(INC + 23) = CP3 * SM  + SP3 * CM
        ROWJ(INC + 24) = CP4 * SM  + SP4 * CM
        ROWJ(INC + 25) = CP2 * SM2 + SP2 * CM2
        ROWJ(INC + 26) = CP3 * SM3 + SP3 * CM3
        ROWJ(INC + 27) = CP4 * SM4 + SP4 * CM4
        ROWJ(INC + 28) = CP  * CM  - SP  * SM
        ROWJ(INC + 29) = CP2 * CM  - SP2 * SM
        ROWJ(INC + 30) = CP3 * CM  - SP3 * SM
        ROWJ(INC + 31) = CP4 * CM  - SP4 * SM
        ROWJ(INC + 32) = CP2 * CM2 - SP2 * SM2
        ROWJ(INC + 33) = CP3 * CM3 - SP3 * SM3
        ROWJ(INC + 34) = CP4 * CM4 - SP4 * SM4
    1 CONTINUE
      PS1      = 1.0
      PS2      = 1.0
      PS3      = 1.0
      IF (NCY .GT. 1) THEN
        DO 10 J = 1, NACOEF
          JJ  = J + NACOEF
          PS1 = PS1 + TERMS(J) * ROWJ(J)
          PS2 = PS2 + TERMS(J) * ROWJ(JJ)
10      CONTINUE
        IF (ITCOR .EQ. 1) THEN
          ST2      = CT  * ST  * 2
          CT2      = CT  * CT  - ST  * ST
          ST3      = CT  * ST2 + CT2 * ST
          CT3      = CT  * CT2 - ST  * ST2
          ROWJ(72) = CT2 * ST2 * 2
          ROWJ(77) = CT2 * CT2 - ST2 * ST2
          ROWJ(73) = CT2 * ST3 + CT3 * ST2
          ROWJ(78) = CT2 * CT3 - ST2 * ST3
          ROWJ(69) = ST
          ROWJ(70) = ST2
          ROWJ(71) = ST3
          ROWJ(74) = CT
          ROWJ(75) = CT2
          ROWJ(76) = CT3
          IF (NCY .GT. 2) THEN
            NSTART = NACOEF + 1
            DO 20 J = NSTART, NSHAPE
              JJ  = J + NACOEF
              PS3 = PS3 + TERMS(J) * ROWJ(JJ)
20          CONTINUE
          ENDIF
        ENDIF
      ENDIF
      RETURN
      END
      FUNCTION PLA182 (X, Y, XMN, XMX, YMN, YMX)
      COMMON /REFL/ FC, FO, FM, PHI(2), MU(2), SINTH, COSTH
      COMMON /DRVR/ NCY, NSHAPE, NACOEF, NBCOEF, SFMU, ITCOR
      REAL MU
      IF (Y .GE. 0.0) THEN
        RMU =   SQRT(Y)      * SFMU
      ELSE
        RMU = - SQRT(ABS(Y)) * SFMU
      ENDIF
      MU(1)  = RMU
      MU(2)  = RMU
      PHI(1) = X
      PHI(2) = X
      IF (X .GE. XMN .AND. X .LE. XMX .AND.
     1    Y .GE. YMN .AND. Y .LE. YMX) THEN
        CALL PLA181 (PS1, PS2, PS3)
        PLA182 = 2.5 * (PS1 * PS2) ** 2
      ELSE
        PLA182 = 0.0
      ENDIF
      RETURN
      END
      SUBROUTINE PLA183
      PARAMETER (NP12=600,NP13=500,NP17=99,NPVD=40000000,NP23=18000,
     1 NP38=125,NP39=30,MR=300000,MZ=NPVD+2*NP23-9*MR-7656)
      DOUBLE PRECISION B(3570), C(84), E(84), F(84), DD, DT, TT
      COMMON // B, C, E, F, D(12), FF(MR), FC(MR), SG(MR), XI(MR),
     1 XD(MR), YI(MR), YD(MR), ZI(MR), ZD(MR), DUMMY(MZ)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      DIMENSION TRMX(3, 3)
      COMMON /PAGENM/ PAGET, PAGEIND(25)
      CHARACTER PAGET*8, PAGEIND*8
      IF (IGBL(37) .NE. 1) THEN
        IPR(2) = 56
        GOTO 1000
      ENDIF
      TH  = PAR(417)
      DU  = PAR(418)
      ME  = IPR(523)
      MO  = IPR(524)
      IHT = 0
      IKT = 0
      ILT = 0
      CALL PLA293 (PAR(17), 0)
      IF (IPR(37) .EQ. 0) GOTO 1000
      CALL PLA287 (1, 1, 0)
      PAGET = 'SHXABS'
      CALL PLA269 (0)
      WRITE (LU6, 99999) PAR(417), PAR(418), IPR(523), IPR(524)
      WRITE (LU7, 99999) PAR(417), PAR(418), IPR(523), IPR(524)
      K = 230
      DO 4 I = 1, 3
        DO 3 J = 1, 3
          K = K + 1
          TRMX(I, J) = PAR(K)
    3   CONTINUE
    4 CONTINUE
      NR = 0
      U  = 0.0
      V  = 0.0
  10  READ (LU16, 99998, ERR = 10, END = 20) IH, IK, IL, OBS, Q, J,
     1      XINR, XDNR, YINR, YDNR, ZINR, ZDNR
      IF (IH .EQ. 0 .AND. IK .EQ. 0 .AND. IL .EQ. 0) GOTO 20
      IF (OBS .LT. TH * Q) GOTO 10
      IF (Q .LE. 0.0) GOTO 10
      ACAL = 0.0
      BCAL = 0.0
      IF (GEN050 (TRMX, IH, IK, IL, IHT, IKT, ILT) .GT. 0.0) THEN
        CALL PLA131 (IHT, IKT, ILT, ACAL, BCAL, ACALA, BCALA, SNTHA)
        NR     = NR + 1
        CALC   = (ACAL + ACALA) ** 2 + (BCAL + BCALA) ** 2
        FF(NR) = OBS
        FC(NR) = CALC
        SG(NR) = Q
        U      = U + OBS
        V      = V + CALC
        XI(NR) = XINR
        YI(NR) = YINR
        ZI(NR) = ZINR
        XD(NR) = XDNR
        YD(NR) = YDNR
        ZD(NR) = ZDNR
        IF (NR .EQ. MR) GOTO 1001
      ENDIF
      GOTO 10
  20  N  = NR
      IF (N .EQ. 0) GOTO 1000
      NR = 0
      SC = V / U
      DO 30 I = 1, 6
        C(I) = 0.D0
  30  CONTINUE
      DO 40 I = 1, 21
        B(I) = 0.D0
  40  CONTINUE
      DO 70 I = 1, N
        OBS = FF(I) * SC
        SIG = SG(I) * SC
        IF (AMIN1 (OBS, FC(I)) .GT. TH * SIG) THEN
          NR     = NR + 1
          FF(NR) = OBS
          FC(NR) = FC(I)
          SG(NR) = SIG
          XI(NR) = XI(I)
          YI(NR) = YI(I)
          ZI(NR) = ZI(I)
          XD(NR) = XD(I)
          YD(NR) = YD(I)
          ZD(NR) = ZD(I)
          F(1)   = DBLE(XI(I))**2
          F(2)   = DBLE(YI(I))**2
          F(3)   = DBLE(ZI(I))**2
          F(4)   = DBLE(YI(I) * ZI(I))
          F(5)   = DBLE(XI(I) * ZI(I))
          F(6)   = DBLE(XI(I) * YI(I))
          F(7)   = DBLE(XD(I))**2
          F(8)   = DBLE(YD(I))**2
          F(9)   = DBLE(ZD(I))**2
          F(10)  = DBLE(YD(I) * ZD(I))
          F(11)  = DBLE(XD(I) * ZD(I))
          F(12)  = DBLE(XD(I) * YD(I))
          L      = 0
          DO 60 J = 1, 6
            C(J) = C(J) + F(J) + F(J + 6)
            DO 50 K = 1, J
              L    = L + 1
              B(L) = B(L) + F(J) * F(K) + F(J + 6) * F(K + 6)
  50        CONTINUE
  60      CONTINUE
        ENDIF
  70  CONTINUE
      CALL GEN110 (6, 21, C, B)
      DO 80 I = 1, 6
        D(I + 6) = SNGL(C(I))
  80  CONTINUE
      D(1) = SQRT (D(7))
      D(2) = 0.5 * D(12) / D(1)
      D(3) = 0.5 * D(11) / D(1)
      D(4) = SQRT (D(8) - D(2)**2)
      D(5) = (0.5 * D(10) - D(2) * D(3)) / D(4)
      D(6) = SQRT (D(9) - D(3)**2 - D(5)**2)
      T = 0.0
      S = 0.0
      R = 0.0
      U = 0.0
      V = 0.0
      DO 90 I = 1, NR
        U     = U + FF(I)
        V     = V + FC(I)
        XI(I) = XI(I) * D(1) + YI(I) * D(2) + ZI(I) * D(3)
        YI(I) = YI(I) * D(4) + ZI(I) * D(5)
        ZI(I) = ZI(I) * D(6)
        XD(I) = XD(I) * D(1) + YD(I) * D(2) + ZD(I) * D(3)
        YD(I) = YD(I) * D(4) + ZD(I) * D(5)
        ZD(I) = ZD(I) * D(6)
        P     = ABS (1.0 - XI(I)**2 - YI(I)**2 - ZI(I)**2)
        Q     = ABS (1.0 - XD(I)**2 - YD(I)**2 - ZD(I)**2)
        R     = R + P + Q
        T     = AMAX1 (T, P, Q)
        S     = AMAX1 (S, 0.5 * (XI(I) * XD(I) + YI(I) * YD(I)
     1        + ZI(I) * ZD(I) + 1.0))
  90  CONTINUE
      R = 0.5 * R / REAL(NR)
      S = 114.59156 * ATAN2 (SQRT (S), SQRT (1.0 - S))
      WRITE (LU6, 99995) R, T, S
      WRITE (LU7, 99995) R, T, S
      CALL GEN109 (MO, ME, XI(1), YI(1), ZI(1), F, I)
      NP = I + 4
      T  = V / U
      U  = 0.0
      V  = 0.0
      DO 100 I = 1, NR
        P = SQRT (T * FF(I))
        Q = SQRT (FC(I))
        U = U + ABS (P - Q)
        V = V + Q
 100  CONTINUE
      WRITE (LU6, 99997) NR, NP, U / V
      WRITE (LU7, 99997) NR, NP, U / V
      NN = (NP * (NP + 1)) / 2
      DO 110 I = 1, NN
        B(I) = 0.D0
 110  CONTINUE
      DO 120 I = 1, NP
        C(I) = 0.D0
 120  CONTINUE
      DO 160 I = 1, NR
        CALL GEN109 (MO, ME, XI(I), YI(I), ZI(I), E, L)
        CALL GEN109 (MO, ME, XD(I), YD(I), ZD(I), F, L)
        S = 0.5 * (XI(I) * XD(I) + YI(I) * YD(I) + ZI(I) * ZD(I) + 1.0)
        DO 130 J = 1, L
          F(J) = F(J) + E(J)
 130    CONTINUE
        F(L + 1) = DBLE(S)
        F(L + 2) = 1.0D0
        F(L + 3) = 1.0D0 / DBLE(S)
        F(L + 4) = 1.0D0 / DBLE(S)**2
        DD       = DBLE(ALOG (FC(I) / FF(I)))
        M = 0
        DO 150 J = 1, NP
          C(J) = C(J) + DD * F(J)
          DT = F(J)
          DO 140 K = 1, J
            M = M + 1
            B(M) = B(M) + DT * F(K)
 140      CONTINUE
 150    CONTINUE
 160  CONTINUE
      CALL GEN110 (NP, NN, C, B)
      TM = -9.E9
      TZ = 9.E9
      U  = 0.0
      V  = 0.0
      DO 190 I = 1, NR
        CALL GEN109 (MO, ME, XI(I), YI(I), ZI(I), E, L)
        CALL GEN109 (MO, ME, XD(I), YD(I), ZD(I), F, L)
        S = 0.5 * (XI(I) * XD(I) + YI(I) * YD(I) + ZI(I) * ZD(I) + 1.0)
        DO 170 J = 1, L
          F(J) = F(J) + E(J)
 170    CONTINUE
        F(L + 1) = DBLE(S)
        F(L + 2) = 1.0D0
        F(L + 3) = 1.0D0 / DBLE(S)
        F(L + 4) = 1.0D0 / DBLE(S)**2
        TT       = 0.0D0
        DO 180 K = 1, NP
          TT = TT + C(K) * F(K)
 180    CONTINUE
        T  = SNGL(TT)
        T  = AMIN1 (T, 15.0)
        TM = AMAX1 (TM, T)
        TZ = AMIN1 (TZ, T)
        S  = SQRT (FC(I))
        U  = U + ABS (SQRT (FF(I) * EXP(T)) - S)
        V  = V + S
 190  CONTINUE
      WRITE (LU6, 99996) U / V
      WRITE (LU7, 99996) U / V
      O  = 1.0
      TA = -9.E9
      TB = 9.E9
 200  REWIND LU16
      N  = 0
 210  READ (LU16, 99998, ERR = 210, END = 270) IH, IK, IL,
     1                          T, S, M, U, P, V, Q, W, R
      IF (IABS(IH) + IABS(IK) + IABS(IL) .EQ. 0) GOTO 210
      U = U * D(1) + V * D(2) + W * D(3)
      V = V * D(4) + W * D(5)
      W = W * D(6)
      P = P * D(1) + Q * D(2) + R * D(3)
      Q = Q * D(4) + R * D(5)
      R = R * D(6)
      N = N +1
      CALL GEN109 (MO, ME, U, V, W, E, L)
      CALL GEN109 (MO, ME, P, Q, R, F, L)
      Q = 0.5 * (U * P + V * Q + W * R + 1.0)
      DO 220 J = 1, L
        F(J) = F(J) + E(J)
 220  CONTINUE
      F(L + 1) = DBLE(Q)
      F(L + 2) = 1.0D0
      F(L + 3) = 1.0D0 / DBLE(Q)
      F(L + 4) = 1.0D0 / DBLE(Q)**2
      P        = -157.9137 * Q * DU
      DO 230 K = 1, NP
        P = P + SNGL(C(K) * F(K))
 230  CONTINUE
      P  = EXP (AMAX1 (TZ, AMIN1 (P, TM)))
      TA = AMAX1 (TA, P)
      TB = AMIN1 (TB, P)
      Q  = O * P
      T  = T * Q
      S  = S * Q
      IF (T .GT. 99999.99) GOTO 240
      IF (S .GT. 99999.99) GOTO 240
      IF (T .LT. -9999.99) GOTO 240
      IF (S .LT. -9999.99) GOTO 240
      WRITE (LU17, 99994) IH, IK, IL, T, S, M
      GOTO 210
 240  IF (T .GT. 9999999.0) GOTO 250
      IF (S .GT. 9999999.0) GOTO 250
      IF (T .LT. -999999.0) GOTO 250
      IF (S .GT. -999999.0) GOTO 260
 250  REWIND LU17
      O = O * 0.1
      GOTO 200
 260  WRITE (LU17, 99993) IH, IK, IL, T, S, M
      GOTO 210
 270  I = 0
      T = 0.0
      WRITE (LU17, 99994) I, I, I, T, T, I
      T = (TB / TA)**0.3333
      WRITE (LU6, 99992) N, T * TB / TA, T
      WRITE (LU7, 99992) N, T * TB / TA, T
      IPR(2) = -10
 1000 RETURN
 1001 WRITE (LU6, 99991)
      WRITE (LU7, 99991)
      RETURN
99999 FORMAT (/, ' SHXABS', 2F8.2, 2I5, /)
99998 FORMAT (3I4, 2F8.2, I4, 6F8.5)
99997 FORMAT (/, I8, ' Reflections used to determine', I3,' Parameters'
     1 //' R1 =',F9.4,'  Before Parameter Refinement')
99996 FORMAT (' R1 =',F9.4,'  After  Parameter Refinement'/)
99995 FORMAT (/, 'Mean and Maximum Errors in Direction Cosine Check ',
     1 'Function =', 2F7.3, /, 'The mean error should not exceed,',
     2 ' 0.005. Maximum 2-theta =', F8.2, ' degrees', /)
99994 FORMAT (3I4, 2F8.2, I4)
99993 FORMAT (3I4, 2F8.0, I4)
99992 FORMAT (I8,' Corrected reflections written to file ', //,
     1 ' Minimum and Maximum Virtual Transmission =', 2F12.6, /)
99991 FORMAT (' ** Too many .raw data - use higher I/sigma ',
     1 //, 'or larger version  **')
      END
      SUBROUTINE PLA185 (MODE, SCL, NR, NOCLS)
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16,
     1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP22=256,NP25=99,
     2 NP29=63,NP38=125,NP39=30,NP41=200,NP47=9,NXT1=100,NXT2=200,
     3 NXT3=100, NXT4=200)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /P190/ NVRR, PMILL(NXT1, 5), XTLV(7, NXT2), IDG(NXT4, 4),
     1 XYZPL(3, NXT2), CFACE(5, NXT2), IEDGE(NXT3), NFACES, NEDGE, NVER
      COMMON /ABSPSI/ PSIS(38, 4, 10), OP(3, 3, 11), IHKLPS(4, 10),
     1 NPSI
      CHARACTER NRV*6
      VERT = 25.0
      IDM  = '  H  K  L  DIST(mm)'
      CALL GGIP20 (0.0, IDM, 19, 0.5, 5, 2, VERT + 0.1, VERT - 3.0)
      DO 10 I = 1, NFACES
        WRITE (IDM, 99999) (NINT(PMILL(I, J)), J = 1, 3), PMILL(I, 5)
        CALL GGIP20 (0.0, IDM, 18, 0.5, -1, 2, VERT + 0.1,
     1       VERT - 3.5 - I * 0.8)
   10 CONTINUE
      CALL GGIP (13.0, 12.0, 0.0, -3)
      IF (NVER .GT. NXT2) THEN
        CALL GGIP20 (0.0, 'Too Many Vertices ', 18, 0.75,
     1                         2, 2, 1.0, -6.5)
        GOTO 190
      ELSE IF (NFACES + NVRR - 2 .NE. NEDGE) THEN
        WRITE (PRBUF, 99994)
        WRITE (LU6, 99998) PRBUF
        WRITE (LU7, 99998) PRBUF
        CALL GGIP20 (0.0, PRBUF, 18, 0.75, 2, 2, 1.0, -8.0)
        GOTO 190
      ENDIF
      CALL GEN021 (DUMV, 1)
      CALL GEN004 (OP(1, 1, NR), DUMV, DUMV)
      CALL GEN003 (OP(1, 1, NR), PAT, DET, 0)
      CALL GEN007 (RAA, DUMV(1, 1), V3, 1)
      CALL GEN007 (RAA, DUMV(1, 2), V4, 1)
      CALL GEN007 (RAA, DUMV(1, 3), V5, 1)
      DO 20 I = 1, 2
        V3(I)     = V3(I) * SCL * 0.5
        V4(I)     = V4(I) * SCL * 0.5
        V5(I)     = V5(I) * SCL * 0.5
        V1(I)     =   1000000.0
        V1(I + 2) = - 1000000.0
   20 CONTINUE
      IF (NVER .GT. 0) THEN
        CALL GEN074 (V2, 0.0, 1, 3)
        DO 30 I = 1, NVER
          CALL GEN002 (MODE, DUMV, XTLV(1, I), XYZPL(1, I), XG)
          V1(1) = MIN (V1(1), XYZPL(1, I))
          V1(2) = MIN (V1(2), XYZPL(2, I))
          V1(3) = MAX (V1(3), XYZPL(1, I))
          V1(4) = MAX (V1(4), XYZPL(2, I))
          V2(1) = V2(1) + XYZPL(1, I)
          V2(2) = V2(2) + XYZPL(2, I)
          V2(3) = V2(3) + XYZPL(3, I)
   30   CONTINUE
        V2(1) = V2(1) / NVER
        V2(2) = V2(2) / NVER
        V2(3) = V2(3) / NVER
        DO 40 I = 1, NVER
          XYZPL(1, I) = XYZPL(1, I) - V2(1)
          XYZPL(2, I) = XYZPL(2, I) - V2(2)
          XYZPL(3, I) = XYZPL(3, I) - V2(3)
   40   CONTINUE
        DIS = 0.0
        DO 50 I = 1, NVER
          DIS = MAX (DIS, SQRT (GEN009 (XYZPL(1, I), XYZPL(1, I))))
   50   CONTINUE
        SCAL = PAR(325) * SCL / DIS
        DO 90 I = 1, NFACES
          ANGLE = 0
          DO 60 J = 1, 3
            ANGLE       = ANGLE + PAT(J, 3) * PMILL(I, J)
            CFACE(J, I) = 0.0
   60     CONTINUE
          CFACE(4, I) = 0
          CFACE(5, I) = ANGLE
          DO 80 K = 1, NVER
            DO 70 J = 4, 6
              N = IABS(NINT(XTLV(J, K)))
              IF (N .EQ. I) THEN
                IF (ANGLE .LT. 0.0) N = - N
                XTLV(J, K) = N
                CFACE(1, I) = CFACE(1, I) + XYZPL(1, K)
                CFACE(2, I) = CFACE(2, I) + XYZPL(2, K)
                CFACE(3, I) = CFACE(3, I) + XYZPL(3, K)
                CFACE(4, I) = CFACE(4, I) + 1.0
              ENDIF
   70       CONTINUE
   80     CONTINUE
   90   CONTINUE
        IF (NOCLS .GE. 0) THEN
          COLR = 1.0
        ELSE
          COLR = 0.0
        ENDIF
        CALL GGIP (0.0, COLR, 0.0, 0)
        DO 110 I = 1, NVER
          DO 100 K = 1, 3
            XYZPL(K, I) = SCAL * XYZPL(K, I)
  100     CONTINUE
          IF (IGBL(75) .EQ. 1) THEN
            IF (NVER .LT. 100) THEN
              NV = 2
              WRITE (NRV, 99997) NINT(XTLV(7, I))
            ELSE
              NV = 3
              WRITE (NRV, 99996) NINT(XTLV(7, I))
            ENDIF
            CALL GGIP20 (0.0, NRV, NV, 0.3, -1, 2,
     1                   XYZPL(1, I), XYZPL(2, I))
          ENDIF
  110   CONTINUE
        DO 130 I = 1, NFACES
          DO 120 K = 1, 3
            CFACE(K, I) = SCAL * (CFACE(K, I) / CFACE(4, I))
  120     CONTINUE
          IF (IGBL(75) .EQ. 1) THEN
            IF (CFACE(5, I) .GT. 0.0) THEN
              COLR = 1.0
              SHT = 0.15
            ELSE
              COLR = 4.0
              SHT = -0.15
            ENDIF
            IF (NOCLS .LT. 0) THEN
              COLR = 0.0
            ENDIF
            CALL GGIP (0.0, COLR, 0.0, 0)
            WRITE (NRV, 99995) (NINT(PMILL(I, K)), K = 1, 3)
            CALL GGIP20 (0.0, NRV, 6, 0.25, -1, 2,
     1                   CFACE(1, I) - 0.5, CFACE(2, I) + SHT)
          ENDIF
  130   CONTINUE
      ENDIF
      DO 180 I0 = 1, NEDGE
        I  = IDG(I0, 3)
        J0 = IDG(I0, 4)
        MC   = 0
        IVIS = 0
        IF (NOCLS .LT. 0) THEN
          COLR = 0.0
        ELSE
          COLR = 1.0
        ENDIF
        CALL GGIP (0.0, COLR, 0.0, 0)
        DO 170 K = 1, 3
          DO 160 L = 1, 3
            IF (ABS(XTLV(K + 3, I)) .EQ. ABS(XTLV(L + 3, J0))) THEN
              MC = MC + 1
              IF (XTLV(K + 3, I) .GT. 0.0) IVIS = IVIS + 1
              IF (MC .EQ. 2) THEN
                IF (IVIS .LT. 1) THEN
                  XB = XYZPL(1, I)
                  YB = XYZPL(2, I)
                  DIST = SQRT ((XYZPL(1, J0) - XB)**2
     1                 +       (XYZPL(2, J0) - YB)**2)
                  NSTEP = NINT(DIST / 0.3)
                  IF (NSTEP .GT. 0) THEN
                    STEPX = (XYZPL(1, J0) - XB) / NSTEP
                    STEPY = (XYZPL(2, J0) - YB) / NSTEP
                    DO 140 II = 1, NSTEP, 2
                      CALL GGIP (XB, YB, 0.0, 3)
                      XB = XB + STEPX
                      YB = YB + STEPY
                      CALL GGIP (XB, YB, 0.0, 2)
                      XB = XB + STEPX
                      YB = YB + STEPY
  140               CONTINUE
                  ENDIF
                ELSE
                  IF (NOCLS .LT. 0) THEN
                    COLR = 0.0
                  ELSE
                    COLR = 1.0
                  ENDIF
                  CALL GGIP (0.0, COLR, 0.0, 0)
                  DELX = XYZPL(1, J0) - XYZPL(1, I)
                  DELY = XYZPL(2, J0) - XYZPL(2, I)
                  IF (DELX .EQ. 0) THEN
                    DX = 0.025
                    DY = 0.0
                  ELSE IF (DELY .EQ. 0) THEN
                    DX = 0.0
                    DY = 0.025
                  ELSE
                    DY = - (DELX / DELY)
                    DX = SQRT (0.000625 / (1 + DY**2))
                    DY = DX * DY
                  ENDIF
                  XB = XYZPL(1, I)  - DX
                  YB = XYZPL(2, I)  - DY
                  XE = XYZPL(1, J0) - DX
                  YE = XYZPL(2, J0) - DY
                  DO 150 II = 1, 2
                    CALL GGIP (XB, YB, 0.0, 3)
                    CALL GGIP (XE, YE, 0.0, 2)
                    XB = XB + 2 * DX
                    YB = YB + 2 * DY
                    XE = XE + 2 * DX
                    YE = YE + 2 * DY
  150             CONTINUE
                ENDIF
                GOTO 180
              ENDIF
            ENDIF
  160     CONTINUE
  170   CONTINUE
  180 CONTINUE
      IF (IPR(388) .EQ. 1) THEN
        IF (NOCLS .LT. 0) THEN
          COLR = 0.0
        ELSE
          COLR = 2.0
        ENDIF
        CALL GGIP (0.0, COLR, 0.0, 0)
        CALL GGIP (0.0,   0.0,   0.0, 3)
        CALL GGIP (V3(1), V3(2), 0.0, 2)
        CALL GGIP20 (0.0, 'a', 1, 0.35,  -1, 2, V3(1) + 0.2, V3(2))
        CALL GGIP (0.0,   0.0,   0.0, 3)
        CALL GGIP (V4(1), V4(2), 0.0, 2)
        CALL GGIP20 (0.0, 'b', 1, 0.35,  -1, 2, V4(1) + 0.2, V4(2))
        CALL GGIP (0.0,   0.0,   0.0, 3)
        CALL GGIP (V5(1), V5(2), 0.0, 2)
        CALL GGIP20 (0.0, 'c', 1, 0.35,  -1, 2, V5(1) + 0.2, V5(2))
      ENDIF
  190 CALL GGIP (-13.0, -12.0, 0.0, -3)
      CALL GGIP (0.0, 0.0, 0.0, 0)
      RETURN
99999 FORMAT (3I3, F8.3)
99998 FORMAT (':: ', A)
99997 FORMAT (I2)
99996 FORMAT (I3)
99995 FORMAT (3I2)
99994 FORMAT ('Crystal not Finite')
      END
      SUBROUTINE PLA187
C * CALCULATES AN EMPIRICAL CORRECTION FOR ABSORPTION ANISOTROPY BASED
C * ON A LEAST-SQUARES FIT OF REAL SPHERICAL HARMONIC FUNCTIONS TO THE
C * EMPIRICAL TRANSMISSION SURFACE AS SAMPLED BY MULTIPLE SYMMETRY-
C * EQUIVALENT AND/OR AZIMUTH ROTATION-EQUIVALENT REFLECTION
C * MEASUREMENTS. (C.F. BLESSING, ACTA CRYST (1995), A51, 33-38)
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16,
     1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NPVD=40000000,
     2 NP22=256,NP23=18000,NP25=99,NP29=63,NP38=125,NP39=30,NP41=200,
     3 NP45=2048,NP47=9,NMX=1000,NMAX=(NPVD+2*NP23-14*NMX-45600)/2)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON // AZ(80, 80), BZ(80), UZ(80), VZ(80, 80), VA(80, 80),
     1 YI(NMX), SIGYI(NMX), U0(3, NMX), U1(3, NMX), AII(NMX), SAA(NMX),
     2 WI(NMX), IHH(NMX), IKK(NMX), ILL(NMX), SIGALM(80), ALM(80),
     3 YLM0(80), YLM1(80), QI(80), XI(80), CORR(80, 80), DATA(NMAX),
     4 INDEX(NMAX)
      COMMON /Q/ ICL, IFL(NP17)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      DIMENSION S0(3), S1(3), FMUR(12), AMUR(12)
      DOUBLE PRECISION AZ, BZ, UZ, VZ, VA
      CHARACTER N0*1, N1*1, N2*1
      DATA FMUR /0, 0.5, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10/
      DATA AMUR /1.0, 0.48181, 0.24249, 0.07142, 0.02606, 0.01156,
     1 0.005983, 0.00347, 0.002186, 0.001465, 0.001029, 0.00075/
      IHM      = - 9999
      IKM      = - 9999
      ILM      = - 9999
      SMIN     = 9.0
      SMAX     = 0.0
      PAR(301) = FN(1)
      PAR(305) = FN(2)
      PAR(304) = FN(3)
      PAR(306) = FN(4)
      IPR(373) = NINT(FN(5))
      IPR(374) = NINT(FN(6))
      PAR(321) = PAR(301) * PAR(305)
      IF (PAR(321) .EQ. 0.0) THEN
        IGBL(23) = 16
        NAUTO    = IGBL(25)
      ELSE
        NAUTO = 0
      ENDIF
      CALL PLA269 (-3)
      WRITE (LU7, 99999)
      IF (PAR(17) .LE. 0) THEN
        WRITE (LU6, '(''STOP : WAVELENGTH NOT GIVEN'')')
        WRITE (LU7, '(''STOP : WAVELENGTH NOT GIVEN'')')
        GOTO 830
      ENDIF
      SINA  = SIN(PAR(244) / GL(5))
      COSA  = COS(PAR(244) / GL(5))
      COSBS = COS(PAR(139) / GL(5))
      COSGS = COS(PAR(140) / GL(5))
      SINBS = SIN(PAR(139) / GL(5))
      SINGS = SIN(PAR(140) / GL(5))
      DELTA = 0.0
      DO 5 I = 1, 6
        DELTA = DELTA + ABS(PAR(100 + I) - PAR(240 + I))
    5 CONTINUE
      IF (DELTA .GT. 0.01) THEN
        CALL GEN112 (QQ, PAR(231), 1)
        CALL GEN003 (QQ, DUMV, DET, 0)
        CALL GEN112 (DUMV, XJX(1), -1)
        XJX(10)  = 0.0
        XJX(11)  = 0.0
        XJX(12)  = 0.0
        LINE = 'SPGR '//SPGRNM(1)(1:11)
        CALL SGSM (LINE, NRSM, XJX, LU6, 16, IERR)
        CALL SGSM (LINE, NSM, XJX, LU6, 2, IERR)
        CALL SGSM (LINE, 0,   XJX, LU6, 18, IERR)
        IPR(255) = NINT(XJX(4))
        IPR(257) = NINT(XJX(5))
      ENDIF
      FSQMIN = 1.0
      FSQMAX = 1E10
      STLMIN = 0.0
      STLMAX = 9.0
      SMIN1  = 0
      SMAX1  = 9
      IF (NAUTO .EQ. 1) THEN
        CALL PLA200 (6, 1, 0, 0)
        CALL GGIP (0.0, 0.0, 0.0, 6)
      ENDIF
      N3REJ    = 0
      N6REJ    = 0
      N7REJ    = 0
      IPR(371) = 0
      IPR(372) = 0
      CALL PLA290 (0)
      CALL GEN108 (LU16, 0)
      NINP = 0
   10 READ (LU16, 99998, END = 30) IH, IK, IL, Y, SIGY,
     1    (V1(K), V2(K), K = 1, 3)
      IF (IH .EQ. 0 .AND. IK .EQ. 0 .AND. IL .EQ. 0) GOTO 30
      NINP  = NINP + 1
      V3(1) = IH
      V3(2) = IK
      V3(3) = IL
      STH = SQRT(GEN095 (PAR(391), IH, IK, IL)) * PAR(17)
      DO 2050 K = 1, 3
        V4(K) = PAR(134 + K) * V1(K)
        V5(K) = PAR(134 + K) * V2(K)
 2050 CONTINUE
      TPRIM = GEN009 (V3, V4)
      TDIFF = GEN009 (V3, V5)
      DUMMY = GEN006 (V4, RAA, V5) /
     1            SQRT(GEN006 (V4, RAA, V4) * GEN006 (V5, RAA, V5))
      IF (ABS(DUMMY) .GT. 1.0) DUMMY = SIGN(1.0, DUMMY)
      IF (ABS(STH) .GT. 0.99999999)
     1    WRITE (LU6,'(''|SIN(THETA)| > 1.0 ?'', 3I5,F10.5,/)')
     2           IH, IK, IL, STH
      TH1    = ASIN(STH) * GL(5)
      TH2    = 90.0 - ACOS(DUMMY) * GL(5) / 2.0
      CALL PLA291 (TPRIM, TDIFF, TH1, TH2, ITEST)
      IF (ITEST .NE. 0) GOTO 30
      S0(1)    = V1(1)
      S1(1)    = V2(1)
      S0(2)    = (V1(2) - V1(1) * COSGS) / SINGS
      S1(2)    = (V2(2) - V2(1) * COSGS) / SINGS
      S0(3)    = (V1(3) - V1(1) * COSBS + S0(2) * SINBS * COSA) /
     1           (SINBS * SINA)
      S1(3)    = (V2(3) - V2(1) * COSBS + S1(2) * SINBS * COSA) /
     1           (SINBS * SINA)
      IPR(371) = IPR(371) + 1
      S = GEN056 (IH, IK, IL, RBB)
      IF (S .LT. SMIN1 .OR. S .GT. SMAX1) THEN
        N3REJ = N3REJ + 1
        GOTO 10
      ENDIF
      IF (SIGY .LE. 0) THEN
        N6REJ = N6REJ + 1
        GOTO 10
      ENDIF
      IF (Y .LT. -4 * SIGY) THEN
        N7REJ = N7REJ + 1
        GOTO 10
      ENDIF
      SMIN = MIN (SMIN, S)
      SMAX = MAX (SMAX, S)
      NSYMH = IPR(255)
      ICNTR = IPR(257)
      IHKLM = -99999
      DO 20 I = 1, NSYMH
        XJX(1) = IH
        XJX(2) = IK
        XJX(3) = IL
        XJX(4) = 0.0
        NS     = I
        CALL SGSM (ICL, NS, XJX, 0, 5, IERR)
        IH0  = NINT(XJX(7))
        IK0  = NINT(XJX(8))
        IL0  = NINT(XJX(9))
        IHKL = IL0 * 250000 + IK0 * 500 + IH0
        IF (IHKL .LT. 0 .AND. ICNTR .EQ. 2) THEN
          IH0  = - IH0
          IK0  = - IK0
          IL0  = - IL0
          IHKL = - IHKL
        ENDIF
        IF (IABS(IHKL) .GT. IHKLM) THEN
          IHKLM = IABS(IHKL)
          J     = IH0
          K     = IK0
          L     = IL0
        ENDIF
   20 CONTINUE
      IHM = MAX (IHM, IABS(J))
      IKM = MAX (IKM, IABS(K))
      ILM = MAX (ILM, IABS(L))
      IF (IPR(372) .LT. NMAX) IPR(372) = IPR(372) + 1
      IF (NAUTO .EQ. 1) THEN
        IF (MOD(IPR(372), 5000) .EQ. 0) CALL PLA200 (6, 1, 0, 1)
      ENDIF
      WRITE (LU29, REC = IPR(372))
     1       J, K, L, IH, IK, IL, Y, SIGY, S0, S1
      GOTO 10
   30 WRITE (LU7, '(''Read   ='', I7, '' Measurements'')') IPR(371)
      IF (ITEST .NE. 0) THEN
        IPR(210) = 0
        GOTO 830
      ENDIF
      WRITE (LU7, '(''Accept ='', I7, '' Measurements'')') IPR(372)
      CALL PLA290 (-1)
      CALL PLA269 (6)
   35 IF (IPR(373) .EQ. 0) IPR(373) = 8
      IF (IPR(374) .GT. 7) IPR(374) = 7
      AIMIN  = 0.5
      AIMAX  = 1.5
      IF (AIMIN .EQ. 0 .AND. AIMAX .EQ. 0) THEN
        IF (PAR(301) .GT. 0 .AND. PAR(304) .GT. 0
     1                      .AND. PAR(306) .GT. PAR(304)) THEN
          AIMIN = EXP(- PAR(301) * PAR(306))
          AIMAX = EXP(- PAR(301) * PAR(304))
        ELSE
          AIMIN = 0.5
          AIMAX = 1.5
        ENDIF
      ENDIF
      IF (AIMIN .GE. 0 .AND. AIMAX .GT. AIMIN) THEN
        AMEAN = 0.5 * (AIMIN + AIMAX)
        AIMIN = AIMIN / AMEAN
        AIMAX = AIMAX / AMEAN
      ENDIF
      IF (AIMIN .LT. 0) AIMIN = 0
      IF (AIMAX .LT. 0) AIMAX = 1E10
      CALL PLA269 (16)
      WRITE (LU7, 99997) IPR(373), IPR(374), PAR(301), PAR(305),
     1                   PAR(304), PAR(306), PAR(326)
      WRITE (LU7, 99982) FSQMIN, FSQMAX, STLMIN, STLMAX,AIMIN,AIMAX
      IF (PAR(301) .EQ. 0) THEN
        CALL PLA269 (2)
        WRITE (LU7, 99981)
      ELSE IF (PAR(305) .EQ. 0 .AND. PAR(304) .EQ. 0) THEN
        CALL PLA269 (2)
        WRITE (LU7, 99980)
      ELSE IF (PAR(305) .EQ. 0 .AND. PAR(304) .GT. 0) THEN
        CALL PLA269 (2)
        WRITE (LU7, 99979)
      END IF
      IF (NAUTO .EQ. 1) THEN
   38   CALL PLA200 (6, 1, 0, 0)
        CALL PLA013 (0, 1)
        CALL PLA006 (0, IS)
        IF (IFL(1)(1:4) .EQ. 'MU') THEN
          PAR(301) = FN(1)
          PAR(321) = PAR(301) * PAR(305)
          IPR(441) = 0
        ELSE IF (IFL(1)(1:4) .EQ. 'RADI') THEN
          PAR(305) = FN(1)
          PAR(321) = PAR(301) * PAR(305)
          IPR(442) = 0
        ELSE IF (IFL(1)(1:4) .EQ. 'TMIN') THEN
          PAR(304)   = FN(1)
        ELSE IF (IFL(1)(1:4) .EQ. 'TMAX') THEN
          PAR(306)   = FN(1)
        ELSE IF (IFL(1)(1:5) .EQ. 'L0MAX') THEN
          IPR(373)   = NINT(FN(1))
        ELSE IF (IFL(1)(1:5) .EQ. 'L1MAX') THEN
          IPR(374)   = NINT(FN(1))
        ELSE IF (IFL(1)(1:4) .EQ. 'NEXT') THEN
          CALL GGIP20 (0.0, 'Click on NEXT-STEP to PROCEED', 29,
     1                 0.60, 0, 2, 18.0, 1.5)
          CALL GGIP (0.0, 0.0, 0.0, 6)
          GOTO 39
        ELSE IF (IFL(1)(1:4) .EQ. 'END ') THEN
          GOTO 830
        ELSE IF (IFL(1)(1:4) .EQ. 'EXIT') THEN
          GOTO 830
        ELSE
          GOTO 38
        ENDIF
        CALL GGIP (0.0, 0.0, 0.0, 6)
        GOTO 35
      ENDIF
   39 CALL PLA269 (7)
      WRITE (LU7, 99983) N3REJ, SMIN1, SMAX1, N6REJ, N7REJ
      WRITE (LU7, 99986) SMIN, SMAX
      NL  = 2 * ILM + 1
      NK  = 2 * IKM + 1
      NKL = NK * NL
      DO 40 I = 1, IPR(372)
        READ (LU29, REC = I) J, K, L
        DATA(I) = (J + IHM) * NKL + (K + IKM) * NL + (L + ILM)
   40 CONTINUE
      CALL GEN053 (IPR(372), DATA, INDEX)
      DO 50 I = 1, IPR(372)
        READ  (LU29, REC = INDEX(I)) J, K, L,
     1                               IH, IK, IL, Y, SIGY, S0, S1
        WRITE (LU30, REC = I)        IH, IK, IL, Y, SIGY, S0, S1
   50 CONTINUE
      CALL GEN108 (LU8, 0)
      IHKL  = NINT(DATA(INDEX(1)))
      NMEAS = 1
      INDEX(IPR(372) + 1) = IPR(372) + 1
      DATA(IPR(372) + 1)  = -999999.0
      DO 70 I = 2, IPR(372) + 1
        IF (DATA(INDEX(I)) .EQ. IHKL) THEN
          NMEAS = NMEAS + 1
        ELSE
          IH = IHKL / NKL
          IK = (IHKL - IH * NKL) / NL
          IL = IHKL - IH * NKL - IK * NL
          IH = IH - IHM
          IK = IK - IKM
          IL = IL - ILM
          WRITE (LU8) NMEAS, IH, IK, IL
          DO 60 J = 1, NMEAS
            IREC = I - J
            READ  (LU30, REC = IREC) IH, IK, IL, Y, SIGY, S0, S1
            WRITE (LU8)              IH, IK, IL, Y, SIGY, S0, S1
   60     CONTINUE
          IHKL  = NINT(DATA(INDEX(I)))
          NMEAS = 1
        ENDIF
   70 CONTINUE
      IPR(376) = 0
      IPR(375) = 0
      CHISQ    = 0
      SUMSQ    = 0
      CALL GEN108 (LU8, 1)
      CALL GEN108 (LU9, 0)
   80 READ (LU8, END = 150) N
      DO 100 J = 1, N
        READ (LU8) IH, IK, IL, YJ, SIGYJ, S0, S1
        YI(J)    = YJ
        SIGYI(J) = SIGYJ
        DO 90 K = 1, 3
          U0(K, J) = - S0(K)
          U1(K, J) =   S1(K)
   90   CONTINUE
  100 CONTINUE
      IF (N .LT. 2) GOTO 80
      S =  GEN056 (IH, IK, IL, RBB)
      IF (S .LT. STLMIN .OR. S .GT. STLMAX) GOTO 80
      DO 110 I = 1, N
        IF (YI(I) / SIGYI(I) .LT. FSQMIN .OR. YI(I) .GT. FSQMAX)
     1      GOTO 80
  110 CONTINUE
      CALL GEN053 (N, YI, INDEX)
      M = N / 2
      IF (MOD(N, 2) .EQ. 0) THEN
        YMEDIAN = 0.5 * (YI(INDEX(M)) + YI(INDEX(M + 1)))
      ELSE
        YMEDIAN = YI(INDEX(M + 1))
      ENDIF
      NDATA = 0
      SUMW  = 0
      DO 120 I = 1, N
        AI = YI(I) / YMEDIAN
        IF (AI .LT. AIMIN .OR. AI .GT. AIMAX) THEN
          WI(I) = 0.0
        ELSE
          WI(I) = 1.0 / (SIGYI(I)**2)
          SUMW  = SUMW  + WI(I)
          NDATA = NDATA + 1
        ENDIF
  120 CONTINUE
      IF (NDATA .LT. 2) GOTO 80
      IPR(376) = IPR(376) + 1
      IPR(375) = IPR(375) + NDATA
      WRITE (LU9) NDATA, SUMW
      DO 140 I = 1, N
        IF (WI(I) .GT. 0) WRITE (LU9)
     1     (U0(III, I), III = 1, 3),
     2     (U1(III, I), III = 1, 3), WI(I), YI(I)
        DI = 0
        DO 130 J = 1, N
          YJ = - WI(J) * YI(J) / SUMW
          IF (J .EQ. I) YJ = YJ + YI(J)
          DI = DI + YJ
  130   CONTINUE
        CHISQ = CHISQ + WI(I) * DI**2
        SUMSQ = SUMSQ + WI(I) * YI(I)**2
  140 CONTINUE
      GOTO 80
  150 CALL PLA269 (16)
      WRITE (LU7, 99984) STLMIN, STLMAX, FSQMIN, FSQMAX, AIMIN, AIMAX,
     1 IPR(375), IPR(376)
      PAR(322) = SQRT(CHISQ / SUMSQ)
      Z1 = SQRT(CHISQ / (IPR(375) - IPR(376)))
      WQ = 1.0 / PAR(322)**2
      IPR(377) = 0
      LMAX = MAX (IPR(373), IPR(374))
      DO 160 L = 1, LMAX
        IF ((MOD(L, 2) .EQ. 0 .AND. L .LE. IPR(373)) .OR.
     1      (MOD(L, 2) .EQ. 1 .AND. L .LE. IPR(374)))
     2       IPR(377) = IPR(377) + 2 * L + 1
  160 CONTINUE
  170 IF (IPR(375) / IPR(377) .LT. 10) THEN
        IPR(377) = IPR(377) - (2 * LMAX + 1)
        IF (IPR(377) .LE. 0) THEN
          WRITE (PRBUF, 99975)
          WRITE (LU6, 99976) PRBUF
          WRITE (LU7, 99976) PRBUF
          GOTO 830
        ENDIF
        LMAX = LMAX - 1
        IF (IPR(373) .GT. LMAX) IPR(373) = IPR(373) - 2
        IF (IPR(374) .GT. LMAX) IPR(374) = IPR(374) - 2
        GOTO 170
      ENDIF
      DO 190 I = 1, 80
        BZ(I) = 0
        DO 180 J = I, 80
          AZ(I, J) = 0
  180   CONTINUE
  190 CONTINUE
      CALL GEN108 (LU9, 1)
  200 READ (LU9, END = 290) N, SUMW
      DO 210 I = 1, N
        READ (LU9) (U0(J, I), J = 1, 3), (U1(J, I), J = 1, 3),
     1              WI(I), YI(I)
  210 CONTINUE
      DO 280 I = 1, N
        CALL GEN055 (YLM0, U0(1, I), IPR(373), IPR(374))
        CALL GEN055 (YLM1, U1(1, I), IPR(373), IPR(374))
        DO 220 K = 1, IPR(377)
          QI(K) = 0.5 * (YLM0(K) + YLM1(K))
          XI(K) = 0.0
  220   CONTINUE
        YII = 0
        DO 250 J = 1, N
          YJ = - WI(J) * YI(J) / SUMW
          IF (J .EQ. I) YJ = YJ + YI(J)
          YII = YII + YJ
          CALL GEN055 (YLM0, U0(1, J), IPR(373), IPR(374))
          CALL GEN055 (YLM1, U1(1, J), IPR(373), IPR(374))
          DO 240 K = 1, IPR(377)
            XI(K) = XI(K) + YJ * 0.5 * (YLM0(K) + YLM1(K))
  240     CONTINUE
  250   CONTINUE
        DO 270 K = 1, IPR(377)
          BZ(K) = BZ(K) - WI(I) * YII * XI(K)
          DO 260 L = K, IPR(377)
            AZ(K, L) = AZ(K, L) + WQ * QI(K) * QI(L)
     1                       + WI(I) * XI(K) * XI(L)
  260     CONTINUE
  270   CONTINUE
  280 CONTINUE
      GOTO 200
  290 DO 310 I = 1, IPR(377) - 1
        DO 300 J = I + 1, IPR(377)
          AZ(J, I) = AZ(I, J)
  300   CONTINUE
  310 CONTINUE
      CALL GEN054 (IPR(377), 80, AZ, UZ, VZ)
      UMAX = 0
      DO 320 I = 1, IPR(377)
        UMAX = MAX (UMAX, ABS(SNGL(UZ(I))))
  320 CONTINUE
      NZERO = 0
      T = PAR(326) * UMAX
      DO 330 I = 1, IPR(377)
        IF (ABS(UZ(I)) .LT. T) THEN
          UZ(I) = 0
          NZERO = NZERO + 1
        ELSE
          UZ(I) = 1 / UZ(I)
        ENDIF
  330 CONTINUE
      DO 350 I = 1, IPR(377)
        DO 340 J = 1, IPR(377)
          AZ(I, J) = 0
  340   CONTINUE
        AZ(I, I) = UZ(I)
  350 CONTINUE
      DO 380 I = 1, IPR(377)
        DO 370 J = 1, IPR(377)
          VA(I, J) = 0
          DO 360 K = 1, IPR(377)
            VA(I, J) = VA(I, J) + VZ(I, K) * AZ(K, J)
  360     CONTINUE
  370   CONTINUE
  380 CONTINUE
      DO 400 I = 1, IPR(377) - 1
        DO 390 J = I + 1, IPR(377)
          T        = VZ(I, J)
          VZ(I, J) = VZ(J, I)
          VZ(J, I) = T
  390   CONTINUE
  400 CONTINUE
      DO 430 I = 1, IPR(377)
        DO 420 J = 1, IPR(377)
          AZ(I, J) = 0
          DO 410 K = 1, IPR(377)
            AZ(I, J) = AZ(I, J) + VA(I, K) * VZ(K, J)
  410     CONTINUE
  420   CONTINUE
  430 CONTINUE
      DO 450 I = 1, IPR(377)
        ALM(I) = 0.0
        DO 440 J = 1, IPR(377)
          ALM(I) = ALM(I) + AZ(I, J) * BZ(J)
  440   CONTINUE
  450 CONTINUE
      CHISQ  = 0
      SUMSQ  = 0
      AIMIN  = 1E10
      AIMAX  = 0
      SUMA   = 0
      SUMASQ = 0
      CHISQA = 0
      CALL GEN108 (LU9, 0)
  460 READ (LU9, END = 510) N, SUMW
      DO 480 I = 1, N
        READ (LU9) (U0(J, I), J = 1, 3),
     1             (U1(J, I), J = 1, 3), WI(I), YI(I)
        CALL GEN055 (YLM0, U0(1, I), IPR(373), IPR(374))
        CALL GEN055 (YLM1, U1(1, I), IPR(373), IPR(374))
        AI = 1
        DO 470 K = 1, IPR(377)
          AI = AI + ALM(K) * 0.5 * (YLM0(K) + YLM1(K))
  470   CONTINUE
        YI(I)  = YI(I) * AI
        AIMIN  = MIN (AIMIN, AI)
        AIMAX  = MAX (AIMAX, AI)
        SUMA   = SUMA + AI
        SUMASQ = SUMASQ + AI**2
        CHISQA = CHISQA + (AI - 1)**2
  480 CONTINUE
      DO 500 I = 1, N
        DI = 0
        DO 490 J = 1, N
          YJ = - WI(J) * YI(J) / SUMW
          IF (J .EQ. I) YJ = YJ + YI(J)
          DI = DI + YJ
  490   CONTINUE
        CHISQ = CHISQ + WI(I) * DI**2
        SUMSQ = SUMSQ + WI(I) * YI(I)**2
  500 CONTINUE
      GOTO 460
  510 AMEAN    = SUMA / IPR(375)
      RMSDA    = SQRT(SUMASQ / IPR(375) - AMEAN**2)
      ZY       = SQRT(CHISQ / (IPR(375) - IPR(376) - IPR(377)))
      PAR(323) = SQRT(CHISQ / SUMSQ)
      ZA       = SQRT(WQ * CHISQA / (IPR(375) - IPR(376)))
      RA       = SQRT(CHISQA / SUMASQ)
      DO 520 I = 1, IPR(377)
        SIGALM(I) = ZY * SQRT(AZ(I, I))
  520 CONTINUE
      DO 540 I = 1, IPR(377)
        DO 530 J = I, IPR(377)
          IF (AZ(I, I) * AZ(J, J) .GT. 0) THEN
            IF (I .EQ. J) THEN
              T = 1
            ELSE
              T = SNGL(AZ(I, J) / SQRT(AZ(I, I) * AZ(J, J)))
            ENDIF
          ELSE
            T = 0
          ENDIF
          CORR(I, J) = T
          CORR(J, I) = T
  530   CONTINUE
  540 CONTINUE
      IF (IPR(377) .LT. 80) THEN
        DO 560 I = IPR(377) + 1, 80
          ALM(I)    = 0
          SIGALM(I) = 0
          DO 550 J = 1, 80
            CORR(I, J) = 0
            CORR(J, I) = 0
  550     CONTINUE
  560   CONTINUE
      ENDIF
      CALL PLA269 (-18)
      WRITE (LU7, 99996)
      NPAR = 0
      N0   = '0'
      N01  = 0
      N02  = 0
      N03  = 0
      SUMA = 0
      DO 580 L = 1, MAX (IPR(373), IPR(374))
        N0 = CHAR(ICHAR('0') + L)
        N1 = ' '
        N2 = '0'
        J  = 1
        DO 570 M = -L, L
          IF ((MOD(L, 2) .EQ. 0 .AND. L .LE. IPR(373)) .OR.
     1        (MOD(L, 2) .EQ. 1 .AND. L .LE. IPR(374))) THEN
            NPAR = NPAR + 1
            ALX = ABS(ALM(NPAR)) / SIGALM(NPAR)
            CALL PLA269 (1)
            WRITE (LU7, 99995) NPAR, N0, N1//N2, ALM(NPAR), ALX
            IF (ALX .GE. 1) N01 = N01 + 1
            IF (ALX .GE. 2) N02 = N02 + 1
            IF (ALX .GE. 3) N03 = N03 + 1
            SUMA = SUMA + ALX
            J = J + 1
            N2 = CHAR(ICHAR('0') + J / 2)
            IF (MOD(J, 2) .EQ. 1) THEN
              N1 = '-'
            ELSE
              N1 = '+'
            ENDIF
            N0 = ' '
          ENDIF
  570   CONTINUE
  580 CONTINUE
      IPR(377) = NPAR
      WRITE (LU7, 99989) N01, N02, N03, SUMA / IPR(377), NZERO, PAR(326)
      CALL PLA269 (0)
      WRITE (LU7, 99988)
      WRITE (LU7, 99987)
      WRITE (LU6, 99985) IPR(375), IPR(376), IPR(377),
     1                   Z1, PAR(322), ZY, PAR(323), ZA, RA
      WRITE (LU7, 99985) IPR(375), IPR(376), IPR(377),
     1                   Z1, PAR(322), ZY, PAR(323), ZA, RA
      WRITE (LU7, 99992) AIMIN, AIMAX, AMEAN, RMSDA
      IF (PAR(305) .EQ. 0) THEN
        AMAX = 1.0 / AIMIN
        IF (PAR(304) .LE. 0 .OR. AMAX .LE. 0) GOTO 620
        ASPHERE = EXP(- PAR(301) * PAR(304)) / AMAX
        IF (ASPHERE .GE. 1) GOTO 620
        IF (ASPHERE .LT. AMUR(12)) ASPHERE = AMUR(12)
        DO 600 J = 2, 12
          IF (ASPHERE .GE. AMUR(J)) GOTO 610
  600   CONTINUE
  610   X = (LOG(AMUR(J)) - LOG(ASPHERE)) /
     1      (LOG(AMUR(J)) - LOG(AMUR(J - 1)))
        PAR(305) = (FMUR(J) - X * (FMUR(J) - FMUR(J-1))) / PAR(301)
      ENDIF
      GOTO 630
  620 PAR(301) = 0.0
  630 CALL PLA191 (1, PAR(301) * PAR(305), YUNK)
      IPR(432) = 0
      IF (NAUTO .EQ. 1) THEN
        CALL PLA200 (6, 1, 0, 0)
        CALL GGIP (0.0, 0.0, 0.0, 6)
      ENDIF
      PAR(315) = 999.0
      PAR(317) = 0.0
      PAR(319) = 999.0
      PAR(320) = 0.0
      SUMN     = 0
      SUMA     = 0
      SUMASQ   = 0
      SUMV     = 0
      IPRINT   = 101
      XIMAX    = 0.0
      CALL GEN108 (LU8, 0)
      CALL GEN108 (LU9, 0)
      CALL PLA269 (-2)
      WRITE (LU7, 99994)
  660 READ  (LU8, END = 800) N, JH, JK, JL
      IPRINT = IPRINT - 1
      THETA  = GEN056 (JH, JK, JL, RBB) * PAR(17)
      IF (ABS(THETA) .GT. 1.0) THEN
        WRITE(LU6, 99977) N, JH, JK, JL, THETA
        STOP 'ASIN() PROBLEM IN MULABS'
      ENDIF
      THETA = ASIN(THETA)
      DO 780 I0 = 1, N
        READ (LU8) JH, JK, JL, YJ, SIGYJ, S0, S1
        CALL GEN055 (YLM0, S0, IPR(373), IPR(374))
        CALL GEN055 (YLM1, S1, IPR(373), IPR(374))
        A = 1
        V = 0
        DO 690 J = 1, IPR(377)
          A    = A + ALM(J) * 0.5 * (YLM0(J) + YLM1(J))
          YLMJ = 0.5 * (YLM0(J) + YLM1(J)) * SIGALM(J)
          DO 680 K = 1, IPR(377)
            YLMK = 0.5 * (YLM0(K) + YLM1(K)) * SIGALM(K)
            V    = V + CORR(J, K) * YLMJ * YLMK
  680     CONTINUE
  690   CONTINUE
        A = MAX (A, AIMIN)
        A = MIN (A, AIMAX)
        PAR(319) = MIN (PAR(319), 1.0 / A)
        PAR(320) = MAX (PAR(320), 1.0 / A)
        CALL PLA191 (0, THETA, A0)
        V    = (A0 / A)**2 * (V / A**2)
        SIGA = SQRT(V)
        A    = A0 / A
        YJ   = YJ / A
        SGYJ = SQRT(SIGYJ**2 + YJ**2 * V) / A
        WRITE (LU9) JH, JK, JL, YJ, SGYJ
        XIMAX    = MAX (XIMAX, YJ)
        PAR(315) = MIN (PAR(315), A)
        PAR(317) = MAX (PAR(317), A)
        SUMN     = SUMN   + 1
        SUMA     = SUMA   + A
        SUMASQ   = SUMASQ + A**2
        SUMV     = SUMV   + V
        IF (IPRINT .GT. 0) THEN
          IHH(I0)   = JH
          IKK(I0)   = JK
          ILL(I0)   = JL
          YI(I0)    = YJ*A
          SIGYI(I0) = SGYJ
          AII(I0)   = A
          SAA(I0)   = SIGA
          DO 770 J = 1, 3
            U0(J, I0) = S0(J)
            U1(J, I0) = S1(J)
  770     CONTINUE
        ENDIF
  780 CONTINUE
      IF (IPRINT .GT. 0) THEN
        IF (N .GE. 2) THEN
          CALL GEN053 (N, YI, INDEX)
        ELSE
          INDEX(1) = 1
        ENDIF
        CALL PLA269 (N + 1)
        WRITE (LU7, 99978)
        DO 790 I = 1, N
          J = INDEX(I)
          WRITE (LU7, 99993) IHH(J), IKK(J), ILL(J),
     1    YI(J), YI(J) / AII(J), SIGYI(J), AII(J), SAA(J),
     2    (U0(K, J), K = 1, 3), (U1(K, J), K = 1, 3)
  790   CONTINUE
      ENDIF
      GOTO 660
  800 CALL GEN108 (LU9, 1)
      CALL GEN108 (LU17, 0)
      IF (XIMAX .GT. 99999.0) THEN
        SCF = 99999.0 / XIMAX
      ELSE
        SCF = 1.0
      ENDIF
      NOUT = 0
  810 READ (LU9, END = 820) JH, JK, JL, YJ, SGYJ
      YJ   = YJ   * SCF
      SGYJ = SGYJ * SCF
      NOUT = NOUT + 1
      WRITE (LU17, 99990) JH, JK, JL, YJ, SGYJ
      GOTO 810
  820 WRITE (LU17, 99978)
      WRITE (LU6, 99991) PAR(315), PAR(317), NINP, NOUT
      CALL PLA269 (4)
      WRITE (LU7, 99991) PAR(315), PAR(317), NINP, NOUT
      IF (NAUTO .EQ. 1) GOTO 35
  830 RETURN
99999 FORMAT ('MULABS - Empirical Correction for Absorption ',
     1 'Anisotropy. [c.f. R.H. Blessing, Acta Cryst. (1995), A51,',
     2 ' 33-38]', /, 132('='), /)
99998 FORMAT (3I4, 2F8.0, 4X, 6F8.5)
99997 FORMAT (/, 'Absorption Correction Variables:', /, 132('-'),
     1 /, 'L0max  = ',I2, 23X,
     2 'Even Order Limit of Spherical Harmonic Expansion', 5X,
     3 'Y(l,m); l = 0, Lmax; m = -l, +l', /, 'L1max  = ', I2, 23X,
     4 'Odd Order Limit ', /, 'mu     =', F11.3, ' mm**-1', 8X,
     5 'Linear Absorption Coefficient', /, 'Radius = ', F10.3, ' mm',
     6 12X, 'Estimated Radius of "Equivalent" Spherical Crystal', /,
     7 'Tmin   = ', F10.3,' mm', 12X,
     8 'Estimated Minimum Crystal Thickness', /, 'Tmax   = ', F10.3,
     9 ' mm', 12X, 'Estimated Maximum Crystal Thickness', /,
     * 'Umin   = ', E10.3, 15X, 'Eigenvalue Filtering Factor')
99996 FORMAT ('Fitted Absorption Anisotropy Expansion ',
     1 'Coefficients A(l, m)', /, 59('-'), //,
     2 'FSQ(Corr) = FSQ(Meas) / A', //, 'A = A(0)/(1 + SUM(L=1,Lmax)',
     3 ' Sum(M=-L,L) A(L, M)*[0.5*[Y(L, M)(-U0) + Y(L,M)(U1)]])', //,
     4 'A(0) = A(Sphere)(mu*R, Theta)', //,
     5 'Y(l,m)(U) = Y(l,m)(X, Y, Z)', //,
     5 'Where X, Y, and Z are Components of Unit Vectors Along the',
     6 ' Reverse Incident Beam,', /,
     7 ' -U0, or the Diffracted Beam, U1, Referred to Crystal',
     8 ' Fixed Cartesian (i.e., Orthonormal) Axes.', /,
     9 ' In Other Words X, Y, and, Z are Direction Cosines of the ',
     * 'Beam Direction Vectors.', //,
     1 ' I    L  M   A(l,m)     Abs(A)/Sigma(A)', /,
     2 ' -    -  -   ------     ---------------', /,
     3 ' 0    0  0   1.0')
99995 FORMAT (I2, 4X, A, 1X, A, 2X, E10.3, F10.3)
99994 FORMAT ('  H  K  L      I(Obs)    I(obs)/A Sig[I(obs)/A]',
     1 '     A  Sig(A)   K0 and K1 Direction Cosines (Cartesian)', /,
     2 132('-'))
99993 FORMAT (3I3, 3F12.2, 2F8.4, 2(1X, 3F8.4))
99992 FORMAT (//,
     1 'Statistics of Fitted Anisotropy Correction Factors, AHI:', /,
     2 'Amin                          = ', F10.4, /,
     3 'Amax                          = ', F10.4, /,
     4 'Amean                         = ', F10.3, /,
     5 'Rmsda = <(A - Amean)**2>**1/2 = ', F10.4)
99991 FORMAT (/,
     1 ':: MIN  Transmission =', F9.5, /,
     2 ':: MAX  Transmission =', F9.5, //,
     3 '::', I8, ' Reflections on Input', /,
     4 '::', I8, ' Reflections on Output', /)
99990 FORMAT (3I4, 2F8.2)
99989 FORMAT (//,
     1 'N1   = ', I3, '  A(l,m) with abs(A)/Sigma(A) .GE. 1', /,
     2 'N2   = ', I3, '    "      "        "         .GE. 2', /,
     3 'N3   = ', I3, '    "      "        "         .GE. 3', //,
     4 '<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 ' .LT. SMIN1 = ',F5.3,' OR .GT. SMAX1 = ', F5.3, /, 'N6 =',
     3 I6, 6X, '"           "          "       "    Sigma(Ymeas',
     4 ') .LE. 0', /, 'N7 =',
     5 I6, 6X, '"           "          "       "    Ymeas .LT.',
     6 ' -4*Sigma(Ymeas)')
99982 FORMAT ('FSQMIN = ', F5.2, 20X, 'Minimum FSQ/Sigma(FSQ) ',
     1 'for Measurements Used for YLM Fit', /,
     2 'FSQMAX = ', E10.3,
     3 15X, 'Maximum FSQ for Measurements Used for YLM Fit', /,
     4 'STLMIN = ', F5.2, ' Ang**-1', 12X, 'Min Sin(Theta)/Lambda ',
     5 'For Reflections Used for YLM Fit', /,
     6 'STLMAX = ', F5.2,
     7 ' Ang**-1', 12X, 'Max Sin(Theta)/Lambda for Reflections Used',
     8 ' for YLM Fit', /,
     9 'Amin   = ', E10.3, 15X,
     * 'Minimum Expected Relative Transmission Factor', /,
     1 'Amax   = ', E10.3, 15X,
     2 'Maximum Expected Relative Transmission Factor')
99981 FORMAT (/, 4X, 'Mu = 0.0  Only Transmission Anisotropy Factors,',
     1 ' 0 < A < Amax, Amean Approximately 1, will be Calculated.')
99980 FORMAT (//,'    Radius = 0 and TMIN = 0.  only Transmission ',
     1 'Anisotropy Factors, 1 - X < A < 1 + X, <A> = 1,  will be ',
     2 'Calculated.')
99979 FORMAT (4X, 'If Radius .EQ. 0, and Tmin .GT. 0, Radius will ',
     1 'be Estimated From', /, 5X, 'A(Sphere) = A(LIMIT)/A(MAX),', /,
     2 5X, 'Where A(Limit) = Exp(-Mu*Tmin),', /,
     3 5X, 'and A(MAX) is the Maximum Transmission Anisotropy ',
     4 'Factor From the YLM Fitting.')
99978 FORMAT (1X)
99977 FORMAT (4I5, F10.3)
99976 FORMAT (A)
99975 FORMAT (':: Too Few Data to Fit Transmission Surface')
      END
      SUBROUTINE PLA188 (MODE, JB, JE)
      PARAMETER (NP4=9,NP10=16,NP12=600,NP13=500,NP17=99,NP22=256,
     1 NP38=125,NP39=30,NP45=2048)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /Q/ ICL, IFL(NP17)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /ABSPSI/ PSIS(38, 4, 10), OP(3, 3, 11), IHKLPS(4, 10),
     1 NPSI
      CHARACTER TXT(3)*3
      TXT(1) = 'Obs'
      TXT(2) = 'Cal'
      TXT(3) = 'Cor'
      DO 90 J = JB, JE
   10   CALL PLA200 (MODE, 1, 0, 0)
        CALL GGIP (13.0, 12.0, 0.0, -3)
        CALL GGIP20 (0.0, 'Psi-Scan', 8,  0.6, 1, 2, 15.3, -11.5)
        CALL GGIP20 (0.0, '0',        1, 0.25, 1, 2, 12.0,  -0.1)
        CALL GGIP20 (0.0, '270',      3, 0.25, 1, 2, -0.2, -11.3)
        CALL GGIP20 (0.0, '180',      3, 0.25, 1, 2,-12.1,   0.3)
        CALL GGIP20 (0.0, '90',       2, 0.25, 1, 2, -0.2,  11.4)
        DO 70 K = 1, 4
          CALL GGIP (0.0, FLOAT(K), 0.0, 0)
          IF (K .GT. 1) THEN
            TEMP1 = 9999999.0
            DO 20 I = 1, 36
              IF (PSIS(I, K, J) .GE. 0.01)
     1          TEMP1 = MIN (TEMP1, PSIS(I, K, J))
   20       CONTINUE
            IPERC = NINT(TEMP1 * 100.0)
            IPX = 0
            YPL = 10.5 + 1.5 - K * 0.75
            CALL GGIP20 (0.0, TXT(K - 1), 3, 0.5, -1, 2, 8.4, YPL)
            CALL GEN040 (IPERC, NQ1, IPX)
            CALL GGIP20 (0.0, NQ1, IPX, 0.5, -1, 2, 11.0, YPL)
          ENDIF
          DO 60 I = 1, 36
            PSI = PSIS(I, 1, J) / GL(5)
            XPL =  COS(PSI)
            YPL =  SIN(PSI)
            XP  = 6.0
            YP  = 6.0
            DS  = 0.1 * (K - 1)
            IF (K .GT. 1) THEN
              PSS = PSIS(I, K, J)
              IF (PSS .LT. 0.0) PSS = 0.0
              XP = PSS * XP
              YP = PSS * YP
            ENDIF
            XPL = XPL * (XP + 5.0)
            YPL = YPL * (YP + 5.0)
            IF (K .GT. 1) THEN
              IF (I .EQ. 1) THEN
                XP0 = XPL
                YP0 = YPL
                GOTO 30
              ENDIF
              CALL GGIP (XPL, YPL, 0.0, 2)
            ENDIF
   30       YPL = YPL - DS
            CALL GGIP (XPL, YPL, 0.0, 3)
            IF (K .LE. 1) THEN
              XPL = XPL * (5.0 / 11.5)
              YPL = YPL * (5.0 / 11.5)
              CALL GGIP (XPL, YPL, 0.0, 2)
            GOTO 60
            ENDIF
            DO 50 L = 1, 3, 2
              DY = DS * (2 - L)
              DO 40 M = 1, 3, 2
                DX  = DS * (2 - M) * (2 - L)
                XPL = XPL + DX
                YPL = YPL + DY
                CALL GGIP (XPL, YPL, 0.0, 2)
   40         CONTINUE
   50       CONTINUE
            YPL = YPL + DS
            CALL GGIP (XPL, YPL, 0.0, 3)
   60     CONTINUE
          IF (K .NE. 1) THEN
            CALL GGIP (XP0, YP0, 0.0, 2)
            CALL GGIP (0.0, 0.0, 0.0, 3)
          ENDIF
   70   CONTINUE
        CALL GGIP (0.0, 1.0, 0.0, 0)
        DO 80 JJ = 1, 3
          XPL = 5 + JJ * 2
          CALL GEN040 (IHKLPS(JJ, J), NQ1, IPX)
          CALL GGIP20 (0.0, NQ1, IPX, 0.5, -1, 2, XPL, -11.5)
   80   CONTINUE
        CALL GGIP (0.0, 0.0, 0.0, 3)
        CALL GGIP (0.0, 0.0,   0.0, -1)
        CALL PLA013 (0, 1)
        CALL PLA006 (0, IS)
        IF (IFL(1)(1:4) .EQ. 'PLOT') GOTO 10
        IF (IFL(1)(1:4) .EQ. 'EXIT') GOTO 100
   90 CONTINUE
  100 RETURN
      END
      SUBROUTINE PLA189
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16,
     1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NPVD=40000000,
     2 NP23=18000,NP25=99,NP29=63,NP38=125,NP39=30,NP41=200,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON // JNSC(2, NP23), VOID(NPVD)
      COMMON /ISCR/ IHLP(21)
      COMMON /ABSPSI/ PSIS(38, 4, 10), OP(3, 3, 11), IHKLPS(4, 10),
     1 NPSI
      IHO   = 0
      IKO   = 0
      ILO   = 0
      NPSI  = 0
      MPSI  = 0
      KAS   = 0
      I1    = IHLP(IHLP(1) + 1) - 13
   10 I1    = I1 + 14
      V6(1) = VOID(I1)
      V6(2) = VOID(I1 + 1)
      V6(3) = VOID(I1 + 2)
      V2(1) = VOID(I1 + 5)  * PAR(135)
      V3(1) = VOID(I1 + 6)  * PAR(135)
      V2(2) = VOID(I1 + 7)  * PAR(136)
      V3(2) = VOID(I1 + 8)  * PAR(136)
      V2(3) = VOID(I1 + 9)  * PAR(137)
      V3(3) = VOID(I1 + 10) * PAR(137)
      IH = NINT(V6(1))
      IK = NINT(V6(2))
      IL = NINT(V6(3))
      IF (IH .LT. - 999.0) GOTO 30
      CALL GEN002 (-2, ROR, V6, V8, XLNG)
      IF (IH .NE. IHO .OR. IK .NE. IKO .OR. IL .NE. ILO) THEN
        IF (NPSI .GT. 0 .AND. IHKLPS(4, NPSI) .LT. 37) THEN
          WRITE (LU6, 99999) IHO, IKO, ILO
          NPSI = NPSI - 1
          IF (IHKLPS(4, NPSI + 1) .EQ. 2) GOTO 130
        ENDIF
        IHO  = IH
        IKO  = IK
        ILO  = IL
        MPSI = 1
        IF (NPSI .EQ. 10) THEN
          WRITE (LU6, 99998)
          GOTO 30
        ENDIF
        NPSI = NPSI + 1
        IHKLPS(1, NPSI) = IH
        IHKLPS(2, NPSI) = IK
        IHKLPS(3, NPSI) = IL
        QM(1, 3) = V8(1)
        QM(2, 3) = V8(2)
        QM(3, 3) = V8(3)
        YUNKM = 2.0
        QM(1, 2) = 0.0
        QM(2, 2) = 0.0
        QM(3, 2) = 0.0
        IF (NPSI .EQ. 1) THEN
          DO 20 J = 1, 3
            YUNK = GEN009(OR(1, J), V8) /
     1             SQRT(GEN009(OR(1, J), OR(1, J)))
            IF (ABS(YUNK) .LT. YUNKM) THEN
              YUNKM = ABS(YUNK)
              KAS = J
            ENDIF
   20     CONTINUE
        ENDIF
        QM(KAS, 2) = 1.0
        CALL GEN008 (QM(1, 2), QM(1, 3), QM(1, 1), 1)
        CALL GEN008 (QM(1, 3), QM(1, 1), QM(1, 2), 1)
        CALL GEN005 (QM, DUMV)
        CALL GEN004 (DUMV, OR, OP(1, 1, NPSI))
      ENDIF
      CALL GEN002 (2, OP(1, 1, NPSI), V2, V4, XLNG)
      CALL GEN002 (2, OP(1, 1, NPSI), V3, V5, XLNG)
      IF (V5(3) .LT. 0.99999) THEN
        PHI = ATAN2(V5(2), V5(1)) * GL(5)
      ELSE
        PHI = 0.0
      ENDIF
      MPSI                = MPSI + 1
      PSIS(MPSI, 1, NPSI) = MOD(360.0 + PHI, 360.0)
      PSIS(MPSI, 2, NPSI) = VOID(I1 + 3)
      PSIS(MPSI, 3, NPSI) = VOID(I1 + 11)
      IHKLPS(4, NPSI)     = MPSI
      GOTO 10
   30 IF (NPSI .GT. 0) THEN
        DO 120 K = 1, NPSI
          MPSI = IHKLPS(4, K)
   40     ICHANGE = 0
          DO 60 J = 2, MPSI - 1
            IF (PSIS(J, 1, K) .GT. PSIS(J + 1, 1, K)) THEN
              DO 50 I = 1, 3
                CALL GEN018 (PSIS(J, I, K), PSIS(J + 1, I, K))
   50         CONTINUE
              ICHANGE = 1
            ENDIF
   60     CONTINUE
          IF (ICHANGE .NE. 0) GOTO 40
          L = 2
          PSISL = PSIS(L, 1, K)
          DO 80 J = 3, MPSI
            PSISJ = PSIS(J, 1, K)
            IF (ABS(PSISJ - PSISL) .GT. 0.05) THEN
              L = L + 1
              DO 70 I = 1, 3
                PSIS(L, I, K) = PSIS(J, I, K)
   70         CONTINUE
              PSISL = PSIS(L, 1, K)
            ENDIF
   80     CONTINUE
          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)
          DO 90 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) .GT. 0.0) THEN
              PSIS(I, 4, K) = PSIS(I, 2, K) / PSIS(I, 3, K)
            ELSE
              PSIS(I, 4, K) = 0.0
            ENDIF
   90     CONTINUE
          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)
          PMAX2 = 0.0
          PMAX3 = 0.0
          PMAX4 = 0.0
          DO 100 I = 1, MPSI
            PMAX2 = MAX (PMAX2, PSIS(I, 2, K))
            PMAX3 = MAX (PMAX3, PSIS(I, 3, K))
            PMAX4 = MAX (PMAX4, PSIS(I, 4, K))
  100     CONTINUE
          DO 110 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
  110     CONTINUE
  120   CONTINUE
      ENDIF
  130 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 PLA190
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16,
     1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NPVD=40000000,
     2 NP22=256,NP23=18000,NP25=99,NP29=63,NP38=125,NP39=30,NP41=200,
     3 NP45=2048,NP47=9,NXT1=100,NXT2=200,NXT3=100,NXT4=200)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /Q/ ICL, IFL(NP17)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON // JNSC(2, NP23), VOID(NPVD)
      COMMON /ISCR/ IHLP(21)
      COMMON /SFCLC/ NATO, NNG(3), NGRID
      COMMON /P190/ NVRR, PMILL(NXT1, 5), XTLV(7, NXT2), IDG(NXT4, 4),
     1 XYZPL(3, NXT2), CFACE(5, NXT2), IEDGE(NXT3), NFACES, NEDGE, NVER
      COMMON /ABSPSI/ PSIS(38, 4, 10), OP(3, 3, 11), IHKLPS(4, 10),
     1 NPSI
      DIMENSION IHMIN(3), IHMAX(3)
      COMMON /FNAME/ KNM(8), KXT, KNM16
      COMMON /NAMES/ NAME(8), EXTENS, PROGNM, FNLU1, FNLU16, RDTYPE
      CHARACTER NAME*80, EXTENS*9, PROGNM*28, FNLU1*80, FNLU16*80,
     1          RDTYPE*7
      COMMON /CGG11/ BCD, SBCD
      CHARACTER BCD*132, SBCD*132
      I2       = 0
      MODE     = IPR(78)
      TIM1     = CPUTIM()
      NRF      = 0
      PAR(301) = PAR(162)
      IPR(388) = 1
      IGBL(75) = 1
      IGBL(23) = 16
      IF (IPR(220) .GT. 1) THEN
        IF (IFL(2)(1:4) .EQ. 'DIRC') IPR(445) = 1
      ENDIF
      IF (MODE .EQ. -1 .OR. MODE .EQ. 4) PAR(321) = FN(1)
      IF (PAR(301) .EQ. 0.0 .OR.
     1   (MODE .EQ. -1 .AND. PAR(321) .EQ. 0.0)) THEN
        NAUTO = IGBL(25)
      ELSE
        NAUTO = 0
      ENDIF
      CALL PLA080
      CALL GEN021 (DUMV, 1)
      CALL GEN004 (DUMV, OR, OP(1, 1, 11))
      CALL PLA042 (0)
 1600 IF (NFACES .GT. 0 .AND. MODE .NE. -1) THEN
        CALL PLA269 (0)
        WRITE (LU7, 99995)
        DO 520 J = 1, NFACES
          DO 510 I = 1, 3
            V1(I) = PMILL(J, I)
  510     CONTINUE
          WRITE (LU7, 99994) J, (V1(I), I = 1, 3), PMILL(J, 5)
          PMILL(J, 4) = PMILL(J, 5) * SQRT (GEN006 (V1, RBB, V1))
  520   CONTINUE
        WRITE (LU7, 99991)
        DO 530 I = 1, NXT3
          IEDGE(I) = 0
  530   CONTINUE
        NVER = 0
        NVRR = 0
        N1   = NFACES - 1
        N2   = N1 - 1
        DO 600 K = 1, N2
          DO 540 I = 1, 3
            PAT(1, I) = PMILL(K, I)
  540     CONTINUE
          V1(1) = PMILL(K, 4)
          K1 = K + 1
          DO 590 L = K1, N1
            DO 550 I = 1, 3
              PAT(2, I) = PMILL(L, I)
  550       CONTINUE
            V1(2) = PMILL(L, 4)
            L1 = L + 1
            DO 580 M = L1, NFACES
              DO 560 I = 1, 3
                PAT(3, I) = PMILL(M, I)
  560         CONTINUE
              V1(3) = PMILL(M, 4)
              CALL GEN003 (PAT, QM, DET, 0)
              IF (DET .NE. 0.0) THEN
                CALL GEN002 (1, QM, V1, V2, XLNG)
                DO 566 J0 = 1, NFACES
                  CHECK = 0.0
                  DO 565 I0 = 1, 3
                    CHECK = CHECK + PMILL(J0, I0) * V2(I0)
  565             CONTINUE
                  IF (PMILL(J0, 4) .LT. CHECK - 0.00001) GOTO 580
  566           CONTINUE
                NVER          = NVER + 1
                IF (NVER .GT. NXT2) GOTO 652
                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
                ICHK = 1
                DO 9000 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)) .LT. 0.00001) THEN
                      ICHK = 0
                      XTLV(7, NVER) = K0
                    GOTO 9010
                  ENDIF
 9000           CONTINUE
 9010           NVRR = NVRR + ICHK
                WRITE (LU7, 99990)
     1                 NVER, NINT(XTLV(7, NVER)), V2, K, L, M
                DO 570 IPLOT = 1, 3
                  XTLV(IPLOT, NVER) = V2(IPLOT)
  570           CONTINUE
              ENDIF
  580       CONTINUE
  590     CONTINUE
  600   CONTINUE
        WRITE (LU7, 99988)
        DO 610 I = 1, NFACES
          IF (IEDGE(I) .NE. 1) THEN
            WRITE (LU7, 99989) I
            WRITE (LU6, 99989) I
            IF (NAUTO .EQ. 0) GOTO 1000
          ENDIF
  610   CONTINUE
        WRITE (LU7, 99993)
        NEDGE = 0
        NF    = NVER - 1
        DO 650 I = 1, NF
          I1 = I + 1
          DO 640 J = I1, NVER
            IO = NINT(XTLV(7, I))
            JO = NINT(XTLV(7, J))
            IF (JO .EQ. IO) GOTO 640
            IF (IO .GT. JO) CALL GEN014 (IO, JO)
            MC = 0
            DO 630 K = 1, 3
              DO 620 L = 1, 3
                IF (XTLV(K + 3, I) .EQ. XTLV(L + 3, J)) THEN
                  MC = MC + 1
                  IF (MC .EQ. 2) THEN
                    DO 9025 M = 1, NEDGE
                      IF (IDG(M, 1) .EQ. IO) THEN
                        IF (IDG(M, 2) .EQ. JO) GOTO 640
                      ENDIF
 9025               CONTINUE
                    DO 625 N = 1, 3
                      V1(N)  = XTLV(N, I) - XTLV(N, J)
  625               CONTINUE
                    EDGE = SQRT(GEN006 (V1, RAA, V1))
                    NEDGE = NEDGE + 1
                    WRITE (LU7, 99992) NEDGE, IO, JO, EDGE
                    IDG(NEDGE, 1) = IO
                    IDG(NEDGE, 2) = JO
                    IDG(NEDGE, 3) = I
                    IDG(NEDGE, 4) = J
                    GOTO 640
                  ENDIF
                ENDIF
  620         CONTINUE
  630       CONTINUE
  640     CONTINUE
  650   CONTINUE
      ENDIF
  652 IF (NAUTO .EQ. 1) THEN
        INEXT    = 0
        IGBL(23) = 16
        IF (MODE .EQ. -1 .OR. MODE .EQ. 0  .OR. MODE .EQ. 1
     1        .OR. MODE .EQ. 2 .OR.
     1      MODE .EQ. 3 .OR.  MODE .EQ. 4) THEN
          ICRT  = 0
          ANGLE = 0
          NOCLS = 0
  655     CALL PLA200 (MODE, INEXT, NOCLS, 0)
          IF (ICRT .GT. 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 .GT. 0) THEN
              ICRT  = 0
              NOCLS = 0
            ELSE
              NOCLS = -1
              CALL PLA200 (MODE, INEXT, NOCLS, 0)
              NOCLS =  1
              CALL GEN051 (1, OP(1, 1, 11), ANGLE, ICRT)
              GOTO 655
            ENDIF
          ENDIF
          CALL PLA013 (0, 1)
          CALL PLA006 (0, IS)
          IF (IFL(1)(1:3) .EQ. 'MU ') THEN
            PAR(301) = FN(1)
            IPR(441) = 0
          ELSE IF (IFL(1)(1:3) .EQ. 'MUR') THEN
            PAR(321) = FN(1)
            IPR(443) = 0
          ELSE IF (IFL(1)(1:4) .EQ. 'FACE') THEN
            IF (IPR(221) .EQ. 4) THEN
              IF (NFACES .GT. 0) THEN
                DO 1164 I = 1, NFACES
                  DO 1163 J = 1, 3
                    IF (ABS(PMILL(I, J) - FN(J)) .GT. 0.001) GOTO 1164
 1163             CONTINUE
                  GOTO 1165
 1164           CONTINUE
              ENDIF
              NFACES = NFACES + 1
              I      = NFACES
 1165         DO 1166 J = 1, 4
                PMILL(I, J) = FN(J)
 1166         CONTINUE
              PMILL(I, 5) = FN(4)
              IPR(451) = 0
              GOTO 1600
            ENDIF
          ELSE IF (IFL(1)(1:4) .EQ. 'DELF') THEN
            IF (IPR(221) .EQ. 3) THEN
              DO 1250 I = 1, NFACES
                IF (PMILL(I, 1) .EQ. FN(1) .AND.
     1              PMILL(I, 2) .EQ. FN(2) .AND.
     2              PMILL(I, 3) .EQ. FN(3)) THEN
                  IF (I .LT. NFACES) THEN
                    DO 1260 J = 1, 5
                      PMILL(I, J) = PMILL(NFACES, J)
 1260               CONTINUE
                  ENDIF
                  NFACES = NFACES - 1
                  GOTO 1600
                ENDIF
 1250         CONTINUE
            ENDIF
          ELSE IF (IFL(1)(1:4) .EQ. 'GRID') THEN
            IF (IPR(221) .EQ. 3) THEN
              IPR(421) = NINT(FN(1))
              IPR(422) = NINT(FN(2))
              IPR(423) = NINT(FN(3))
              IPR(444) = 0
            ENDIF
          ELSE IF (IFL(1)(1:4) .EQ. 'NEXT' .OR. IFL(1) .EQ. 'CALC') THEN
            IF (IPR(432) .GT. 0) GOTO 250
            IF (PAR(301) .EQ. 0.0) THEN
              IF (MODE .NE. -1 .AND. MODE .NE. 4) THEN
                CALL PLA015 (0, 46)
                GOTO 655
              ENDIF
            ENDIF
            INEXT = INEXT + 1
            GOTO 659
          ELSE IF (IFL(1)(1:4) .EQ. 'XROT') THEN
            CALL GEN051 (1, OP(1, 1, 11), FN(1) / GL(5), 1)
          ELSE IF (IFL(1)(1:4) .EQ. 'YROT') THEN
            CALL GEN051 (1, OP(1, 1, 11), FN(1) / GL(5), 2)
          ELSE IF (IFL(1)(1:4) .EQ. 'ZROT') THEN
            CALL GEN051 (1, OP(1, 1, 11), FN(1) / GL(5), 3)
          ELSE IF (IFL(1)(1:5) .EQ. 'CROTX') THEN
            ANGLE = FN(1) / GL(5)
            CALL GEN051 (1, OP(1, 1, 11), ANGLE, 1)
            ICRT = 1
          ELSE IF (IFL(1)(1:5) .EQ. 'CROTY') THEN
            ANGLE = FN(1) / GL(5)
            CALL GEN051 (1, OP(1, 1, 11), ANGLE, 2)
            ICRT = 2
          ELSE IF (IFL(1)(1:5) .EQ. 'CROTZ') THEN
            ANGLE = FN(1) / GL(5)
            CALL GEN051 (1, OP(1, 1, 11), ANGLE, 3)
            ICRT = 3
          ELSE IF (IFL(1)(1:4) .EQ. 'PLOT') THEN
            GOTO 655
          ELSE IF (IFL(1)(1:4) .EQ. 'END ') THEN
            GOTO 250
          ELSE IF (IFL(1)(1:4) .EQ. 'EXIT') THEN
            GOTO 250
          ENDIF
          GOTO 655
        ENDIF
      ENDIF
  659 IF (IPR(39) .GT. 0) THEN
        CALL PLA130 (NATO, 0)
        IF (NATO .LT. 0) STOP 'PLA190'
      ENDIF
      IF (MODE .EQ. -1) CALL PLA191 (1, PAR(321), YUNK)
      IHLP(1) = 0
      IHLP(2) = 10000
      I1      = IHLP(2) + 1
      NREF    = 0
      WRITE (LU6, 99998) NAME(4)(1:KNM(4))//'.hkl'
      IF (IGBL(37) .EQ. 0) THEN
        IPR(2) = 37
        GOTO 250
      ELSE IF (IGBL(37) .EQ. 1) THEN
        WRITE (LU6, 99987)
        I2 = IHLP(2) + 11
      ELSE IF (IGBL(37) .EQ. 2) THEN
        WRITE (LU6, 99986)
        I2 = IHLP(2) + 6
      ENDIF
      CALL GEN108 (LU16, 0)
      CALL PLA290 (0)
      GOTO 10
   11 READ (LU16, '(A)', END = 20) PRBUF
      IF (INDEX(PRBUF, '<?') .NE. 0) GOTO 20
      BACKSPACE LU16
   10 IF (IGBL(37) .EQ. 1) THEN
        READ (LU16, 99981, END = 20) (VOID(I), I = I1, I1 + 4),
     1        VOID(I1 + 13), (VOID(I), I = I1 + 5, I2)
      ELSE
        READ (LU16, 99980, END = 20) (VOID(I), I = I1, I2)
      ENDIF
      VOID(I1 + 11) = 1.0
      VOID(I1 + 12) = 0.0
      IF (NINT(VOID(I1 + 13)) .EQ. 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) .GT. 0.1) THEN
        STH = SQRT(GEN095 (PAR(391), IH, IK, IL)) * PAR(17)
        IF (IGBL(37) .NE. 2) THEN
          L = 3
          DO 2050 K = 1, 3
            L = L + 2
            V4(K) = PAR(134 + K) * VOID(I1 + L)
            V5(K) = PAR(134 + K) * VOID(I1 + L + 1)
 2050     CONTINUE
          TPRIM = GEN009 (VOID(I1), V4)
          TDIFF = GEN009 (VOID(I1), V5)
          DUMMY = GEN006 (V4, RAA, V5) /
     1            SQRT(GEN006 (V4, RAA, V4) * GEN006 (V5, RAA, V5))
          IF (ABS(DUMMY) .GT. 1.0) DUMMY = SIGN(1.0, DUMMY)
          IF (ABS(STH) .GT. 0.99999999)
     1        WRITE (LU6,'(''|SIN(THETA)| > 1.0 ?'', 3I5, F10.5, /)')
     2            IH, IK, IL, STH
          TH1 = ASIN(STH) * GL(5)
          TH2 = 90.0 - ACOS(DUMMY) * GL(5) / 2.0
          CALL PLA291 (TPRIM, TDIFF, TH1, TH2, ITEST)
          IF (ITEST .EQ. 1) GOTO 20
        ELSE
          CALL GEN106 (VOID(I1), STH, VOID(I1 + 5) / GL(5),
     1                 RAA, RBB, V6, V8, PAR(135))
          L = 3
          DO 2000 K = 1, 3
            L = L + 2
            VOID(I1 + L)     = V6(K)
            VOID(I1 + L + 1) = V8(K)
 2000     CONTINUE
        ENDIF
        NREF = NREF + 1
        IF (MODE .EQ. -1) THEN
          CALL PLA191 (0, STH, ASTAR)
          VOID (I2 + 1) = ASTAR
        ENDIF
        IF (IPR(39) .GT. 0) THEN
          ACAL = 0
          BCAL = 0
          CALL PLA131 (IH, IK, IL, ACAL, BCAL, ACALA, BCALA, DUM)
          ACAL = ACAL + ACALA
          BCAL = BCAL + BCALA
          VOID(I2 + 2) = ACAL**2 + BCAL**2
        ENDIF
        I1 = I1 + 14
        IF (IGBL(37) .EQ. 1) THEN
          I2 = I1 + 10
        ELSE
          I2 = I1 + 5
        ENDIF
      ELSE
        IF (VOID(I1 - 1) .GT. -1000.0) THEN
          VOID (I1) = - 1000.0
          IHLP(1)   = IHLP(1) + 1
          IHLP(IHLP(1) + 2) = I1
          I1        = I1 + 1
          I2        = I1 + 10
        ENDIF
      ENDIF
      GOTO 11
   20 IF (NREF .EQ. 0) THEN
        IPR(2) = 39
        GOTO 250
      ENDIF
      IPR(383) = NREF
      IF (IGBL(37) .EQ. 1) CALL PLA290 (-1)
      IF (VOID(I1 - 1) .GT. -1000.0) THEN
        VOID (I1) = - 1000.0
        IHLP(1)   = IHLP(1) + 1
      ENDIF
      IF (MODE .EQ. 1) THEN
        CALL PLA193 (IHLP(1) + 1)
        CALL PLA189
        IF (NPSI .LE. 0) THEN
          IPR(2) = 38
        ELSE
          CALL PLA188 (MODE, 1, NPSI)
        ENDIF
        IF (NAUTO .EQ. 1) GOTO 652
        GOTO 250
      ELSE IF (MODE .EQ. 2) THEN
        IF (IGBL(25) .EQ. 0 .AND. PAR(301) .EQ. 0.0) THEN
          IPR(2) = 35
          GOTO 250
        ENDIF
        CALL PLA192 (2)
      ELSE IF (MODE .EQ. 3) THEN
        IF (IGBL(25) .EQ. 0 .AND. PAR(301) .EQ. 0.0) THEN
          IPR(2) = 35
          GOTO 250
        ENDIF
        CALL PLA193 (2)
      ELSE IF (MODE .EQ. 4) THEN
        IF (IHLP(1) .LE. 1) THEN
          IPR(2) = 38
          GOTO 250
        ENDIF
        CALL PLA191 (1, PAR(321), YUNK)
        CALL PLA189
        IF (NPSI .LE. 0) THEN
          IPR(2) = 38
          GOTO 250
        ENDIF
        CALL PLA269 (0)
        WRITE (LU7, 99997) NPSI
        ILP   = 1
        I1    = IHLP(2) - 13
  400   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 .LT. - 999) THEN
          ILP = ILP + 1
          IF (ILP .GT. IHLP(1)) THEN
            GOTO 500
          ELSE
            I1 = I1 - 13
            GOTO 400
          ENDIF
        ENDIF
        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 750 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) .LT. 0.99999) THEN
            PHI1 = MOD(ATAN2 (V4(2), V4(1)) * GL(5) + 360.0, 360.0)
          ELSE
            PHI1 = 0.0
          ENDIF
          IPH1 = INT(PHI1 / 10.0)
          IF (V5(3) .LT. 0.99999) THEN
            PHI2 = MOD(ATAN2 (V5(2), V5(1)) * GL(5) + 360.0, 360.0)
          ELSE
            PHI2 = 0.0
          ENDIF
          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)
  750   CONTINUE
        TT = TT / NPSI
        CALL PLA191 (0, THETA, ACOR)
        VOID(I1 + 11) = TT * ACOR
        WRITE (LU7, 99996) IH, IK, IL, XINT, SINT, TT, XINT / TT,
     1     (DBUF(J), J = 1, NPSI)
        GOTO 400
  500   CALL PLA189
        CALL PLA188 (MODE, 1, NPSI)
      ELSE IF (MODE .EQ. 5) THEN
      ENDIF
      FMAX = 0.0
      SUMT = 0.0
      TMAX = 0.0
      TMIN = 1.0
      I    = IHLP(2) - 13
   90 I    = I + 14
      IH   = NINT(VOID(I))
      IF (IH .NE. -1000) THEN
        TT   = VOID(I + 11)
        FMAX = MAX (FMAX, VOID(I + 3) / TT)
        SUMT = SUMT + TT
        IF (TT .GT. TMAX) THEN
          TMAX = TT
          DO 100 J = 1, 3
            IHMAX(J) = NINT(VOID(I + J - 1))
  100     CONTINUE
        ENDIF
        IF (TT .LT. TMIN) THEN
          TMIN = TT
          DO 110 J = 1, 3
            IHMIN(J) = NINT(VOID(I + J - 1))
  110     CONTINUE
        ENDIF
        GOTO 90
      ENDIF
      IF (FMAX .GT. 9999.0) THEN
        FSCAL = 9999.0 / FMAX
      ELSE
        FSCAL = 1.0
      ENDIF
      CALL GEN108 (LU17, 0)
      I  = IHLP(2) - 13
  200 I  = I + 14
      IH = NINT(VOID(I))
      IF (IH .NE. -1000) THEN
        NRF  = NRF + 1
        IK   = NINT(VOID(I + 1))
        IL   = NINT(VOID(I + 2))
        RELI = FSCAL * VOID(I + 3) / VOID(I + 11)
        SIGI = FSCAL * VOID(I + 4) / VOID(I + 11)
        IF (MODE .EQ. 5 .OR. IPR(445) .EQ. 1) THEN
          WRITE (LU17, 99985) IH, IK, IL, RELI, SIGI,
     1           NINT(VOID(I + 13)), (VOID(I + K), K = 5, 10)
        ELSE
          WRITE (LU17, 99984) IH, IK, IL, RELI, SIGI, NINT(VOID(I + 13))
        ENDIF
        GOTO 200
      ENDIF
      WRITE (LU17, '(1X)')
      IF (NRF .GT. 0) THEN
        REANAS = SUMT / FLOAT(NRF)
        TIMAV  = (CPUTIM() - TIM1) / NRF
        IF (MODE .EQ. 4) THEN
          WRITE (LU6, 99982) NPSI
          WRITE (LU7, 99982) NPSI
        ENDIF
        PAR(315) = TMIN
        PAR(317) = TMAX
        IPR(432) = NRF
        WRITE (LU6, 99999) IPR(383), IPR(432), TMIN, IHMIN, TMAX,
     1                     IHMAX, REANAS, TIMAV
        WRITE (LU7, 99999) IPR(383), IPR(432), TMIN, IHMIN, TMAX,
     1                     IHMAX, REANAS, TIMAV
      ENDIF
      IF (NAUTO .EQ. 1) GOTO 652
  250 IPR(432) = NRF
 1000 RETURN
99999 FORMAT (/,
     1 '::', I8, ' Reflections on Input', /,
     2 '::', I8, ' Reflections Processed', //,
     3 ':: MIN  Transmission =', F9.5, ' for the ', 2(I3, ','), I3, /,
     4 ':: MAX  Transmission =', F9.5, ' for the ', 2(I3, ','), I3, /,
     5 ':: MEAN Transmission =', F9.5, //, ':: Average Time per',
     6 ' Reflection =', F8.5, ' Seconds', /)
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)
99995 FORMAT ('Crystal Face Defining Data', /, 26('='), //,
     1 '   Nr      h       k       l',
     2  10X, 'Distance(mm)', /, 80('-'))
99994 FORMAT (I5, 1X, 3F8.2, F15.3)
99993 FORMAT (/, '   NR      EDGE   LENGTH (mm)', /, 30('='), /)
99992 FORMAT (3I5, F10.3)
99991 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('-'))
99990 FORMAT (I4, ' =', I4, 3F10.5, 2X, 3I4)
99989 FORMAT (//, ':: Note >> FACE', I3, '  has NO Intersection', /)
99988 FORMAT (1X)
99987 FORMAT ('N: H K L I SIG(I) Direction Cosine Data Assumed', /)
99986 FORMAT ('N: H K L I SIG(I) Psi-Data Assumed', /)
99985 FORMAT (3I4, 2F8.2, I4, 6F8.5)
99984 FORMAT (3I4, 2F8.2, I4)
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)
      END
      SUBROUTINE PLA191 (MODE, VALUE, ASTER)
      COMMON /SABS/ TMC(7), RMF(5, 7), X(6)
      DIMENSION A(6, 6), D(6)
      RAD = ATAN(1.0) / 45.0
      IF (MODE .EQ. 1) THEN
        DO 20 J = 1, 7
          Y = 0.0
          DO 10 I = 1, 5
            Y = Y + RMF(I, J) * VALUE ** I
   10     CONTINUE
          TMC(J) = EXP(-Y)
   20   CONTINUE
        DO 40 K = 1, 6
          STH  = SIN(K * 15.0 * RAD)
          D(K) = TMC(K + 1) - TMC(1)
          DO 30 I = 1, 6
            A(K, I) = STH**(2 * I)
   30     CONTINUE
   40   CONTINUE
        CALL GEN057 (A, X, D, 6)
      ELSE
        ASTER = TMC(1)
        DO 50 J = 1, 6
          K = 2 * J
          ASTER = ASTER + X(J) * VALUE ** K
   50   CONTINUE
      ENDIF
      RETURN
      END
      SUBROUTINE PLA192 (NBEG)
      PARAMETER (NP12=600,NP13=500,NP17=99,NPVD=40000000,NP23=18000,
     1 NP38=125,NP39=30,NXT1=100,NXT2=200,NXT3=100,NXT4=200)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /P190/ NVRR, PMILL(NXT1, 5), XTLV(7, NXT2), IDG(NXT4, 4),
     1 XYZPL(3, NXT2), CFACE(5, NXT2), IEDGE(NXT3), NFACES, NEDGE, NVER
      DIMENSION COSIN(NXT1), COSOUT(NXT1), NIN(NXT1), NOUTT(NXT1),
     1 SD(3), SOD(3), BBOUND(2, 2), DBOUND(2, 2), XYZ(3), HKL(3),
     2 GRD(4), TEMP(3)
      COMMON // JNSC(2, NP23), VOID(NPVD)
      COMMON /ISCR/ IHLP(21)
      DIMENSION IGA(3), GAUSS(500, 2)
      XMU    = PAR(301)
      NIA    = IPR(421)
      NIB    = IPR(422)
      NIC    = IPR(423)
      NPOINT = 0
      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 10 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))
   10 CONTINUE
      JGRD  = NPVD
      VOID(JGRD)     = XMIN
      VOID(JGRD - 1) = XMAX
      JGRD           = JGRD - 1
      IF (NIA .EQ. 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
      ENDIF
      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 110 NPA = 1, NIA
         LL = IGA(1) + NPA
         XYZ(1) = XMIN + (XMAX - XMIN) * GAUSS(LL, 1)
         R1 = GAUSS(LL, 2) * (XMAX - XMIN)
         YMIN =  99999.0
         YMAX = -99999.0
         N1   = NFACES - 1
         DO 50 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 40 L = K1, NFACES
             BBOUND(2, 1) = PMILL(L, 2)
             BBOUND(2, 2) = PMILL(L, 3)
             DET = BBOUND(1, 1) * BBOUND(2, 2)
     1           - BBOUND(1, 2) * BBOUND(2, 1)
             IF (DET .NE. 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 30 J0 = 1, NFACES
                 CHECK = 0.0
                 DO 20 I0 = 1, 3
                   CHECK = CHECK + PMILL(J0, I0) * XYZ(I0)
   20            CONTINUE
                 IF (PMILL(J0, 4) .LT. CHECK - 0.0000001) GOTO 40
   30          CONTINUE
               YMAX = MAX (YMAX, XYZ(2))
               YMIN = MIN (YMIN, XYZ(2))
             ENDIF
   40      CONTINUE
   50    CONTINUE
         VOID(JGRD - 1) = YMIN
         VOID(JGRD - 2) = YMAX
         JGRD           = JGRD - 2
         DO 100 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
            DO 80 I = 1, NFACES
               IF (PMILL(I, 3) .NE. 0) THEN
                 XYZ(3) = (PMILL(I, 4) - XYZ(1) * PMILL(I, 1)
     1                  - XYZ(2) * PMILL(I, 2)) / PMILL(I, 3)
                 DO 70 J0 = 1, NFACES
                   CHECK = 0.0
                   DO 60 I0 = 1, 3
                     CHECK = CHECK + PMILL(J0, I0) * XYZ(I0)
   60              CONTINUE
                   IF (PMILL(J0, 4) .LT. CHECK - 0.0000001) GOTO 80
   70            CONTINUE
                 ZMAX = MAX (ZMAX, XYZ(3))
                 ZMIN = MIN (ZMIN, XYZ(3))
               ENDIF
   80       CONTINUE
            VOID(JGRD - 1) = ZMIN
            VOID(JGRD - 2) = ZMAX
            JGRD           = JGRD - 2
            DELTAZ = ZMAX - ZMIN
            DO 90 NPC = 1, NIC
              NPOINT = NPOINT + 1
              JJ = IGA(3) + NPC
              VOLUME = VOLUME + GAUSS(JJ, 2) * R2 * DELTAZ
   90       CONTINUE
  100    CONTINUE
  110 CONTINUE
      WRITE (LU7, 99997) PAR(301), NIA, NIB, NIC, NPOINT,
     1                   VOLUME * PAR(98)
      NCOR = 0
      I1     = IHLP(NBEG) - 13
  120 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) .LT. - 999.0) GOTO 230
      INTN   = NINT(RINTN)
      DO 130 I = 1, 3
        SOD(I) = SOD(I) * PAR(134 + I)
        SD(I)  = SD(I)  * PAR(134 + I)
  130 CONTINUE
      NCOR = NCOR + 1
      IF (NCOR .EQ. 1) THEN
        CALL PLA269 (0)
        CALL PLA269 (2)
        WRITE (LU7, 99999)
      ENDIF
      TRANSM = 0.0
      TBAR   = 0
      MO     = 1
      LO     = 1
      DO 150 K = 1, NFACES
        COSIN(MO)  = 0.0
        COSOUT(LO) = 0.0
        DO 140 I = 1, 3
          COSIN(MO)  = COSIN(MO)  + SOD(I) * PMILL(K, I)
          COSOUT(LO) = COSOUT(LO) + SD(I)  * PMILL(K, I)
  140   CONTINUE
        IF (COSIN(MO) .GT. 0.0) THEN
          NIN(MO) = K
          MO      = MO + 1
        ENDIF
        IF (COSOUT(LO) .GT. 0.0) THEN
          NOUTT(LO) = K
          LO        = LO + 1
        ENDIF
  150 CONTINUE
      MO = MO - 1
      LO = LO - 1
      JGRD = NPVD
      XMIN = VOID(JGRD)
      XMAX = VOID(JGRD - 1)
      JGRD = JGRD - 1
      DO 220 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 210 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 200 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 170 K = 1, MO
              RDOTN = 0.0
              NMO   = NIN(K)
              DO 160 I = 1, 3
                RDOTN = RDOTN + GRD(I) * PMILL(NMO, I)
  160         CONTINUE
              GAB = (PMILL(NMO, 4) - RDOTN) / COSIN(K)
              GK = MIN (GK, GAB)
  170       CONTINUE
            DO 190 K = 1, LO
              RDOTN = 0.0
              NLO = NOUTT(K)
              DO 180 I = 1, 3
                RDOTN = RDOTN + GRD(I) * PMILL(NLO, I)
  180         CONTINUE
              HAB = (PMILL(NLO, 4) - RDOTN) / COSOUT(K)
              HK = MIN (HK, HAB)
  190       CONTINUE
            PXTL   = GK + HK
            AXTL   = EXP (-XMU * PXTL)
            TXTL   = PXTL * AXTL
            TBAR   = TBAR   + GRD(4) * TXTL
            TRANSM = TRANSM + GRD(4) * AXTL
  200     CONTINUE
  210   CONTINUE
  220 CONTINUE
      ASTAR = VOLUME / TRANSM
      TBAR  = TBAR   / VOLUME
      TBMU  = ALOG(ASTAR)
      ICOR   = NINT(RINTN * ASTAR)
      TRANSM = 1.0 / ASTAR
      ISIGMA = NINT(SIGMA * ASTAR)
      VOID(I1 + 11) = TRANSM
      IF (IGBL(57) .GT. 0) THEN
        CALL PLA269 (1)
        WRITE (LU7, 99998) (NINT(HKL(I)), I = 1, 3), TRANSM, TBMU,
     1         INTN, NINT(SIGMA), ICOR, ISIGMA, TBAR
      ENDIF
      GOTO 120
  230 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.')
      END
      SUBROUTINE PLA193 (NBEG)
C * DE MEULENAER & TOMPA ABSORPTION CORRECTION (ADAPTED FROM ALCOCK VERSI
      PARAMETER (NP12=600,NP13=500,NP17=99,NPVD=40000000, NP23=18000,
     1 NP38=125,NP39=30,NTMP=4000,NXT1=100,NXT2=200,NXT3=100,NXT4=200)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /XYDATA/ RSTK(NTMP), ISTK(NTMP), AMU, TT, VT, CX(2), CY(2),
     1 CZ(2), D(12), DEV(2), VMUL, IL, NC, ND, NF, NG, IB(4), IE(2),
     2 JI(2), JT(2), IENPL, ISTNV, IENNV, ISTED, IENED, ISTVT, IENVT,
     3 IENPT, ISTNP, IENNP, ISTTR, IENTR, MAXUTL, JNK, JNK1, JNK3,
     4 IEX, ISK, ISK2
      COMMON /P190/ NVRR, PMILL(NXT1, 5), XTLV(7, NXT2), IDG(NXT4, 4),
     1 XYZPL(3, NXT2), CFACE(5, NXT2), IEDGE(NXT3), NFACES, NEDGE, NVER
      COMMON // JNSC(2, NP23), VOID(NPVD)
      COMMON /ISCR/ IHLP(21)
      REAL VOID, PAR, FN, GL, XYZPL, CFACE, PMILL, XTLV
      CHARACTER ITX*8
      NMEM   = 0
      RAD    = DBLE(GL(5))
      MAXUTL = 0
      AMU    = DBLE(PAR(301))
      CALL PLA269 (0)
      WRITE (LU7, 99999)
      WRITE (LU6, 99999)
      WRITE (LU7, 99998) AMU
      WRITE (LU6, 99998) AMU
      SINA  = SIN(DBLE(PAR(244)) / RAD)
      COSA  = COS(DBLE(PAR(244)) / RAD)
      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
      IENPL = - 5
      DO 10 IN = 1, NFACES
        IENPL = IENPL + 6
        XH    = DBLE(PMILL(IN, 1))
        XK    = DBLE(PMILL(IN, 2))
        XL    = DBLE(PMILL(IN, 3))
        DA    = DBLE(PMILL(IN, 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 ))
        IF (ABS(SINPBS) .LT. 1.0D-6) THEN
          CPY = CPBS * SINGS
        ELSE
          CPD = (CPX - COSGS * CPBS) / (SINPBS * SINGS)
          CPY = CPBS * SINGS - SINPBS * COSGS * CPD
        ENDIF
        RSTK(IENPL    ) = CPX
        RSTK(IENPL + 1) = CPY
        RSTK(IENPL + 2) = CPZ
        RSTK(IENPL + 3) = DA
   10 CONTINUE
      NPP   = NTMP
      ISTNV = IENPL + 6
      INV   = ISTNV - 10
      NFMX  = IENPL
      NFMX1 = IENPL - 6
      NFMX2 = NFMX1 - 6
      DO 70 I = 1, NFMX2, 6
        AI  = RSTK(I)
        BI  = RSTK(I + 1)
        CI  = RSTK(I + 2)
        DI  = RSTK(I + 3)
        IP1 = I + 6
        DO 60 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 .NE. 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
            DO 50 K = JP1, NFMX, 6
              DEN = RSTK(K) * AIJ + RSTK(K + 1) * BIJ
     1            + RSTK(K + 2) * CIJ
              IF (DEN .NE. 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
                DO 40 NU = 1, NFMX, 6
                  IF (NU .NE. I .AND. NU .NE. J .AND. NU .NE. K) THEN
                    DIST = RSTK(NU + 3) - RSTK(NU) * XP
     1                   - RSTK(NU + 1) * YP - RSTK(NU + 2) * ZP
                    IF (DIST .GT. 1.0D-7) THEN
                      GOTO 40
                    ELSE IF (DIST .EQ. 1.0D-7) THEN
                      GOTO 30
                    ENDIF
                    IF (DIST .LT. -1.E-7) GOTO 50
   30               IF (NU .LE. K) GOTO 50
                    NF = NF + 1
                    ISTK(NPP - NF) = NU
                  ENDIF
   40           CONTINUE
                ISTK(NPP)     = I
                ISTK(NPP - 1) = J
                ISTK(NPP - 2) = K
                INV           = INV + 10
                RSTK(INV)     = XP
                RSTK(INV + 1) = YP
                RSTK(INV + 2) = ZP
                ISTK(INV + 4) = ISTNV + NTMP - NPP
                ISTK(INV + 5) = ISTK(INV + 4) + NF
                NPP           = NPP - NF - 1
              ENDIF
   50       CONTINUE
          ENDIF
   60   CONTINUE
   70 CONTINUE
      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
   80 I = I - 10
      J = J - 10
      IF (I - ISTVT .GE. -1) THEN
        DO 90 K = 1, 3
          RSTK(I + K) = RSTK(J + K)
   90   CONTINUE
        ISTK(I + 5) = ISTK(J + 5)
        ISTK(I + 6) = ISTK(J + 6)
        GOTO 80
      ENDIF
      J = NTMP
      DO 100 I = ISTNV, IENNV
        ISTK(I) = ISTK(J)
        J = J - 1
  100 CONTINUE
      INED = ISTED - 6
      NFMX = IENVT - 10
      II = 0
      DO 140 I = ISTVT, NFMX, 10
        II = II + 1
        NFMX1 = ISTK(I + 4)
        NFMX2 = ISTK(I + 5)
        JNK   = I + 10
        JJ    = II
        DO 130 J = JNK, IENVT, 10
          JJ  = JJ + 1
          NPP = ISTK(J + 4)
          NF  = ISTK(J + 5)
          M   = 0
          DO 120 K = NFMX1, NFMX2
            JUN1 = ISTK(K)
            DO 110 L = NPP, NF
              JUN11 = ISTK(L)
              IF (JUN1 .EQ. JUN11) THEN
                IF (M .LE. 0) THEN
                  M = 1
                  NMEM = JUN11
                ELSE
                  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
                  GOTO 130
                ENDIF
              ENDIF
  110       CONTINUE
  120     CONTINUE
  130   CONTINUE
  140 CONTINUE
      IF (INED .NE. IENED) THEN
        WRITE (LU6, 99997)
        WRITE (LU7, 99997)
        IENPL = 0
      ENDIF
      IF (IENPL .GT. 0) THEN
        VM = 0.0D+0
        RM = 0.0D+0
        DO 150 I = 1, 3
          D(I + 3) = 0.0D+0
          D(I)     = 0.0D+0
  150   CONTINUE
        DO 170 I = ISTVT, IENVT, 10
          DO 160 J = 1, 3
            VT = RSTK(I + J - 1)
            IF (D(J) .GT. VT) THEN
              D(J) = VT
            ELSE IF (D(3 + J) .LT. VT) THEN
              D(3 + J) = VT
            ENDIF
  160     CONTINUE
  170   CONTINUE
        DO 180 I = 1, 3
          VT = D(3 + I) - D(I)
          IF (RM .LT.  VT)       RM =  VT
          IF (VM .LT.  D(3 + I)) VM =  D(3 + I)
          IF (VM .LT. -D(I))     VM = -D(I)
  180   CONTINUE
        VMUL = 1.0D+0 / VM
        DO 190 I = 1, IENPL, 6
          RSTK(I + 3) = RSTK(I + 3) * VMUL
  190   CONTINUE
        JNK = ISTVT - 1
        DO 210 I = JNK, IENVT, 10
          DO 200 J = 1, 3
            RSTK(I + J) = RSTK(I + J) * VMUL
  200     CONTINUE
  210   CONTINUE
        VOLM = 1.0D+0 / (6.0D+0 * VMUL * VMUL * VMUL)
        CALL PLA194 (1)
        VT = VT * VOLM
        TT = 1.0D+0
        WRITE (LU7, 99993) VT
        VA  = 0.1D-2 * VT
        VV1 = VT - VA
        VV2 = VT + VA
        AMU = AMU / VMUL
        CALL PLA269 (0)
        IF (IGBL(57) .GT. 0) THEN
          CALL PLA269 (2)
          WRITE (LU7, 99995)
        ENDIF
        I1   = IHLP(NBEG) - 13
  220   I1   = I1 + 14
        JA   = NINT(VOID(I1))
        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))
        IF (JA .EQ. - 1000) GOTO 260
        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) / (SINBS * SINA)
        CZ(2) = -(C6 - C2 * COSBS + C4 * SINBS * COSA) / (SINBS * SINA)
        IERR  = 2
        CALL PLA194 (2)
        VT = VT * VOLM
        IF (TT .GT. 0.9995) THEN
          TT = 1.0D+0
          IF (TT .LT. 1.0) THEN
            IF (TT .GT. 0) THEN
              IF (VT .LE. VV2) THEN
                IF (VV1 .LE. VT) GOTO 230
              ENDIF
              IF (TT .GT. 0.999) THEN
                TT = 1.0D+0
                IERR = 2
              ELSE
                IERR = 1
                ITX = 'VOLUME  '
                GOTO 230
              ENDIF
            ENDIF
          ENDIF
          IF (TT .GT. 0.999) THEN
            TT = 1.0D+0
            IERR = 2
          ELSE
            ITX = 'TRANS.'
            TT  = ABS(TT)
            IF (TT .LT. 0.01) TT = 0.1D-1
            IERR = 1
          ENDIF
        ENDIF
  230   IF (IERR .EQ. 1) THEN
          GOTO 240
        ELSE IF (IERR .EQ. 2) THEN
          GOTO 250
        ENDIF
  240   CALL PLA269 (1)
        WRITE (LU7, 99992) JA, KA, LA, TT, VT, ITX
  250   FREL = FREL / TT
        SIGF = SIGF / TT
        VOID (I1 + 11) = SNGL(TT)
        IF (IGBL(57) .GT. 0) THEN
          CALL PLA269 (1)
          WRITE (LU7, 99994) JA, KA, LA, FREL, SIGF, TT, VT
        ENDIF
        GOTO 220
  260   WRITE (LU7, 99996) MAXUTL
      ENDIF
      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, 'F**2', 5X, 'Sig(F**2)',
     1        5X, 'Transmission', 6X, 'Volume (mm3)', /,
     2        '   -   -   -', 7X, '----', 5X, 9('-'), 5X,
     3        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 PLA194 (IZ)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (NTMP=4000)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /XYDATA/ RSTK(NTMP), ISTK(NTMP), AMU, TT, VT, CX(2), CY(2),
     1 CZ(2), D(12), DEV(2), VMUL, IL, NC, ND, NF, NG, IB(4), IE(2),
     2 JI(2), JT(2), IENPL, ISTNV, IENNV, ISTED, IENED, ISTVT, IENVT,
     3 IENPT, ISTNP, IENNP, ISTTR, IENTR, MAXUTL, JNK, JNK1, JNK3,
     4 IEX, ISK, ISK2
      DIMENSION NE(6)
      COMMON /SAV/ VZ,FLIM
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 ASSIGNMS
      IF (IZ .EQ. 1) THEN
        IEX   = 1
        ISK   = 1
        ISK2  = 1
        VT    = 0.0D+0
        IENPT = IENVT
        ISTNP = IENVT + 10
        IENNP = ISTNP - 1
        DO 10 I = ISTVT, IENVT, 10
          IENNP       = IENNP + 1
          ISTK(IENNP) = I
   10   CONTINUE
        GOTO 390
      ENDIF
      DO 20 I = 1, 6
        NE(I) = 0
   20 CONTINUE
      DE2    = 0
      DEV(2) = 0
      VT     = 0.0D+0
      TT     = 0
      IL     = 1
      IENPT  = IENVT
      DO 50 IP = 1, 2
        DO 30 I = 1, IENPL, 6
          DEN = RSTK(I) * CX(IP) + RSTK(I + 1) * CY(IP)
     1        + RSTK(I + 2) * CZ(IP)
          IF (DEN .LT. 0.0) THEN
            ISTK(I + IP + 3) = 1
          ELSE
            ISTK(I + IP + 3) = -1
          ENDIF
   30   CONTINUE
        DO 40 I = ISTED, IENED, 6
          JA  = ISTK(I)
          JB  = ISTK(I + 1)
          IND = ISTK(JA + IP + 3) + ISTK(JB + IP + 3)
          IF (IND .LT. 0) THEN
            ISTK(I + IP + 3) = -1
          ELSE IF (IND .EQ. 0) THEN
            ISTK(I + IP + 3) = 0
          ELSE
            ISTK(I + IP + 3) = 1
          ENDIF
  40    CONTINUE
  50  CONTINUE
      IENPT = IENVT
      DO 90 IP = 1, 2
        JNK1 = IP
        IQ   = 3 - IP
        DO 80 J = ISTVT, IENVT, 10
          JNK = J
          ISTK(J + IP + 5) = 0
          ISTK(J + IP + 7) = 0
          IF (IP .EQ. 1) RSTK(J + 3) = 0.0D+0
          M  = ISTK(J + 4)
          LA = ISTK(J + 5)
          LB = ISTK(M)
          NC = ISTK(LB + IP + 3)
          M = M + 1
          DO 60 J5 = M, LA
            LB = ISTK(J5)
            IF (NC .NE. ISTK(LB + IP + 3)) GOTO 80
  60      CONTINUE
          IF (NC .LT. 0) THEN
            ND = 1
            CALL PLA195 (DEN)
            RSTK(J + 3) = RSTK(J + 3) + DEN * AMU
            ISTK(J + IP + 7) = NC
          ELSE IF (NC .EQ. 0) THEN
            GOTO 90
          ELSE
            ND = -1
            CALL PLA195 (DEN)
            NE(IL) = NE(IL) + 1
            IENPT  = IENPT + 10
            ISTK(J + IP + 5) = IENPT
            ISTK(IENPT + 4) = NC
            ISTK(IENPT + 6) = IL
            ISTK(IENPT + 5) = 0
            ISTK(IENPT + 7) = 0
            ISTK(IENPT + 8) = 0
            ISTK(IENPT + 9) = 0
            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
            IF (ISTK(NC + IQ + 3) .EQ. -1) THEN
              ND   = 1
              JNK  = IENPT
              JNK1 = IQ
              CALL PLA195 (DEN)
              JNK1 = IP
              JNK  = J
              ISTK(IENPT + 5) = NC
              RSTK(IENPT + 3) = (FRP + DEN) * AMU
            ENDIF
            IL = IL + 2
            DO 70 K = ISTED, IENED, 6
              IF (ISTK(K + IQ + 3) .EQ. 1) THEN
                IB(1) = J
                IB(2) = J
                IB(3) = ISTK(K + 2)
                IB(4) = ISTK(K + 3)
                CALL PLA196
                D(10) = - D(3)
                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)
                CALL PLA198 (D, 3)
                NC = 1
                IF (ABS(D(4)) .GT. 1.D-9) THEN
                  DEN = D(3) / D(4)
                  IF (DEN .GE. - 0.00001) THEN
                    IF (1.00001 .GE. DEN) THEN
                      NC = 0
                      IF (D(1) .NE. 0) THEN
                        DEN = D(1) / D(4)
                        IF (DEN .GT. 0) THEN
                          IF (DEN .LE. FRP) THEN
                            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
                            ISTK(IENPT + 4) = K
                            ISTK(IENPT + 5) = 0
                            ISTK(IENPT + 6) = IL
                            ISTK(IENPT + 7) = 0
                            ISTK(IENPT + 8) = 0
                            ISTK(IENPT + 9) = 0
                          ENDIF
                        ENDIF
                      ENDIF
                    ENDIF
                  ENDIF
                ENDIF
              ENDIF
  70        CONTINUE
            IL = IL - 2
          ENDIF
  80    CONTINUE
        IL = IL + 1
  90  CONTINUE
      ND = 1
      IL = IL + 2
      DO 120 IP = 1, 2
        JI(IP) = IENPT + 10
        IQ     = 3 - IP
        JNK1   = IQ
        DO 110 K = ISTED, IENED, 6
          IF (ISTK(K + IP + 3) .EQ. 1) THEN
            DO 100 K5 = ISTED, IENED, 6
              IF (ISTK(K5 + IP + 3) .EQ. -1) THEN
                IB(1) = ISTK(K  + 2)
                IB(2) = ISTK(K  + 3)
                IB(3) = ISTK(K5 + 2)
                IB(4) = ISTK(K5 + 3)
                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 PLA198 (D, 3)
                NC = 1
                IF (ABS(D(4)) .GT. 1.D-9) THEN
                  DEN = D(1) / D(4)
                  IF (DEN .GE. - 0.00001) THEN
                    IF (1.00001 .GE. DEN) NC = 0
                  ENDIF
                ENDIF
                IF (NC .EQ. 0) THEN
                  NC = 1
                  IF (ABS(D(4)) .GT. 1.D-9) THEN
                    TX = D(2) / D(4)
                    IF (TX .GE. - 0.00001) THEN
                      IF (1.00001 .GE. TX) NC = 0
                    ENDIF
                  ENDIF
                  IF (NC .EQ. 0) THEN
                    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
                    ISTK(IENPT + 4) = K
                    ISTK(IENPT + 5) = K5
                    ISTK(IENPT + 6) = 0
                    ISTK(IENPT + 7) = 0
                    ISTK(IENPT + 8) = 0
                    ISTK(IENPT + 9) = IL
                    IF (ISTK(K5 + IQ + 3) .EQ. -1) THEN
                      JNK = IENPT
                      CALL PLA195 (TX)
                      RSTK(IENPT + 3) = RSTK(IENPT + 3) + TX * AMU
                      ISTK(IENPT + 7) = NC
                    ENDIF
                  ENDIF
                ENDIF
              ENDIF
  100       CONTINUE
          ENDIF
  110   CONTINUE
        JT(IP) = IENPT
        IL     = IL + 1
  120 CONTINUE
      DO 240 I = 1, IENPL, 6
        IF (ISTK(I + 4) + ISTK(I + 5) .EQ. -2) THEN
          IP  = 1
          IPC = 0
          K      = ISTED
  130     IE(IP) = 2
          JPC    = 0
          IF(ISTK(K + IP + 3) .NE. 1) GOTO 190
          J = JI(IP)
  140     IF (J .LE. JT(IP)) THEN
            IF (ISTK(J + 4) .EQ. K) THEN
              IT = ISTK(J + 5)
              IF (I .NE. ISTK(IT)) THEN
                IF (I .NE. ISTK(IT + 1)) GOTO 150
              ENDIF
              IF (JPC .LE. 0) THEN
                JPC         = 1
                ND          = J
                IB(IPC + 1) = J
                GOTO 150
              ENDIF
              NF          = J
              IB(IPC + 2) = J
              NC = 1
              IF (ABS(RSTK(ND) - RSTK(NF)) .LE. 0.00003) THEN
                IF (ABS(RSTK(ND + 1) - RSTK(NF + 1)) .LE. 0.00003) THEN
                  IF (ABS(RSTK(ND + 2) - RSTK(NF + 2)) .LE. 0.00003)
     1               NC = 0
                ENDIF
              ENDIF
              IF (NC .GT. 0) GOTO 200
            ENDIF
  150       J = J + 10
            GOTO 140
          ENDIF
          DO 180 M = 2, 3
            J   = ISTK(K + M)
            IND = ISTK(J + 4)
            IT  = ISTK(J + 5)
            DO 160 IT2 = IND, IT
              IF (ISTK(IT2) .EQ. I) THEN
                IF (JPC .LE. 0) THEN
                  JPC         = 1
                  ND          = J
                  IB(IPC + 1) = J
                  GOTO 170
                ENDIF
                NF          = J
                IB(IPC + 2) = J
                IF (ABS(RSTK(ND) - RSTK(NF)) .LE. 0.00003) THEN
                  IF (ABS(RSTK(ND + 1) - RSTK(NF + 1)) .LE. 0.00003)
     1               THEN
                    IF (ABS(RSTK(ND + 2) - RSTK(NF + 2)) .LE. 0.00003)
     1                GOTO 170
                  ENDIF
                ENDIF
                GOTO 200
              ENDIF
  160       CONTINUE
  170       IT = ISTK(J + IP + 5)
            IF (IT .GT. 0) THEN
              IF (ISTK(IT + 4) .EQ. I) THEN
                IF (JPC .GT. 0) THEN
                  NF          = IT
                  IB(IPC + 2) = IT
                  NC = 1
                  IF (ABS(RSTK(ND) - RSTK(NF)) .LE. 0.00003) THEN
                    IF (ABS(RSTK(ND + 1) - RSTK(NF + 1)) .LE. 0.00003)
     1                THEN
                      IF (ABS(RSTK(ND + 2) - RSTK(NF + 2)) .LE. 0.00003)
     1                   NC = 0
                    ENDIF
                  ENDIF
                  IF (NC .GT. 0) GOTO 200
                ELSE
                  JPC         = 1
                  ND          = IT
                  IB(IPC + 1) = IT
                ENDIF
              ENDIF
            ENDIF
  180     CONTINUE
          IF (JPC .GT. 0) THEN
            IE(IP) = 1
            GOTO 200
          ENDIF
  190     K = K + 6
          IF (K .LE. IENED) GOTO 130
          IF (IP .NE. 2) GOTO 240
          IP  = 1
          IPC = 0
          K   = JSK
          GOTO 190
  200     IF (IP .LE. 1) THEN
            JSK = K
            K   = ISTED
            IP  = 2
            IPC = 2
            GOTO 130
          ENDIF
          IF (K .EQ. JSK) GOTO 190
          IF (IE(1) .EQ. 2) THEN
            IF (IE(2) .EQ. 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 PLA198 (D, 2)
              NC = 1
              IF (ABS(D(3)) .GT. 1.D-9) THEN
                DEN = D(1) / D(3)
                IF (DEN .GE. - 0.00001) THEN
                  IF (1.00001 .GE. DEN) NC = 0
                ENDIF
              ENDIF
              IF (NC .NE. 0) GOTO 190
              NC = 1
              IF (ABS(D(3)) .GT. 1.D-9) THEN
                DEN = D(2) / D(3)
                IF (DEN .GE. - 0.00001) THEN
                  IF (1.00001 .GE. DEN) NC = 0
                ENDIF
              ENDIF
              IF (NC .NE. 0) GOTO 190
              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))
              GOTO 230
            ENDIF
          ENDIF
          JNK = IE(1)
          DO 220 JA = 1, JNK
            ND = IB(JA)
            JNK1 = IE(2)
            DO 210 JB = 1, JNK1
              NF = IB(2 + JB)
              IF (ABS(RSTK(ND) - RSTK(NF)) .LE. 0.00003) THEN
                IF (ABS(RSTK(ND + 1) - RSTK(NF + 1)) .LE. 0.00003) THEN
                  IF (ABS(RSTK(ND + 2) - RSTK(NF + 2)) .LE. 0.00003)
     1              THEN
                    IENPT           = IENPT + 10
                    RSTK(IENPT)     = RSTK(ND)
                    RSTK(IENPT + 1) = RSTK(ND + 1)
                    RSTK(IENPT + 2) = RSTK(ND + 2)
                    GOTO 230
                  ENDIF
                ENDIF
              ENDIF
  210       CONTINUE
  220     CONTINUE
          GOTO 190
  230     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
          GOTO 190
        ENDIF
  240 CONTINUE
      I     = 1
      ISTNP = IENPT + 10
  250 IF (ISTK(I + 4) .NE. 1) GOTO 520
      J     = 1
  260 IB(2) = J
      IB(1) = I
      IF (ISTK(J + 5) .NE. 1) GOTO 510
      IENNP = ISTNP - 1
      DO 330 J5 = ISTVT, IENVT, 10
        IP = 1
  270   IQ = 3 - IP
        IF (ISTK(J5 + IP + 7) .NE. IB(IP)) THEN
          JA = ISTK(J5 + 4)
          JB = ISTK(J5 + 5)
          DO 280 J2 = JA, JB
            IF (ISTK(J2) .EQ. IB(IP)) GOTO 290
  280     CONTINUE
          IE(IP) = 1
          GOTO 320
  290     IND = ISTK(J5 + IP + 5)
          IF (IND .NE. 0) THEN
            IF (ISTK(IND + 5) .NE. IB(IQ)) THEN
              IF (ISTK(IND + 4) .NE. IB(IQ)) GOTO 300
            ENDIF
            IENNP = IENNP + 1
            ISTK(IENNP) = IND
  300       JA = ISTK(IND + 6) + 2
  310       IND = IND + 10
            IF (IND .LE. IENPT) THEN
              IF (ISTK(IND + 6) .EQ. JA) THEN
                JB = ISTK(IND + 4)
                IF (ISTK(JB) .NE. IB(IQ)) THEN
                  IF (ISTK(JB + 1) .NE. IB(IQ)) GOTO 310
                ENDIF
                IENNP = IENNP + 1
                ISTK(IENNP) = IND
                GOTO 310
              ENDIF
            ENDIF
          ENDIF
        ENDIF
        IE(IP) = 0
  320   IP     = IP + 1
        IF (IP .EQ. 2) GOTO 270
        IF (IE(1) .EQ. 0 .AND. IE(2) .EQ. 0) THEN
          IENNP       = IENNP + 1
          ISTK(IENNP) = J5
        ENDIF
  330 CONTINUE
      DO 360 IP = 1, 2
        IQ = 3 - IP
        J6 = JT(IP)
        J5 = JI(IP)
  340   IF (J5 .LE. J6) THEN
          IND = ISTK(J5 + 4)
          IF (ISTK(IND) .NE. IB(IP)) THEN
            IF (ISTK(IND + 1) .NE. IB(IP)) GOTO 350
          ENDIF
          IF (ISTK(J5 + 7) .NE. IB(IQ)) THEN
            IND = ISTK(J5 + 5)
            IF (ISTK(IND) .NE. IB(IQ)) THEN
              IF (ISTK(IND + 1) .NE. IB(IQ)) GOTO 350
            ENDIF
          ENDIF
          IENNP       = IENNP + 1
          ISTK(IENNP) = J5
  350     J5          = J5 + 10
          GOTO 340
        ENDIF
  360 CONTINUE
      J5 = JT(2) + 10
  370 IF (J5 .LE. IENPT) THEN
        IND = ISTK(J5 + 4)
        IF (ISTK(IND) .NE. I) THEN
          IF (ISTK(IND + 1) .NE. I) GOTO 380
        ENDIF
        IND = ISTK(J5 + 5)
        IF (ISTK(IND) .NE. J) THEN
          IF (ISTK(IND + 1) .NE. J) GOTO 380
        ENDIF
        IENNP       = IENNP + 1
        ISTK(IENNP) = J5
  380   J5          = J5 + 10
        GOTO 370
      ENDIF
      IF (IENNP - ISTNP .LE. 2) GOTO 510
  390 J3 = IENNP
  400 J4 = J3 - 1
  410 ND = ISTK(J3)
      NF = ISTK(J4)
      NC = 1
      IF (ABS(RSTK(ND) - RSTK(NF)) .LE. 0.00003) THEN
        IF (ABS(RSTK(ND + 1) - RSTK(NF + 1)) .LE. 0.00003) THEN
          IF (ABS(RSTK(ND + 2) - RSTK(NF + 2)) .LE. 0.00003) NC = 0
        ENDIF
      ENDIF
      IF (NC .LE. 0) THEN
        J7 = J4
  420   J8 = J7 + 1
        ISTK(J7) = ISTK(J8)
        J7 = J8
        IF (J8 .LT. IENNP) GOTO 420
        J3 = J3 - 1
        IENNP = IENNP - 1
      ENDIF
      J4 = J4 - 1
      IF (J4 .GE. ISTNP) GOTO 410
      J3 = J3 - 1
      IF (J3 .GT. ISTNP) GOTO 400
      IF (IENNP - ISTNP .LE. 2) GOTO 510
      ISTTR = IENNP + 1
      NPER  = ISTNP + 2
  430 IENTR = ISTTR - 6
      ND = ISTNP
      NF = ISTNP + 1
      NG = ISTNP + 2
      IB(1) = ISTK(ND)
      IB(2) = ISTK(NF)
      IB(3) = ISTK(NF)
      IB(4) = ISTK(NG)
      CALL PLA196
      IENTR           =  IENTR + 6
      IF (IENTR + 6 .GE. NTMP) STOP '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)
      ND = ISTK(ISTNP + 3)
      NF = ISTK(IENTR + 3)
      NF = ISTK(NF)
      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)
      IF (DEN .GT. 1.0D-5) THEN
        ISTK(ISTNP)     = ISTK(ISTNP + 1)
        ISTK(ISTNP + 1) = IB(1)
        GOTO 430
      ENDIF
      IF (DEN .GT. - 1.0D-5) THEN
        NPER = NPER + 1
        IF (NPER .GT. IENNP) GOTO 500
        IQ = ISTNP + 1
        DO 440 IP = IQ, IENNP
          ISTK(IP - 1) = ISTK(IP)
  440   CONTINUE
        ISTK(IENNP) = IB(1)
        GOTO 430
      ENDIF
      VT  = VT - DEN
      DEN = - DEN
      IF (ISK .EQ. 2) THEN
        DEV(1) = DEN
        JNK    = IENTR
        NC     = ISTNP+3
        CALL PLA197
        TT  = TT  + DEV(1)
        DE2 = DE2 + DEV(2)
      ENDIF
      IF (IENNP - ISTNP .GT. 3) THEN
        ND = ISTNP + 1
        NF = ISTNP
        NG = ISTNP + 3
        IB(1) = ISTK(ND)
        IB(2) = ISTK(NF)
        IB(3) = ISTK(NF)
        IB(4) = ISTK(NG)
        CALL PLA196
        IENTR           =  IENTR + 6
        IF (IENTR + 6 .GE. NTMP) GOTO 540
        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
        IB(1) = ISTK(ND)
        IB(2) = ISTK(NF)
        IB(3) = ISTK(NF)
        IB(4) = ISTK(NG)
        CALL PLA196
        IENTR           =  IENTR + 6
        IF (IENTR + 6 .GE. NTMP) GOTO 540
        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
        IB(1) = ISTK(ND)
        IB(2) = ISTK(NF)
        IB(3) = ISTK(NF)
        IB(4) = ISTK(NG)
        CALL PLA196
        IENTR           =  IENTR + 6
        IF (IENTR + 6 .GE. NTMP) GOTO 540
        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)
        L = ISTNP + 3
  450   L = L + 1
        IF (IENNP .GE. L) THEN
          NC = L
          M  = IENTR
          IP = ISTTR
  460     IF (ISTK(IP + 5) .GT. 0) THEN
            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 .GT. 1.D-9) THEN
              VT = VT + DEN
              IF (ISK2 .EQ. 2) THEN
                DEV(1) = DEN
                IF (DEN .GT. FLIM) THEN
                  JNK = IP
                  CALL PLA197
                  DE2 = DE2 + DEV(2)
                  TT  = TT  + DEV(1)
                ENDIF
              ENDIF
              JNK1 = ISTK(IP + 5)
              JNK3 = ISTK(IP + 3)
              ISTK(IP + 5) = 0
              ND    = ISTK(IP + 4)
              NF    = JNK1
              NG    = L
              LRETX = -1
  470         DO 480 I0 = ISTTR, IENTR, 6
                IF (NG .EQ. ISTK(I0 + 5)) THEN
                  IF (ND .EQ. ISTK(I0 + 4)) THEN
                    IF (NF .EQ. ISTK(I0 + 3)) THEN
                      ISTK(I0 + 5) = 0
                      GOTO 490
                    ENDIF
                  ENDIF
                ENDIF
  480         CONTINUE
              IB(1) = ISTK(ND)
              IB(2) = ISTK(NF)
              IB(3) = ISTK(NF)
              IB(4) = ISTK(NG)
              CALL PLA196
              IENTR           =  IENTR + 6
              IF (IENTR + 6 .GE. NTMP) GOTO 540
              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)
  490         IF (LRETX .LT. 0) THEN
                NF    = ND
                ND    = JNK3
                LRETX = 0
                GOTO 470
              ELSE IF (LRETX .EQ. 0) THEN
                NF    = ND
                ND    = JNK1
                LRETX = 1
                GOTO 470
              ENDIF
            ENDIF
          ENDIF
          IP = IP + 6
          IF (IP .LE. M) GOTO 460
          GOTO 450
        ENDIF
      ENDIF
  500 IF (IEX .EQ. 1) THEN
        IEX  = 2
        ISK  = 2
        ISK2 = 2
        VZ   = 0.001D+0 * VT
        FLIM = VZ  * 0.03D+0
        GOTO 530
      ENDIF
  510 J = J + 6
      IF (J .LE. IENPL) GOTO 260
  520 I = I + 6
      IF (I .LE. IENPL) GOTO 250
      TT = TT * 6.0D+0 / VT
      DEV(2) = DE2 * 6.0D+0 / VT
  530 J = IENTR + 6
      IF (J .GT. MAXUTL) MAXUTL = J
      IF (MAXUTL .GT. NTMP) GOTO 540
      RETURN
  540 WRITE (LU7, 99999) NTMP
      RETURN
99999 FORMAT ('Available Array Size Exceeded. NTMP =', I7)
      END
      SUBROUTINE PLA195 (TX)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (NTMP=4000)
      COMMON /XYDATA/ RSTK(NTMP), ISTK(NTMP), AMU, TT, VT, CX(2), CY(2),
     1 CZ(2), D(12), DEV(2), VMUL, IL, NC, ND, NF, NG, IB(4), IE(2),
     2 JI(2), JT(2), IENPL, ISTNV, IENNV, ISTED, IENED, ISTVT, IENVT,
     3 IENPT, ISTNP, IENNP, ISTTR, IENTR, MAXUTL, JNK, JNK1, JNK3,
     4 IEX, ISK, ISK2
      TX = 2000.0D+0
      NC = 0
      DO 10 IT = 1, IENPL, 6
        IF (ND .EQ. ISTK(IT + JNK1 + 3)) THEN
          ANM = RSTK(IT + 3) - RSTK(IT) * RSTK(JNK)
     1        - RSTK(IT + 1) * RSTK(JNK + 1)
     2        - RSTK(IT + 2) * RSTK(JNK + 2)
          DN  = RSTK(IT) * CX(JNK1) + RSTK(IT + 1) * CY(JNK1)
     1        + RSTK(IT + 2) * CZ(JNK1)
          DN  = ABS(DN)
          ANM = ABS(ANM)
          IF (ANM .LT. TX * DN) THEN
            TX = ANM / DN
            NC = IT
          ENDIF
        ENDIF
   10 CONTINUE
      RETURN
      END
      SUBROUTINE PLA196
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (NTMP=4000)
      COMMON /XYDATA/ RSTK(NTMP), ISTK(NTMP), AMU, TT, VT, CX(2), CY(2),
     1 CZ(2), D(12), DEV(2), VMUL, IL, NC, ND, NF, NG, IB(4), IE(2),
     2 JI(2), JT(2), IENPL, ISTNV, IENNV, ISTED, IENED, ISTVT, IENVT,
     3 IENPT, ISTNP, IENNP, ISTTR, IENTR, MAXUTL, JNK, JNK1, JNK3,
     4 IEX, ISK, ISK2
      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 PLA197
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (NTMP=4000)
      COMMON /XYDATA/ RSTK(NTMP), ISTK(NTMP), AMU, TT, VT, CX(2), CY(2),
     1 CZ(2), D(12), DEV(2), VMUL, IL, NC, ND, NF, NG, IB(4), IE(2),
     2 JI(2), JT(2), IENPL, ISTNV, IENNV, ISTED, IENED, ISTVT, IENVT,
     3 IENPT, ISTNP, IENNP, ISTTR, IENTR, MAXUTL, JNK, JNK1, JNK3,
     4 IEX, ISK, ISK2
      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 20 I = 1, 3
        AF = D(I)
        JNK = I + 1
        DO 10 J = JNK, 4
          IF (AF .GT. D(J)) THEN
            BF   = D(J)
            D(J) = AF
            AF   = BF
          ENDIF
   10   CONTINUE
        D(I) = AF
   20 CONTINUE
      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) .LT. 15) THEN
        IAL = 1
        IBL = 0
        ICL = 0
        IF (D(2) .GT. 3.D-3) IAL = 5
        IF (D(3) .GT. 3.D-3) IBL = 2
        IF (D(4) .GT. 3.D-3) ICL = 1
        ISW = IAL + IBL + ICL
        I   = 1
        IF (ISW .EQ. 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)))
          GOTO 50
        ELSE IF (ISW .EQ. 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))
          GOTO 30
        ELSE IF (ISW .EQ. 3 .OR. ISW .EQ. 4) THEN
          HA = 1.0D+0 - D(2) * (0.5D+0 - 0.166667D+0 * D(2))
        ELSE IF (ISW .EQ. 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))
          GOTO 50
        ELSE
          HA = (1.0D+0 - EXP(- D(2))) / D(2)
          IF (IBL .LE. 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)
            GOTO 30
          ENDIF
        ENDIF
        HAB  = (1.0D+0  - EXP(- D(5))) / D(5)
        D(8) = (HA - HAB) / D(3)
        IF (ICL .LE. 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)
          GOTO 40
        ENDIF
  30    HABC   = (1.0D+0 - EXP(- D(7))) / D(7)
        D(9)   = (HAB - HABC) / D(4)
  40    D(10)  = (D(8) - D(9)) / D(6)
  50    DEV(I) = DEN * D(10) * EXP(-D(1))
      ELSE
        DEV(1) = 0
        DEV(2) = 0
      ENDIF
      RETURN
      END
      SUBROUTINE PLA198 (D, IZ)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION D(*)
      IF (IZ .EQ. 2) THEN
        AA   =  D(1) * D(6) - D(5) * D(2)
        BB   = -D(3) * D(6) + D(5) * D(4)
        D(3) =  D(1) * D(4) - D(3) * D(2)
        D(1) =  BB
        D(2) =  AA
      ELSE
        AA   =  D(8) * D(12) - D(9) * D(11)
        BB   =  D(7) * D(12) - D(9) * D(10)
        CC   =  D(7) * D(11) - D(8) * D(10)
        DA   =  D(4) * AA    - D(5) * BB + D(6) * CC
        E    = -D(1) * AA    + D(2) * BB - D(3) * CC
        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) =  DA
        D(2) =  E
        D(4) =  F
      ENDIF
      RETURN
      END
      SUBROUTINE PLA200 (MODE, INEXT, NOCLS, NREPL)
      PARAMETER (NP4=9,NP10=16,NP12=600,NP13=500,NP17=99,NP22=256,
     1 NP38=125,NP39=30, NXT1=100, NXT2=200, NXT3=100, NXT4=200)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /P190/ NVRR, PMILL(NXT1, 5), XTLV(7, NXT2), IDG(NXT4, 4),
     1 XYZPL(3, NXT2), CFACE(5, NXT2), IEDGE(NXT3), NFACES, NEDGE, NVER
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /ABSPSI/ PSIS(38, 4, 10), OP(3, 3, 11), IHKLPS(4, 10),
     1 NPSI
      COMMON /LOCAL/ IPR271, IPR272, IPR371, IPR372
      DATA IPR371, IPR372 /0, 0/
      VERT = 25.0
      HORS = PAR(50) * VERT
      IF (NREPL .EQ. 0) THEN
        IF (NOCLS .EQ. 0) CALL GGIP (HORS, VERT, 0.0, 1)
      ELSE
        GOTO 300
      ENDIF
      CALL GGIP (0.0, 1.0, 0.0, 0)
      CALL PLA117 (HORS, VERT, -1)
      IF (MODE .EQ. -1) THEN
        WRITE (PRBUF, '(A)') 'Spherical Absorption Correction '
      ELSE IF (MODE .EQ. 0) THEN
        WRITE (PRBUF, '(A)') 'Xtal Habit Display+Manipulation '
      ELSE IF (MODE .EQ. 1) THEN
        WRITE (PRBUF, '(A)') 'Analytical Correction of PsiScan'
      ELSE IF (MODE .EQ. 2) THEN
        WRITE (PRBUF, '(A)') 'Gaussian Integration Correction '
      ELSE IF (MODE .EQ. 3) THEN
        WRITE (PRBUF, '(A)') 'de Meulenaer- Tompa  Correction '
      ELSE IF (MODE .EQ. 4) THEN
        WRITE (PRBUF, '(A)') 'Psi-Scan  Absorption Correction '
      ELSE IF (MODE .EQ. 6) THEN
        WRITE (PRBUF, '(A)') 'MULtiscan ABSorption Correction '
      ELSE IF (MODE .EQ. 7) THEN
        WRITE (PRBUF, '(A)') 'DELABS    Absorption Correction '
      ENDIF
      CALL GGIP20 (0.0, PRBUF, 32, 0.75, 5 + IGBL(68), 2, 3.0,
     1             VERT - 1.0)
      IF (MODE .EQ. -1 .OR. MODE .EQ. 4) THEN
        WRITE (PRBUF, '(''MuR     '', F6.2)') PAR(321)
        IF (PAR(321) .EQ. 0.0) THEN
          CALL GGIP (0.0, 2.0, 0.0, 0)
          IF (MODE .EQ. -1) THEN
            CALL GGIP20 (0.0, 'Enter MuR         Datum <<', 26, 0.50,
     1                  -1, 2, 21.0, 2.0)
          ELSE IF (MODE .EQ. 4 .AND. NPSI .EQ. 0) THEN
            CALL GGIP20 (0.0,
     1           'Optionally Enter MuR for Additional Theta Correction',
     2             52, 0.50, -1, 2, 10.0, 4.0)
          ENDIF
        ELSE
          CALL GGIP (0.0, 3.0, 0.0, 0)
        ENDIF
        CALL GGIP20 (0.0, PRBUF, 14, 0.5, -1, 2, VERT + 0.1, VERT - 1.0)
        IF (MODE .EQ. 4 .AND. NPSI .GT. 0) THEN
          WRITE (PRBUF, '(A, I3)') 'Nr. Psi Scans =', NPSI
          CALL GGIP20 (0.0, PRBUF, 18, 0.5, 1, 2,
     1                 VERT + 0.1, VERT - 3.0)
        ENDIF
      ELSE IF (MODE .NE. 0 .AND. MODE .NE. 4 .AND. MODE .NE. 7) THEN
        WRITE (PRBUF, '(''Mu      '', F6.2, '' mm-1'')') PAR(301)
        IF (PAR(301) .EQ. 0.0) THEN
          CALL GGIP (0.0, 2.0, 0.0, 0)
          CALL GGIP20 (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)
        ENDIF
        CALL GGIP20 (0.0, PRBUF, 19, 0.5, -1, 2, VERT + 0.1, VERT - 1.0)
      ENDIF
      IF (MODE .EQ. 2) THEN
        WRITE (PRBUF, '(''Grid   '', 3I4)')
     1                  IPR(421), IPR(422), IPR(423)
        CALL GGIP20 (0.0, PRBUF, 19, 0.5, 1, 2, VERT + 0.1, VERT - 2.0)
      ENDIF
      IF (MODE .EQ. 6) THEN
        WRITE (PRBUF, '(''Radius  '', F6.3, '' mm'')') PAR(305)
        IF (PAR(305) .EQ. 0.0) THEN
          CALL GGIP (0.0, 2.0, 0.0, 0)
          CALL GGIP20 (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)
        ENDIF
        CALL GGIP20 (0.0, PRBUF, 18, 0.5, -1, 2, VERT + 0.1,
     1       VERT - 2.0)
        WRITE (PRBUF, '(''Tmin   '', F7.3, '' mm'')') PAR(304)
        CALL GGIP20 (0.0, PRBUF, 17, 0.5, 1, 2, VERT + 0.1,
     1       VERT - 3.0)
        WRITE (PRBUF, '(''Tmax   '', F7.3, '' mm'')') PAR(306)
        CALL GGIP20 (0.0, PRBUF, 17, 0.5, 1, 2, VERT + 0.1,
     1       VERT - 4.0)
        WRITE (PRBUF, '(''Lomax  '', I7)') IPR(373)
        CALL GGIP20 (0.0, PRBUF, 14, 0.5, 1, 2, VERT + 0.1,
     1       VERT - 5.0)
        WRITE (PRBUF, '(''L1max  '', I7)') IPR(374)
        CALL GGIP20 (0.0, PRBUF, 14, 0.5, 1, 2, VERT + 0.1,
     1       VERT - 6.0)
        WRITE (PRBUF, '(''MuR    '', F7.3)') PAR(321)
        CALL GGIP20 (0.0, PRBUF, 17, 0.5, 1, 2, VERT + 0.1,
     1       VERT - 7.0)
      ENDIF
      IF (MODE .EQ. 2 .OR. MODE .EQ. 3 .OR. MODE .EQ. 4
     1      .OR. MODE .EQ. 6 .OR. MODE .EQ. -1 .OR. MODE .EQ. 0) THEN
        IF (MODE .EQ. 2 .OR. MODE .EQ. 3 .OR. MODE .EQ. 0)
     1      PAR(305) = 0.0001
        IF (PAR(301) * PAR(305) .GT. 0.0 .OR. MODE .EQ. 4
     1      .OR. (MODE .EQ. -1 .AND. PAR(321) .GT. 0.0)) THEN
          CALL GGIP (0.0, 2.0, 0.0, 0)
          IF (PAR(315) .EQ. 0.0) THEN
            IF (IPR(375) .EQ. 0) THEN
              CALL GGIP20 (0.0, 'Click on NEXT-STEP to PROCEED', 29,
     1                 0.60, -1, 2, 18.0, 1.5)
            ENDIF
          ELSE
            CALL GGIP20 (0.0, 'Click on END to Terminate    ', 29,
     1                 0.75, -1, 2, 15.0, 1.0)
          ENDIF
        ENDIF
      ENDIF
      IF (IPR(331) .EQ. 1) THEN
        WRITE (IDM, '(''a     = '', F8.4)') PAR(101)
        CALL GGIP20 (0.0, IDM, 16, 0.35, 1, 2, 0.5, VERT - 2.0)
        WRITE (IDM, '(''b     = '', F8.4)') PAR(102)
        CALL GGIP20 (0.0, IDM, 16, 0.35, 1, 2, 0.5, VERT - 2.6)
        WRITE (IDM, '(''c     = '', F8.4)') PAR(103)
        CALL GGIP20 (0.0, IDM, 16, 0.35, 1, 2, 0.5, VERT - 3.2)
        WRITE (IDM, '(''alpha = '', F8.3)') PAR(104)
        CALL GGIP20 (0.0, IDM, 16, 0.35, 1, 2, 0.5, VERT - 3.8)
        WRITE (IDM, '(''beta  = '', F8.3)') PAR(105)
        CALL GGIP20 (0.0, IDM, 16, 0.35, 1, 2, 0.5, VERT - 4.4)
        WRITE (IDM, '(''gamma = '', F8.3)') PAR(106)
        CALL GGIP20 (0.0, IDM, 16, 0.35, 1, 2, 0.5, VERT - 5.0)
        IF (NFACES .GT. 0) THEN
          WRITE (PRBUF, '(''Faces    '', I4)') NFACES
          CALL GGIP20 (0.0, PRBUF, 13, 0.35, 1, 2, 0.5, VERT - 6.0)
          WRITE (PRBUF, '(''Vertices '', I4)') NVRR
          CALL GGIP20 (0.0, PRBUF, 13, 0.35, 1, 2, 0.5, VERT - 6.5)
          WRITE (PRBUF, '(''Edges    '', I4)') NEDGE
          CALL GGIP20 (0.0, PRBUF, 13, 0.35, 1, 2, 0.5, VERT - 7.0)
        ENDIF
      ENDIF
  300 IF (MODE .EQ. 6) THEN
        WRITE (PRBUF, '(''Read   ='', I7, '' Measurements'')')
     1         IPR371
        CALL GGIP20 (0.0, PRBUF, 29, 0.5, 0, 2, 3.0, VERT - 8.0)
        IPR371 = IPR(371)
        WRITE (PRBUF, '(''Read   ='', I7, '' Measurements'')')
     1         IPR(371)
        CALL GGIP20 (0.0, PRBUF, 29, 0.5, 5, 2, 3.0, VERT - 8.0)
        WRITE (PRBUF, '(''Accept ='', I7, '' Measurements'')')
     1         IPR372
        CALL GGIP20 (0.0, PRBUF, 29, 0.5, 0, 2, 3.0, VERT - 9.0)
        IPR372 = IPR(372)
        WRITE (PRBUF, '(''Accept ='', I7, '' Measurements'')')
     1         IPR(372)
        CALL GGIP20 (0.0, PRBUF, 29, 0.5, 5, 2, 3.0, VERT - 9.0)
        IF (NREPL .EQ. 0) THEN
          WRITE (PRBUF, '(''SPGR   =  '', A)') SPGRNM(1)(1:11)
          CALL GGIP20 (0.0, PRBUF, 21, 0.5, 5, 2, 3.0, VERT - 7.0)
          IF (IPR(375) .GT. 0) THEN
            WRITE (PRBUF,
     1        '(''N(obs) ='', I7, '' Measurements (Used)'')') IPR(375)
            CALL GGIP20 (0.0, PRBUF, 36, 0.5, 5 + IGBL(68), 2, 3.0,
     1                   VERT - 10.0)
            WRITE (PRBUF,
     1        '(''N(hkl) ='', I7, '' Unique Reflections'')')  IPR(376)
            CALL GGIP20 (0.0, PRBUF, 35, 0.5, 5 + IGBL(68), 2, 3.0,
     1                   VERT - 11.0)
            WRITE (PRBUF,
     1        '(''N(par) ='', I7, '' Coefficients A(l,m)'')') IPR(377)
            CALL GGIP20 (0.0, PRBUF, 36, 0.5, 5 + IGBL(68), 2, 3.0,
     1                   VERT - 12.0)
            WRITE (PRBUF,
     1        '(''Rw = '', F10.3, '' For All AHI = 1 (N(par) = 0)'')')
     2         PAR(322)
            CALL GGIP20 (0.0, PRBUF, 44, 0.5, 5 + IGBL(68), 2, 3.0,
     1                   VERT - 14.0)
            WRITE (PRBUF,
     1   '(''Rw = '', F10.3, '' For the AHI From the Fitted A(l,m)'')')
     2       PAR(323)
            CALL GGIP20 (0.0, PRBUF, 50, 0.5, 5 + IGBL(68), 2, 3.0,
     1                         VERT - 15.0)
            IF (PAR(319) .GT. 0.0) THEN
              WRITE (PRBUF, '(''A(min) ='', F8.4)') PAR(319)
              CALL GGIP20 (0.0, PRBUF, 16, 0.5, 1, 2, 1.0,
     1                     VERT - 21.0)
              WRITE (PRBUF, '(''A(max) ='', F8.4)') PAR(320)
              CALL GGIP20 (0.0, PRBUF, 16, 0.5, 1, 2, 1.0,
     1                     VERT - 22.0)
              ENDIF
          ENDIF
        ENDIF
        CALL GGIP (0.0, 0.0, 0.0, 6)
      ENDIF
      IF (MODE .NE. 0 .AND. PAR(315) .NE. 0.0) THEN
        IF (MODE .NE. 6) THEN
          WRITE (PRBUF, '(''Refl. Processed'', I7)') IPR(432)
          CALL GGIP20 (0.0, PRBUF, 28, 0.5, 5 + IGBL(68), 2, 1.3,
     1                 VERT - 22.0)
        ENDIF
        WRITE (PRBUF, '(''T(min) ='', F8.4)') PAR(315)
        CALL GGIP20 (0.0, PRBUF, 16, 0.5, 5 + IGBL(68), 2, 1.3,
     1               VERT - 23.0)
        WRITE (PRBUF, '(''T(max) ='', F8.4)') PAR(317)
        CALL GGIP20 (0.0, PRBUF, 16, 0.5, 5 + IGBL(68), 2, 1.3,
     1               VERT - 24.0)
      ENDIF
      IF (INEXT .EQ. 0 .AND. MODE .NE. 4 .AND. MODE .NE. -1 ) THEN
        CALL PLA185 (1, 9.0, 11, NOCLS)
      ENDIF
      RETURN
      END
      SUBROUTINE PLA201
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16,
     1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP25=99,NP29=63,
     2 NP38=125,NP39=30,NP41=200,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      CHARACTER CH*20, PRBUF*100
      CALL GEN003 (QQ, DUMV, DET, 0)
      IF (ABS(DET) .LT. 0.01) THEN
        WRITE (LU6, 99993)
        STOP 'ABNORMAL'
      ENDIF
      IHT = 0
      IKT = 0
      ILT = 0
      CALL GEN005 (QQ, QQ)
      WRITE (LU6, 99996) DET
      WRITE (LU6, 99997) ((DUMV(I, J), J = 1, 3), I = 1, 3)
      WRITE (LU6, 99995)
      WRITE (LU6, 99997) ((QQ(I, J), J = 1, 3), I = 1, 3)
      CALL GEN074 (PAC,  0.0, 1, 9)
      CALL GEN074 (UIJC, 0.0, 1, 9)
      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 GEN004 (QQ, PAC, UIJ)
      CALL GEN004 (UIJC, UIJ, PAT)
      WRITE (LU6, 99994)
      WRITE (LU6, 99997) ((PAT(I, J), J = 1, 3), I = 1, 3)
      IF (IGBL(37) .EQ. 0) WRITE (LU6, 99992)
      N = 0
      GOTO 20
   10 READ (LU16, 99998, END = 30) PRBUF
      IF (INDEX(PRBUF, '<?') .NE. 0) GOTO 30
      BACKSPACE LU16
   20 READ (LU16, 99999, END = 30) IH, IK, IL, CH,
     1            (V1(K), V2(K), K = 1, 3)
      IF (IH .EQ. 0 .AND. IK .EQ. 0 .AND. IL .EQ. 0) THEN
        WRITE (LU17, 99990)
        GOTO 10
      ENDIF
      IF (GEN050 (DUMV, IH, IK, IL, IHT, IKT, ILT) .GT. 0.0) THEN
        N = N + 1
        IF (IGBL(37) .EQ. 1) THEN
          CALL GEN002 (1, PAT,  V1, V4, XLNG)
          CALL GEN002 (1, PAT,  V2, V5, XLNG)
          WRITE (LU17, 99999) IHT, IKT, ILT, CH,
     1                        (V4(K), V5(K), K = 1, 3)
        ELSE
          WRITE (LU17, 99999) IHT, IKT, ILT, CH
        ENDIF
      ENDIF
      GOTO 20
   30 WRITE (LU17, 99990)
      WRITE (LU6, 99991) N
      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 (/, ':: Determinant for transformation = 0.0', /)
99992 FORMAT (/, ':: No Direction Cosines on INPUT/OUTPUT', /)
99991 FORMAT (/, ':: Number of Reflections processed = ', I7, /)
99990 FORMAT (1X)
      END
      SUBROUTINE PLA206 (ISW, TYPE)
      PARAMETER (NP12=600,NP13=500,NP17=99,NP38=125,NP39=30)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0
      CHARACTER TYPE*3
      COMMON /CGG11/ BCD, SBCD
      CHARACTER BCD*132, SBCD*132
C * ISW =  1 - SET
C * ISW = -1 - LIST
C * MODE = +-1 - IPR
C * MODE = +-2 - FN
C * MODE = +-3 - IGBL
C * MODE = +-4 - GL
      MODE = 0
      IEND = 0
      IGBL(23) = - IABS(IGBL(23))
      IF (TYPE .EQ. 'IPR') THEN
        MODE = ISW
        IEND = NP12
      ELSE IF (TYPE .EQ. 'PAR') THEN
        MODE = ISW * 2
        IEND = NP13
      ELSE IF (TYPE .EQ. 'IGB') THEN
        MODE = ISW * 3
        IEND = NP38
      ELSE IF (TYPE .EQ. 'GL ') THEN
        MODE = ISW * 4
        IEND = NP39
      ENDIF
      IF (MODE .LT. 0) THEN
        IF (IPR(221) .EQ. 0) THEN
          I1 = 1
          I2 = IEND
        ELSE
          I1 = NINT(FN(1))
          IF (IPR(221) .GT. 1) THEN
            I2 = NINT(FN(2))
          ELSE
            I2 = I1
          ENDIF
          IF (I1 .LT. 1 .OR. I1 .GT. IEND .OR. I2 .LT. I1
     1        .OR. I2 .GT. IEND) GOTO 100
        ENDIF
        IF (MODE .EQ. -1) THEN
          IF (I2 - I1 .LT. 4) THEN
            WRITE (BCD, 99998) (' ', I, IPR(I), I = I1, I2)
            IF (IWIN .EQ. 1) THEN
              BCD(80:80) = CHAR(0)
              CALL GGIP (-999.0, 5.0 + FLOAT(IGBL(68)), 80.0, 111)
            ELSE
              WRITE (LU6, 99992) BCD
            ENDIF
          ELSE
            WRITE (LU6, 99998) (' ', I, IPR(I), I = I1, I2)
            GOTO 110
          ENDIF
        ELSE IF (MODE .EQ. -2) THEN
          IF (I2 - I1 .LT. 3) THEN
            WRITE (BCD, 99997) (' ', I, PAR(I), I = I1, I2)
            IF (IWIN .EQ. 1) THEN
              BCD(80:80) = CHAR(0)
              CALL GGIP (-999.0, 5.0 + FLOAT(IGBL(68)), 80.0, 111)
            ELSE
              WRITE (LU6, 99992) BCD
            ENDIF
          ELSE
            WRITE (LU6, 99997) (' ', I, PAR(I), I = I1, I2)
            GOTO 110
          ENDIF
        ELSE IF (MODE .EQ. -3) THEN
          IF (I2 - I1 .LT. 3) THEN
            WRITE (BCD, 99999) (' ', I, IGBL(I), I = I1, I2)
            IF (IWIN .EQ. 1) THEN
              BCD(80:80) = CHAR(0)
              CALL GGIP (-999.0, 5.0 + FLOAT(IGBL(68)), 80.0, 111)
            ELSE
              WRITE (LU6, 99992) BCD
            ENDIF
          ELSE
            WRITE (LU6, 99999) (' ', I, IGBL(I), I = I1, I2)
            GOTO 110
          ENDIF
        ELSE IF (MODE .EQ. -4) THEN
          IF (I2 - I1 .LT. 3) THEN
            WRITE (BCD, 99993) (' ', I, GL(I), I = I1, I2)
            IF (IWIN .EQ. 1) THEN
              BCD(80:80) = CHAR(0)
              CALL GGIP (-999.0, 5.0 + FLOAT(IGBL(68)), 80.0, 111)
            ELSE
              WRITE (LU6, '(A)') BCD
            ENDIF
          ELSE
            WRITE (LU6, 99993) (' ', I, GL(I), I = I1, I2)
            GOTO 110
          ENDIF
        ENDIF
      ELSE
        INDX = NINT(FN(1))
        IF (INDX .GT. 0 .AND. INDX .LE. IEND) THEN
          IF (MODE .EQ. 1) THEN
            IVAL      = NINT(FN(2))
            IVALO     = IPR(INDX)
            IPR(INDX) = IVAL
            WRITE (BCD, 99976) INDX, IVALO, IVAL
            IF (IWIN .EQ. 1) THEN
              CALL GGIP (-999.0, 5.0 + FLOAT(IGBL(68)), 48.0, 111)
            ELSE
              WRITE (LU6, 99994) BCD(1:47)
            ENDIF
          ELSE IF (MODE .EQ. 2) THEN
            VAL       = FN(2)
            VALO      = PAR(INDX)
            PAR(INDX) = VAL
            WRITE (BCD, 99974) INDX, VALO, VAL
            IF (IWIN .EQ. 1) THEN
              CALL GGIP (-999.0, 5.0 + FLOAT(IGBL(68)), 48.0, 111)
            ELSE
              WRITE (LU6, 99994) BCD(1:47)
            ENDIF
          ELSE IF (MODE .EQ. 3) THEN
            IVAL       = NINT(FN(2))
            IVALO      = IGBL(INDX)
            IGBL(INDX) = IVAL
            WRITE (BCD, 99956) INDX, IVALO, IVAL
            IF (IWIN .EQ. 1) THEN
              CALL GGIP (-999.0, 5.0 + FLOAT(IGBL(68)), 48.0, 111)
            ELSE
              WRITE (LU6, 99994) BCD(1:47)
            ENDIF
          ELSE IF (MODE .EQ. 4) THEN
            VAL      = FN(2)
            VALO     = GL(INDX)
            GL(INDX) = VAL
            WRITE (BCD, 99955) INDX, VALO, VAL
            IF (IWIN .EQ. 1) THEN
              CALL GGIP (-999.0, 5.0 + FLOAT(IGBL(68)), 48.0, 111)
            ELSE
              WRITE (LU6, 99994) BCD(1:47)
            ENDIF
          ENDIF
        ELSE
          GOTO 100
        ENDIF
      ENDIF
      RETURN
  100 WRITE (BCD, 99996) CHAR(0)
      IF (IWIN .EQ. 1) THEN
        CALL GGIP (-999.0, 2.0, 33.0, 111)
      ELSE
        WRITE (LU6, 99992) BCD(1:32)
      ENDIF
      RETURN
  110 IF (IWIN .EQ. 1) THEN
        WRITE (BCD, 99995) CHAR(0)
        CALL GGIP (-999.0, 5.0 + FLOAT(IGBL(68)), 23.0, 111)
      ENDIF
      RETURN
99999 FORMAT (1('::',3(A, 'IGBL[', I3, '] =', I10, ', ')))
99998 FORMAT (1('::',4(A, 'IPR[', I3, ']', I8, ', ')))
99997 FORMAT (1('::',3(A, 'PAR[', I3, '] =', F10.4, ', ')))
99996 FORMAT ('E: Out of Range Error, Try again', A)
99995 FORMAT ('Output on ASCII window', A)
99994 FORMAT (':: ', A)
99993 FORMAT (1('::',3(A, 'GL[', I3, '] =', F10.4, ', ')))
99992 FORMAT (A)
99976 FORMAT ('IPR(', I3, ')  old value =', I10, ' new =', I10, A)
99974 FORMAT ('PAR(', I3, ')  old value =', F10.4, ' new =', F10.4, A)
99956 FORMAT ('IGBL(', I3, ') old value =', I10, ' new =',  I10, A)
99955 FORMAT ('GL(', I3, ')  old value =', F10.4, ' new =', F10.4, A)
      END
      SUBROUTINE PLA207
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118,
     1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NPVD=40000000,
     2 NP22=256,NP23=18000,NP25=99,NP29=63,NP38=125,NP39=30,NP41=200,
     3 NP45=2048,NP47=9,MP1=5000,MP2=100,MP3=83,
     4 MP4=NPVD+2*NP23-MP3*MP3*MP3-5*MP1)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9),
     1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10),
     2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10),
     3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /FNAME/ KNM(8), KXT, KNM16
      COMMON /NAMES/ NAME(8), EXTENS, PROGNM, FNLU1, FNLU16, RDTYPE
      CHARACTER NAME*80, EXTENS*9, PROGNM*28, FNLU1*80, FNLU16*80,
     1          RDTYPE*7
      COMMON /PATHS/ PLAPATH, BROWSER, CGETENV
      CHARACTER PLAPATH*255, BROWSER*255, CGETENV*255
      CHARACTER LABL*4
      COMMON // TJ(MP3, MP3, MP3), XF(5, MP1), AMX(MP4)
      EXTERNAL SYSTEM
      COMMON /PAGENM/ PAGET, PAGEIND(25)
      CHARACTER PAGET*8, PAGEIND*8
      IF (IPR(221) .GT. 0) PAR(427) = FN(1)
      IF (IPR(30) .EQ. 0) CALL PLA069
      PAGET = 'CAVITY'
      CALL PLA269 (0)
      OPEN (UNIT = LU60, FILE = NAME(1)(1:KNM(1))//'_cavity.spf',
     1      STATUS = 'UNKNOWN')
      WRITE (LU60, 99999) JID(1:74), (PAR(100 + I), I = 1, 6)
      IF (SPGRNM(1)(1:3) .NE. '   ') THEN
        WRITE (LU60, 99986) SPGRNM(1)(1:7)
      ELSE
        WRITE (LU60, 99985) SPGRNM(1)(13:13), SPGRNM(1)(14:14)
        DO 10 I = 2, IPR(255)
          CALL SGSM (ICL, I, XJX, 0, 2, IERR)
          WRITE (LU60, 99984) ICL(1:60)
   10   CONTINUE
      ENDIF
      DO 20 I = 1, 3
        IF (PAR(100 + I) .LT. 10.0) THEN
          V2(I) = 0.05
        ELSE IF (PAR(100 + I) .GT. 20.0) THEN
          V2(I) = 0.0125
        ELSE
          V2(I) = 0.025
        ENDIF
        DEV(I)     = - V2(I)
        DEV(I + 3) = 1.0 + V2(I)
        ITR(I)     = MIN (MP3, 3 + NINT (1.0 / V2(I)))
   20 CONTINUE
      NSYM = IPR(255) * IPR(256) * IPR(257)
      XMIR = PAR(427)
      NAT  = IPR(37)
      N3   = ITR(3)
      N2   = ITR(2)
      N1   = ITR(1)
      M3   = N3 - 1
      M2   = N2 - 1
      M1   = N1 - 1
      IF (LMT(IENS(IAN), 1) .EQ. 'Cg') THEN
        IAN0 = IAN - 1
      ELSE
        IAN0 = IAN
      ENDIF
      WRITE (LU6, 99995) (LMT(IENS(I), 1),  I = 1, IAN0)
      WRITE (LU7, 99995) (LMT(IENS(I), 1),  I = 1, IAN0)
      WRITE (LU6, 99994) (RADR(IENS(I), 4), I = 1, IAN0)
      WRITE (LU7, 99994) (RADR(IENS(I), 4), I = 1, IAN0)
      WRITE (LU7, 99990) (DEV(I), DEV(I + 3), V2(I), I = 1, 3)
      WRITE (LU6, 99988) (ITR(I), I = 1, 3)
      WRITE (LU7, 99988) (ITR(I), I = 1, 3)
      NTOT = 0
      DO 120 N = 1, NAT
        CALL GEN048 (-4, IFG(N), 15, IVAL)
        CALL PLA047 (XLAB(N), NQ1, IDUM, JDUM, IPR(119), IGBL(55), 0, 0)
        RADIUS = 1.5 * RADR(IVAL + 1, 4)
        WRITE (LU60, 99998) NQ1, (XXO(N, M), M = 1, 3)
        DO 110 M = 1, NSYM
          DO 30 I = 1, 3
            XJX(I + 3) = 0.0
            XJX(I)     = XXO(N, I)
   30     CONTINUE
          CALL SGSM (ICL, M, XJX, 6, 3, IER)
          DO 40 I = 7, 9
            XJX(I) = MOD (XJX(I), 1.0)
            IF (XJX(I) .LT. 0.0) XJX(I) = XJX(I) + 1.0
   40     CONTINUE
          DO 100 L = 1, 3
            V8(3) = XJX(9) + L - 2
            DO 90 K = 1, 3
              V8(2) = XJX(8) + K - 2
              DO 80 J = 1, 3
                V8(1) = XJX(7) + J - 2
                DO 50 I = 1, 3
                  IF (V8(I) .LT.  DEV(I) - RADIUS / PAR(100 + I)
     1                .OR. V8(I) .GT.  DEV(I + 3) +
     2                  RADIUS / PAR(100 + I)) GOTO 80
                  XF(I, NTOT + 1) = V8(I)
   50           CONTINUE
                IF (NTOT .NE. 0) THEN
                  DO 70 N9 = 1, NTOT
                    DO 60 I = 1, 3
                      V4(I) = ABS(XF(I, N9) - V8(I))
                      IF (V4(I) .GT. V2(I)) GOTO 70
   60               CONTINUE
                    GOTO 80
   70             CONTINUE
                ENDIF
                NTOT = NTOT + 1
                IF (NTOT .GE. MP1) THEN
                  WRITE (LU6, 99989) MP1
                  GOTO 280
                ENDIF
                XF(4, NTOT) =  RADIUS / 1.5
                XF(5, NTOT) = (RADIUS / 1.5 + XMIR) ** 2
   80         CONTINUE
   90       CONTINUE
  100     CONTINUE
  110   CONTINUE
  120 CONTINUE
      DO 180 IZ = 1, N3
        V5(3) = (IZ - 2) * V2(3)
        DO 170 IY = 1, N2
          V5(2) = (IY - 2) * V2(2)
          DO 160 IX = 1, N1
            V5(1) = (IX - 2) * V2(1)
            DMIN = 99.9
            DO 140 N = 1, NTOT
              DO 130 J = 1, 3
                V6(J) = XF(J, N) - V5(J)
  130         CONTINUE
              D2 = GEN006 (V6, AA, V6)
              IF (D2 .LE. XF(5, N)) THEN
                DMIN = 0.0
                GOTO 150
              ENDIF
              TEMP = SQRT(D2) - XF(4, N)
              IF (TEMP .LT. DMIN) DMIN = TEMP
  140       CONTINUE
  150       TJ(IX, IY, IZ) = DMIN
  160     CONTINUE
  170   CONTINUE
  180 CONTINUE
      WRITE (LU6, 99987) XMIR
      WRITE (LU7, 99987) XMIR
      INX = 0
      DO 240 K = 2, M3
        DO 230 J = 2, M2
          DO 220 I = 2, M1
            TJIJK = TJ(I, J, K)
            IF (TJIJK .GT. XMIR) THEN
              DO 210 I0 = 1, 3
                DO 200 J0 = 1, 3
                  DO 190 K0 = 1, 3
                    IF (I0 .NE. 2 .OR. J0 .NE. 2 .OR. K0 .NE. 2)
     1                THEN
                      IF (TJIJK .LT. TJ (I + I0 - 2, J + J0 - 2,
     1                    K + K0 - 2)) GOTO 220
                    ENDIF
  190             CONTINUE
  200           CONTINUE
  210         CONTINUE
              IF (INX .LT. MP2) THEN
                LL  = INX * 4 + 1
                INX = INX + 1
                AMX(LL)     = TJIJK
                AMX(LL + 1) = V2(1) * (I - 1) + DEV(1)
                AMX(LL + 2) = V2(2) * (J - 1) + DEV(2)
                AMX(LL + 3) = V2(3) * (K - 1) + DEV(3)
              ENDIF
            ENDIF
  220     CONTINUE
  230   CONTINUE
  240 CONTINUE
      NN = (INX - 1) * 4 + 1
  250 ITEST = 0
      DO 260 I = 1, NN - 4, 4
        IJ = I + 4
        IF (AMX(I) .LT. AMX(IJ)) THEN
          CALL GEN018 (AMX(I),     AMX(IJ))
          CALL GEN018 (AMX(I + 1), AMX(IJ + 1))
          CALL GEN018 (AMX(I + 2), AMX(IJ + 2))
          CALL GEN018 (AMX(I + 3), AMX(IJ + 3))
          ITEST = ITEST + 1
        ENDIF
  260 CONTINUE
      IF (ITEST .GT. 0) GOTO 250
      IF (INX .GT. 0) THEN
        WRITE (LU7, 99996)
        WRITE (LU7, 99992)
        IND = 0
        DO 270 I = 1, NN, 4
        IND = IND + 1
          WRITE (LU7, 99991) IND, (AMX(I + J), J = 1, 3), AMX(I)
          WRITE (LU6, 99991) IND, (AMX(I + J), J = 1, 3), AMX(I)
          IF (IND .GT. 99) THEN
            WRITE (LABL, '(''X'', I3)') IND
          ELSE IF (IND .GT. 9) THEN
            WRITE (LABL, '(''X'', I2)') IND
          ELSE
            WRITE (LABL, '(''X'', I1)') IND
          ENDIF
          WRITE (LU60, 99998) LABL, (AMX(I + J), J = 1, 3)
          WRITE (LU60, 99983) LABL,  AMX(I)
  270   CONTINUE
        WRITE (LU60, 99997)
        CLOSE (UNIT = LU60)
        IF (AMX(1) .LT. 5.0) THEN
          CALL SYSTEM
     1  (PLAPATH(1:IGBL(80))//' -p '//NAME(1)(1:KNM(1))//'_cavity.spf')
        ENDIF
      ELSE
        WRITE (LU6, 99993)
        CALL PLA015 (0, 52)
      ENDIF
  280 RETURN
99999 FORMAT ('TITL ', A, /, 'CELL', 6F12.4)
99998 FORMAT ('ATOM ', A, 3F10.4)
99997 FORMAT ('STRAW COLOR', /, 'UNITCELL', /, 'PACK', /, 'PLOT')
99996 FORMAT (//, 10X, 'Centers of CAVITIES with Their Radius', /)
99995 FORMAT (/, 'van der Waals (or ion) Radii used in the Analysis',
     1        /, 80('='), //, 16(3X, A))
99994 FORMAT (80('-'), /, 16F5.2)
99993 FORMAT (/, ':: No CAVITY''S Found in this Structure', /)
99992 FORMAT (29X, 'X', 7X, 'Y', 7X, 'Z', 7X, 'Radius (Ang)', /)
99991 FORMAT (10X, 'Cavity No.', I3, 3F8.3, 7X, F7.2)
99990 FORMAT (//, 9X, 'Map Intervals and Limits Along X,Y,Z', //,
     1        6X, 3(3X, 3F6.3))
99989 FORMAT (//, 1X, 'The Limit of', I5,
     1        ' Generated ATOMS has been Reached.')
99988 FORMAT (/, 10X, 'Number of Map Points Along X, Y, Z = ', 3I5, /)
99987 FORMAT (/, 10X, '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)
      END
      SUBROUTINE PLA208
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118,
     1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP22=256,
     2 NP25=99,NP29=63,NP38=125,NP39=30,NP41=200,NP45=2048,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /Q/ ICL, IFL(NP17)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /FNAME/ KNM(8), KXT, KNM16
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /SFCLC/ NATO, NNG(3), NGRID
      COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9),
     1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10),
     2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10),
     3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770)
      COMMON /NAMES/ NAME(8), EXTENS, PROGNM, FNLU1, FNLU16, RDTYPE
      CHARACTER NAME*80, EXTENS*9, PROGNM*28, FNLU1*80, FNLU16*80,
     1          RDTYPE*7
      DIMENSION NCT(16)
      IPR(495) = 0
      NB       = 1
      NE       = 80
      CALL GEN097 (NCT, 1, 16, 0)
      CALL PLA080
      CALL PLA287 (1, 1, 1)
      NAT  = IPR(37)
      NRES = IPR(75)
      OPEN (UNIT = LU62, FILE = NAME(1)(1:KNM(1))//'.rp1',
     1                                     STATUS = 'UNKNOWN')
      WRITE (LU62, 99999) JID(1:74), PAR(47),
     1       (PAR(100 + I), I = 1, 6), (PAR(106 + I), I = 1, 6)
      WRITE (LU62, 99998) (LMT(IENS(I), 1), I = 1, IAN)
      WRITE (LU62, 99997) (NINT(CONT(IENS(I), 2)), I = 1, IAN)
      DO 90 N = 1, NRES
        NSO = 0
        DO 80 I = 1, NATO
          CALL GEN048 (-6, IFG(I), 9, NR)
          IF (NR .EQ. N) THEN
            CALL PLA047 (XLAB(I), NQ1, MN, IENR, 0, IGBL(55), 0, 0)
            CALL GEN048 (-4, IFG(I), 15, NO1)
            NO1 = NO1 + 1
            CALL GEN048 (-1,  IFG(I), 4, IANIS)
            NCT(NO1) = NCT(NO1) + 1
            DO 10 L = 1, IAN
              IF (IENS(L) .EQ. NO1) THEN
                ISCFT = L
                GOTO 20
              ENDIF
   10       CONTINUE
   20       NQ3 = LMT(NO1, 1)
            IF (NQ3(1:1) .EQ. ' ') THEN
              NQ2 = NQ3(2:2)//'      '
            ELSE
              NQ2 = NQ3(1:2)//'     '
            ENDIF
            CALL GEN040 (NCT(NO1), NQ3, IP)
            IF (NQ2(2:2) .EQ. ' ') THEN
              NQ2(2:) = NQ3(1:IP)
            ELSE
              NQ2(3:) = NQ3(1:IP)
            ENDIF
            NS = (I - 1) / NAT + 1
            IF (NS .NE. NSO) THEN
              DO 40 K = 1, 3
                V2(K) = 0.0
   30           IF (XXO(I, K) + V2(K) .LT. 0.0) THEN
                  V2(K) = V2(K) + 1.0
                  GOTO 30
                ENDIF
   40         CONTINUE
              DO 60 K = 1, 3
   50           IF (XXO(I, K) + V2(K) .GE. 1.0) THEN
                  V2(K) = V2(K) - 1.0
                  GOTO 50
                ENDIF
   60         CONTINUE
              NSO = NS
              DO 70 K = 1, 3
                XJX(K + 3) = V2(K)
   70         CONTINUE
              CALL SGSM (ICL, NS, XJX, 0, 20, IER)
              CALL GEN047 (ICL, 1, 80)
              CALL GEN039 (1, ICL, 1, 80, NB, NE)
            ENDIF
            WRITE (LU62, 99993) NQ2, NQ1, ICL(1:NE)
            WRITE (LU62, 99995)
     1      NQ2, ISCFT, (XXO(I, J) + V2(J), J = 1, 3), XXO(I, 4) + 10.0
            NANIS = 1 + IANIS * 5
            WRITE (LU62, 99994) (XSD(I, J), J = 1, NANIS)
          ENDIF
   80   CONTINUE
   90 CONTINUE
      WRITE (LU62, 99996)
      CLOSE (LU62)
      IF (IPR(2) .EQ. 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 ('END')
99995 FORMAT (A, I3, 4F10.4, ' =')
99994 FORMAT (5X, 6F10.6)
99993 FORMAT (7X, 'new: ', A, ' = old: ', A, '[', A, ']')
      END
      SUBROUTINE PLA209
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118,
     1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP22=256,
     2 NP25=99,NP29=63,NP38=125,NP39=30,NP41=200,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9),
     1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10),
     2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10),
     3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /FNAME/ KNM(8), KXT, KNM16
      COMMON /NAMES/ NAME(8), EXTENS, PROGNM, FNLU1, FNLU16, RDTYPE
      CHARACTER NAME*80, EXTENS*9, PROGNM*28, FNLU1*80, FNLU16*80,
     1          RDTYPE*7
      DIMENSION QUADRIC(10), UU(4, 4), UINV(4, 4), EIGENS(4),
     1 EVECS(4, 4), EVECINV(4, 4), EVECIT(4, 4), QQQ(4, 4), QP(4, 4),
     2 TEMP(4, 4)
      COMMON /PATHS/ PLAPATH, BROWSER, CGETENV
      CHARACTER PLAPATH*255, BROWSER*255, CGETENV*255
      COMMON /MSWDS/ DOS
      LOGICAL DOS
      CHARACTER REDIR*4, TIFF*5
      INTEGER FINDEXE
      EXTERNAL SYSTEM
      IF (DOS) THEN
        REDIR = ' -i '
      ELSE
        REDIR = '  < '
      ENDIF
      IF (IGBL(109) .EQ. 0) THEN
        TIFF = 'tiff'
      ELSE
        TIFF = 'png'
      ENDIF
      CALL GEN021 (EVECINV, 0)
      ASPECT = 1280.0 / 1024.0
      RADIUS = 0.10
      XMARG  = 1.15
      RAD    = PAR(46) / (4.0 * GL(6))
      OPEN (UNIT = LU64, FILE = NAME(1)(1:KNM(1))//'.rst',
     1                          STATUS = 'UNKNOWN')
      OPEN (UNIT = LU65, FILE = NAME(1)(1:KNM(1))//'.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 .GE. 1.0) THEN
        XROOM = ASPECT
        YROOM = 1.0
        ZROOM = 2.0
      ELSE
        XROOM = 1.0
        YROOM = ASPECT
        ZROOM = 2.0
      ENDIF
      SCALE = MAX ((PAR(58) - PAR(55) + 2 * RAD) / XROOM,
     1             (PAR(59) - PAR(56) + 2 * RAD) / YROOM,
     2             (PAR(60) - PAR(57) + 2 * RAD) / ZROOM)
      SCALE = SCALE / 0.90
      WRITE (LU65, 99999) TX, TY, TZ, SCALE
      IF (RADIUS .GT. 0.0) THEN
        KNCD = IPR(39) + IPR(64)
        DO 30 NCD = 1, IPR(131)
          KNCD = KNCD + 1
          IAT = NINT(XSD(KNCD, 4))
          JAT = NINT(XSD(KNCD, 5))
          CALL PLA047 (XLAB(IAT), NQ1, IDUM, IENR1, 0, IGBL(55), 1, 0)
          CALL PLA047 (XLAB(JAT), NQ2, IDUM, IENR2, 0, IGBL(55), 1, 0)
          CALL GEN048 (-4,  IFG(IAT), 15, IEN1)
          CALL GEN048 (-4,  IFG(JAT), 15, IEN2)
          ICOL = IACL(IEN1 + 1)
          JCOL = IACL(IEN2 + 1)
          CALL GEN108 (LU64, 0)
          NS = 0
   10     READ (LU64, 99988, END = 30) LINE
          IF (LINE(1:4) .NE. 'ATOM')  GOTO 10
          IF (NQ1 .EQ. LINE(13:19)) THEN
            READ (LINE(31:54), 99990) V1(1), V1(2), V1(3)
            NS = NS + 1
          ELSE IF (NQ2 .EQ. LINE(13:19)) THEN
            READ (LINE(31:54), 99990) V2(1), V2(2), V2(3)
            NS = NS + 1
          ENDIF
          IF (NS .LT. 2) GOTO 10
          WRITE (LU65, 99993) NQ1, NQ2
          IF (ICOL .EQ. JCOL) THEN
            WRITE (LU65, 99994) (V1(K), K = 1, 3), RADIUS,
     1           (V2(K), K = 1, 3), RADIUS,
     3           RGB(1, ICOL), RGB(2, ICOL), RGB(3, ICOL)
          ELSE
            DO 20 K = 1, 3
              V3(K) = (V1(K) + V2(K)) / 2
   20       CONTINUE
            WRITE (LU65, 99994) (V1(K), K = 1, 3), RADIUS,
     1           (V3(K), K = 1, 3), RADIUS,
     3           RGB(1, ICOL), RGB(2, ICOL), RGB(3, ICOL)
            WRITE (LU65, 99994) (V3(K), K = 1, 3), RADIUS,
     1           (V2(K), K = 1, 3), RADIUS,
     3           RGB(1, JCOL), RGB(2, JCOL), RGB(3, JCOL)
          ENDIF
   30   CONTINUE
      ENDIF
      IF (IPR(148) .NE. 0) THEN
        NB = 1
        NE = 2
        IF (IPR(148) .EQ. 1) NB = 2
        IF (IPR(148) .EQ. 2) NE = 1
        DO 120 NS = NB, NE
          CALL GEN108 (LU64, 0)
   40     READ (LU64, 99988, END = 110) LINE
          IF (LINE(1:4) .EQ. 'ATOM') THEN
            IF (LINE(13:13) .NE. ' ') CALL GEN020 (-1, LINE, 14, 14)
            IF (LINE(13:14) .NE. 'CG') THEN
              DO 50 I = 1, 16
                IF (LINE(13:14) .EQ. LMT(I, 1)) THEN
                  ICOL = IACL(I)
                  GOTO 60
                ENDIF
   50         CONTINUE
              ICOL = 1
            ELSE
              GOTO 40
            ENDIF
   60       READ (LINE(31:54), 99990) X, Y, Z
            READ (LU64, 99988, END = 110) LINE
            READ (LINE(29:70), 99989) (DUMA(I), I = 1, 6)
            CALL GEN074 (EIGENS, 0.0, 1, 3)
            CALL GEN074 (EVECS,  0.0, 1, 16)
            CALL GEN074 (UU,     0.0, 1, 16)
            CALL GEN074 (UINV,   0.0, 1, 16)
            EIGENS(4)   = 1.0
            EVECS(4, 4) = 1.0
            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
            IF (GEN061 (UU, UINV) .EQ. 0.0) STOP 'PLA209'
            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)
            CALL GEN064 (UU, 3, 4, EIGENS, EVECS)
            DO 70 I = 1, 3
              IF (EIGENS(I) .GT. 0.0) THEN
                EIGENS(I) = SQRT(EIGENS(I))
              ELSE
                GOTO 40
              ENDIF
   70       CONTINUE
            RADLIM = PAR(46) * MAX (EIGENS(1), EIGENS(2), EIGENS(3))
     1             * XMARG
            IF (NS .EQ. 1) THEN
              IF (GEN061 (EVECS, EVECINV) .EQ. 0.0) STOP 'PLA209'
              CALL GEN060 (EVECINV, EVECIT)
              DO 100 K = 1, 3
                DO 90 I = 1, 4
                  DO 80 J = 1, 4
                    QQQ(I, J) = 0.0
   80             CONTINUE
                  QQQ(I, I) = 1.0 / EIGENS(I)**2
   90           CONTINUE
                QQQ(K, K) = 1000.0
                QQQ(4, 4) = - PAR(46) ** 2
                CALL GEN059 (QQQ, EVECINV, TEMP)
                CALL GEN059 (EVECIT, TEMP, QP)
                IF (ICOL .NE. 8) THEN
                  WRITE (LU65, 99996) LINE(13:19), X, Y, Z, RADLIM,
     1                         (RGB(L, ICOL), L = 1, 3)
                  WRITE (LU65, 99995) QP(1, 1), QP(2, 2), QP(3, 3),
     1                          QP(1, 2), QP(2, 3), QP(1, 3),
     2                          QP(1, 4), QP(2, 4), QP(3, 4), QP(4, 4)
                ENDIF
  100         CONTINUE
            ELSE
              IF (ICOL .NE. 8) THEN
                WRITE (LU65, 99996) LINE(13:19), X, Y, Z, RADLIM,
     1                         (RGB(K, ICOL), K = 1, 3)
                WRITE (LU65, 99995) (QUADRIC(I), I = 1, 10)
              ENDIF
            ENDIF
          ENDIF
          GOTO 40
  110     IF (NS .EQ. 1) THEN
            IF (IPR(148) .EQ. 3) THEN
              WRITE (LU65, 99998)
            ELSE IF (IPR(148) .EQ. 2) THEN
              GOTO 130
            ENDIF
          ELSE
            IF (IPR(148) .EQ. 3) WRITE (LU65, 99997)
          ENDIF
  120   CONTINUE
      ENDIF
  130 CLOSE (LU64)
      CLOSE (LU65)
      CALL GEN038 (CGETENV, 1, 255)
      NE = FINDEXE ('R3DEXE', CGETENV, 'render')
      IF (NE .GT. 0) THEN
        CGETENV(NE + 1:)  = REDIR//NAME(1)(1:KNM(1))//
     1 '.r3d  -'//TIFF//NAME(1)(1:KNM(1))//'.'//TIFF
        CALL SYSTEM (CGETENV)
        CALL GEN038 (CGETENV, 1, 255)
        NE = FINDEXE ('XVWEXE', CGETENV, 'display')
        IF (NE .EQ. 0) THEN
          WRITE (LU6, 99992)
          NE = FINDEXE ('XVWEXE', CGETENV, 'xv')
        ENDIF
        IF (NE .EQ. 0) THEN
          WRITE (LU6, 99991)
          NE = FINDEXE ('XVWEXE', CGETENV, 'gimp')
        ENDIF
        IF (NE .GT. 0) THEN
          CGETENV(NE + 1:) = ' '//NAME(1)(1:KNM(1))//'.'//TIFF//' &'
          CALL SYSTEM (CGETENV)
        ENDIF
      ELSE
        CALL PLA015 (0, 9)
      ENDIF
      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 PLA210 (PAR, OR, UIJ, UIL, DUMA, RIK, UEQ)
      DIMENSION PAR(*), OR(3, 3), ROR(3, 3), UIJ(3, 3), DUMA(6),
     1 RIK(3, 3), RLJ(3, 3), UKL(3, 3), UIL(3, 3)
      CALL GEN003 (OR, ROR, DET, 0)
      DO 20 K = 1, 3
        DO 10 L = 1, 3
          RLJ(K, L) = 0.0
          IF (K .EQ. L) RLJ(K, K) = PAR(112 + K)
   10   CONTINUE
   20 CONTINUE
      CALL GEN004 (OR, RLJ, UKL)
      CALL GEN001 (1, UKL, UIJ, UIL)
      CALL GEN024 (UIL, RIK, DUMA, RLJ)
      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 30 J = 1, 3
        SUM = SQRT(RIK(1, J)**2 + RIK(2, J)**2 + RIK(3, J)**2)
        RIK(1, J) = RIK(1, J) / SUM
        RIK(2, J) = RIK(2, J) / SUM
        RIK(3, J) = RIK(3, J) / SUM
   30 CONTINUE
      UEQ = (DUMA(1) + DUMA(2) + DUMA(3)) / 3.0
      RETURN
      END
      SUBROUTINE PLA211 (LU6, LU7, JID)
      PARAMETER (NMA=550, NMG=120)
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118,
     1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP25=99,
     2 NP29=63,NP38=125,NP39=30,NP41=200,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9),
     1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10),
     2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10),
     3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770)
      COMMON /AT2/ DCM, INDWGH
      COMMON /ORIE/ ORX(3, 3), OT(3, 3), OTI(3, 3), BARC(3), BARO(3),
     1 RIN(3)
      COMMON /SRC/ XO(3, NMA), XS(3, NMA), D(NMA), CO(3, NMA), IV(NMA),
     1 COY(3,NMA), WWW(NMA), NGE(NMA), WGHT(NMA), DC(NMA), TRL(3, NMG),
     2 CF(NMA), MK(NMA, NMG), MN(NMA), MD(NMA, 2), RMSX(3, NMA),
     3 ISU(NMG), IASU(NMA), SIM(3, 3, NMG), DEVX(NMG), CSM(NMG),
     4 MTG(NMG, NMG), IAT(NMA), DA(NMA), MEQ(NMA), AL(3, 3), ALX(3, 3),
     5 AAY(3, 3), DEL(4), DELM(4), ORI(3, 3), CSMT, NMS, RMST
      CHARACTER LINE*80, RIGA*40, OLDPT*7, PT*7, S1*1, S2*1, SN*2,
     1 TOT*4, LBLS(NMG)*3
      COMMON /PAGENM/ PAGET, PAGEIND(25)
      CHARACTER PAGET*8, PAGEIND*8
      COMMON /POINTGR/ PNTGR(32)
      CHARACTER PNTGR*5
      CHARACTER JID*(*), PRBUF*132
      COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0
      ICOM = 0
      MOO  = -1
      IF (IGBL(25) * IGBL(32) .EQ. 1 .AND. IPR(495) .EQ. 2 .AND.
     1  IPR(121) .EQ. 0) THEN
        IWIN = 1
        CALL GGIP (HORS, VERT, 0.0, 1)
        VRT = VERT - 0.8
        WRITE (PRBUF, '(15X, ''PLATON/MOLSYM for '', A)') JID(1:20)
        CALL GGIP20 (0.0, PRBUF, 80, 0.50, 5 + IGBL(68), 2, 1.0, VRT)
        VRT = VRT - 0.2
        CALL GGIP (0.0, 0.0, 0.0, 6)
      ELSE
        IWIN = 0
      ENDIF
      PAGET = 'MOLSYM'
      CALL PLA269 (-6)
      WRITE (LU7, 99998)
      MO = 0
      NA = IPR(39)
   10 MO = MO + 1
      IF (MO .GT. IPR(75)) GOTO 860
      OLDPT = ' '
      IPRW  = 0
      DCM   = PAR(73)
   20 INDWGH  = 1
      DELINER = 0.1
      CALL GEN074 (SIM, 0.0, 1, 9 * NMG)
      CALL GEN021 (AL, 1)
      SIM(1, 1, 1) = 1.0
      SIM(2, 2, 1) = 1.0
      SIM(3, 3, 1) = 1.0
      IES          = 0
      N            = 0
      NMS          = 1
      DO 40 I = 1, NA
        CALL GEN048 (-7, JFG(I), 1, IPP)
        IF (IPPR(IPP + 1, 1) .LT. 1000) THEN
          N = 0
          GOTO 10
        ENDIF
        CALL GEN048 (-1, IFG(I), 7, IHAT)
        IF (IHAT .EQ. 0) THEN
          CALL GEN048 (-6, IFG(I), 9, IRES)
          IF (IRES .EQ. MO) THEN
            N = N + 1
            IF (N .GT. NMA) THEN
              CALL PLA269 (3)
              WRITE (LU6, 99990) MO
              WRITE (LU7, 99990) MO
              GOTO 860
            ENDIF
            IASU(I) = 2
            DO 30 K = 1, 3
              XO(K, N) = XXO(I, K + 3)
   30       CONTINUE
            CALL GEN048 (-4, IFG(I), 15, NO1)
            NO1 = NO1 + 1
            IF (INDWGH .EQ. 1) THEN
              WGHT(N) = ATWT(IEN(NO1))
            ELSE
              WGHT(N) = 1.0
            ENDIF
            MN(N)    = NO1
            MK(N, 1) = N
          ENDIF
        ENDIF
   40 CONTINUE
      PORIG = WGHT(1)
      IF (N .LE. 2) GOTO 10
      NLOOP = 0
   50 CALL GEN021 (PAT, 1)
      CALL GEN074 (BARO, 0.0, 1, 3)
      CALL GEN074 (SDV,  0.0, 1, 6)
      SUM = 0.0
      DO 60 I = 1, N
        BARO(1) = BARO(1) + WGHT(I) * XO(1, I)
        BARO(2) = BARO(2) + WGHT(I) * XO(2, I)
        BARO(3) = BARO(3) + WGHT(I) * XO(3, I)
        SUM     = SUM + WGHT(I)
   60 CONTINUE
      IF (SUM .EQ. 0.0) GOTO 870
      DO 70 I = 1, 3
        BARO(I) = BARO(I) / SUM
   70 CONTINUE
      DO 80 I = 1, N
        XO(1, I) = XO(1,I) - BARO(1)
        XO(2, I) = XO(2,I) - BARO(2)
        XO(3, I) = XO(3,I) - BARO(3)
        V2(1)    = XO(1, I) * WGHT(I)
        V2(2)    = XO(2, I) * WGHT(I)
        V2(3)    = XO(3, I) * WGHT(I)
        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)
   80 CONTINUE
      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)
      DO 90 I = 1, N
        CALL GEN078 (ORX, XO, XO, 1, I, I)
   90 CONTINUE
      DM = 0.0
      DO 100 I = 1, N
        CALL GEN075  (XO, XO, D(I), I, I, 2)
        IF (D(I) .GT. DM) DM = D(I)
  100 CONTINUE
      MDEG = 0
      DELR = ABS(RIN(1) - RIN(2)) / RIN(1)
      IF (DELR .LE. DELINER) MDEG = 1
      DELR = ABS(RIN(2) - RIN(3)) / RIN(1)
      IF (DELR .LE. DELINER) MDEG = MDEG + 2
      ND = (MDEG + 1) / 2 + 1
      IF (MDEG .EQ. 1) THEN
        DO 110 I = 1, N
          COM = SQRT(XO(1, I) ** 2 + XO(2, I) ** 2)
          IF (COM .GT. DCM) GOTO 120
  110   CONTINUE
        CALL GEN074 (CO, 0.0, 1, 9)
        CO(1, 1) = -1.0
        CO(2, 2) = -1.0
        CO(3, 3) =  1.0
        CALL PLA212 (CO, MV, N)
        CO(3, 3) = -1.0
        CALL PLA212 (CO, MV, N)
        MDEG = 5
        GOTO 470
      ENDIF
      IF (MDEG .EQ. 3) THEN
        GOTO 270
      ELSE IF (MDEG .EQ. 2) THEN
        CALL GEN074 (CO, 0.0, 1, 9)
        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))
      ENDIF
  120 IU = 3
      IB = 2
      IC = 1
      MORD = 9
      IF (MDEG .EQ. 0) MORD = 3
      NASS = 1
  130 MORD = MORD - 1
      IF (MORD .EQ. 3 .AND. MDEG .EQ. 3) MORD = 2
      IF (MORD .EQ. 1) GOTO 160
  140 COST = 1.0
      CALL GEN074 (CO, 0.0, 1, 9)
      ROT = GL(6) / FLOAT(MORD)
      CA  = COS(ROT)
      CB  = SIN(ROT)
  150 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
      CALL PLA212 (CO, MV, N)
      IF (MV .NE. 1) THEN
        IF (COST .EQ. -1.0) GOTO 130
        COST = -1.0
        GOTO 150
      ENDIF
      IF (MORD .EQ. 3 .OR. MORD .EQ. 6) IES = 1
      IF (MDEG .EQ. 1 .AND. MORD .GT. 2) GOTO 170
      IF (MORD .GT. 2) GOTO 130
  160 NASS = NASS + 1
      IF (NASS .EQ. 4) GOTO 450
      MORD = 2
      I    = IU
      IU   = IB
      IB   = IC
      IC   = I
      GOTO 140
  170 CALL GEN074 (CO, 0.0, 1, 18)
      CO(3, 3) = 1.0
      DO 180 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
  180 CONTINUE
      IAI = 0
      N1 = N - 1
      DO 200 I = 1, N1
        IF (MD(I, 1) .EQ. 0) THEN
          IAI        = IAI + 1
          MD(I, 1)   = IAI
          MD(IAI, 2) = 1
          J          = I + 1
          DO 190 K = J, N
            IF (MN(I) .NE. MN(K) .OR. K .EQ. I
     1                .OR. MD(K, 1) .NE. 0) GOTO 190
            IF (ABS(D(I) - D(K)) .GT. 0.5 * DCM) GOTO 190
            MD(K, 1)   = IAI
            MD(IAI, 2) = MD(IAI, 2) + 1
  190     CONTINUE
        ENDIF
  200 CONTINUE
      JJ = 10000
      DO 210 I = 1, IAI
        IF (MD(I, 2) .LT. JJ .OR. MD(I, 2) .GT. 2) JJ = MD(I, 2)
  210 CONTINUE
      DM = 0.0
      DO 230 I = 1, IAI
        IF (MD(I, 2) .EQ. JJ) THEN
          DO 220 K = 1, N
            IF (MD(K, 1) .EQ. I) THEN
              IF (D(K) .GT. DM) THEN
                DM = D(K)
                II = I
              ENDIF
            ENDIF
  220     CONTINUE
        ENDIF
  230 CONTINUE
      CALL GEN074 (AAY, 0.0, 1, 9)
      N1 = N - 1
      DO 260 I1 = 1, N1
        IF (MD(I1, 1) .EQ. II) THEN
          IN1 = I1 + 1
          DO 250 I2 = IN1, N
            IF (MD(I2, 1) .EQ. 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 .LE. 0.00001) GOTO 250
              CALL GEN082 (CO, 2)
              CALL GEN076 (CO, CO, CO, 2, 3, 1)
              CALL GEN081 (CO, CO, 1, 1)
              CALL PLA214 (CO, N)
              COM = 1.0
  240         AAY(1, 1) = -1
              AAY(2, 2) = -1
              AAY(3, 3) =  COM
              CALL PLA212 (AAY, MV, N)
              AAY(1, 1) = -1
              AAY(2, 2) =  1
              AAY(3, 3) =  COM
              CALL PLA212 (AAY, MV, N)
              AAY(1, 1) =  1
              AAY(2, 2) = -1
              AAY(3, 3) =  COM
              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
              CALL PLA212 (AAY, MV, N)
              IF (NMS .GE. 3) GOTO 130
              IF (COM .LE. 0.0) GOTO 250
              COM = - COM
              CALL GEN074 (AAY, 0.0, 1, 9)
              GOTO 240
            ENDIF
  250     CONTINUE
        ENDIF
  260 CONTINUE
      GOTO 450
  270 N1 = N - 1
      N2 = N - 2
      DO 290 I = 1, N
        MD(I, 1) = 0
        MD(I, 2) = 0
        DO 280 J = 2, NMG
          MK(I, J) = 0
  280   CONTINUE
  290 CONTINUE
      IAI = 0
      DO 310 I = 1, N1
        IF (MD(I, 1) .EQ. 0) THEN
          IAI        = IAI + 1
          MD(I, 1)   = IAI
          MD(IAI, 2) = 1
          J = I + 1
          DO 300 K = J, N
            IF (MN(I) .NE. MN(K) .OR. K .EQ. I
     1                .OR. MD(K, 1) .NE. 0) GOTO 300
            IF (ABS(D(I) - D(K)) .LE. 0.5 * DCM) THEN
              MD(K, 1)   = IAI
              MD(IAI, 2) = MD(IAI, 2) + 1
            ENDIF
  300     CONTINUE
        ENDIF
  310 CONTINUE
      CALL GEN074 (CO, 0.0, 1, 9)
      MMD = 1000
      DO 320 I = 1, IAI
        IF (MD(I, 2) .LT. MMD .AND. MD(I, 2) .GT. 1) THEN
          MMD = MD(I, 2)
          II  = I
        ENDIF
  320 CONTINUE
      IER = 0
      IF (MD(II, 2) .EQ. 12 .OR. MD(II, 2) .EQ. 20 .OR. MD(II, 2)
     1       .EQ. 30 .OR. MD(II, 2) .GT. 48)
     2        CALL PLA213 (N, II, MDEG, IER, LU6)
      IF (IER .NE. 0) GOTO 620
      IF (MDEG .EQ. 1) GOTO 120
      IF (NMS .GE. 5) THEN
        MDEG = 1
        CALL GEN074 (AAY, 0.0, 1, 9)
        DO 340 I = 1, 3
          DO 330 J = 1, 3
            IF (J .EQ. 4 - I) THEN
              AAY(J, J) = -1
            ELSE
              AAY(J, J) =  1
            ENDIF
  330     CONTINUE
          CALL PLA212 (AAY, MV, N)
  340   CONTINUE
        GOTO 450
      ENDIF
      CA = 0.0
      CALL GEN074 (AAY, 0.0, 1, 9)
      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
      N2 = N - 2
      N1 = N - 1
      DO 390 I1 = 1, N2
        IF (MD(I1, 1) .EQ. II) THEN
          IN1 = I1 + 1
          DO 380 I2 = IN1, N1
            IF (MD(I2, 1) .EQ. 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 370 I3 = IN2, N
                IF (MD(I3, 1) .EQ. 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) .GT. DCM) GOTO 370
                  IF (ABS(CA - CC) .GT. DCM) GOTO 370
                  IF (ABS(CB - CC) .GT. DCM) GOTO 370
                  CO(1, 3) = XO(1, I1) + XO(1, I2) + XO(1, I3)
                  CO(2, 3) = XO(2, I1) + XO(2, I2) + XO(2, I3)
                  CO(3, 3) = XO(3, I1) + XO(3, I2) + XO(3, I3)
                  CALL GEN082 (CO, 3)
                  CO(1, 6 + NMS1) = CO(1, 3)
                  CO(2, 6 + NMS1) = CO(2, 3)
                  CO(3, 6 + NMS1) = CO(3, 3)
                  IF (NMS1 .GT. 1) THEN
                    CALL GEN075 (CO, CO, PRO, 7, 8, 1)
                    IF (ABS(PRO) .GT. 0.9) GOTO 370
                    IF (PRO .GT. 0.0) THEN
                      CO(1, 8) = - CO(1, 8)
                      CO(2, 8) = - CO(2, 8)
                      CO(3, 8) = - CO(3, 8)
                    ENDIF
                  ENDIF
                  DO 350 I = 1, 3
                    CALL GEN074 (CO, 0.0, 1, 3)
                    CO(I, 1) = 1.0
                    CALL GEN075 (CO, CO, PRO, 1, 3, 1)
                    IF (ABS(PRO) .GT. 0.5) GOTO 360
  350             CONTINUE
  360             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)
                  CALL PLA212 (AAY, MV, N)
                  NMS  = 1
                  NMS1 = NMS1 + MV
                  CALL GEN081 (CO, CO, 1, 1)
                  CALL PLA214 (CO, N)
                  IF (NMS1 .EQ. 3) GOTO 430
                ENDIF
  370         CONTINUE
            ENDIF
  380     CONTINUE
        ENDIF
  390 CONTINUE
      IF (NMS1 .EQ. 1) THEN
        IF (PORIG .NE. WGHT(1)) THEN
          DELINER = DELINER * 0.1
          GOTO 50
        ENDIF
        IPRW = IPRW + 1
        IF (IPRW .EQ. 1) THEN
          CALL PLA269 (2)
          WRITE (LU7, 99992)
        ENDIF
        DO 400 K = 1, N
          WGHT(K) = WGHT(K) * (D(K) / DM)**4
  400   CONTINUE
        NLOOP = NLOOP + 1
        IF (NLOOP .LT. 100) GOTO 50
      ENDIF
      CO(1, 3) = CO(1, 7)
      CO(2, 3) = CO(2, 7)
      CO(3, 3) = CO(3, 7)
      DO 410 I = 1, 3
        CALL GEN074 (CO, 0.0, 1, 3)
        CO(I, 1) = 1.0
        CALL GEN075 (CO, CO, PRO, 1, 3, 1)
        IF (ABS(PRO) .GT. 0.5) GOTO 420
  410 CONTINUE
  420 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)
      GOTO 440
  430 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, 0.0, 1, 9)
      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)
      CALL PLA214 (CO, N)
      CALL GEN074 (AAY, 0.0, 1, 9)
      AAY(1, 2) = 1.0
      AAY(2, 3) = 1.0
      AAY(3, 1) = 1.0
      CALL PLA212 (AAY, MV, N)
      NASS = 1
      IU   = 1
      IB   = 2
      IC   = 3
      MORD = 4
      CALL GEN074 (CO, 0.0, 1, 9)
      CO(1, 1) = -1.0
      CO(2, 2) = -1.0
      CO(3, 3) =  1.0
      CALL PLA212 (CO, MV, N)
      IF (MV .EQ. 1) GOTO 140
      CALL GEN074 (CO, 0.0, 1, 9)
      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)
  440 NMS  = 1
      MORD = 6
      MDEG = 1
      IU   = 3
      IB   = 2
      IC   = 1
      WRITE (LU6, 99993)
      GOTO 460
  450 II = 2
      CALL GEN021 (CO, -1)
      CALL PLA212 (CO, MV, N)
  460 IF (NMS .EQ. 1) THEN
        IF (DCM .GE. PAR(75)) THEN
          WRITE (LU6, 99995) MO, DCM
          CALL PLA269 (2)
          WRITE (LU7, 99995) MO, DCM
          GOTO 10
        ELSE
          DCM = DCM + 0.1
          GOTO 20
        ENDIF
      ENDIF
  470 IER = 0
      CALL PLA215 (N, IER)
      IF (IER .NE. 0) GOTO 860
      IF (MDEG .EQ. 5) GOTO 620
      NTEST = 0
      DO 480 I = 1, NMS
        IF (MTG(I, I) .NE. 1) NTEST = 1
  480 CONTINUE
      IF (NMS .EQ. 2 .OR. NMS .EQ. 4) THEN
        NAX2 = 0
        LAX2 = 0
        DO 490 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 .NE. 3) GOTO 520
          IF (ITRAC .EQ. -1) THEN
            NAX2 = NAX2 + 1
            LAX2 = I
          ENDIF
  490   CONTINUE
        IF (NAX2 .EQ. 0 .OR. NAX2 .EQ. 3) GOTO 620
        IF (NAX2 .EQ. 1) THEN
          DO  500 L = 1, 3
            IF (NINT(SIM(L, L, LAX2)) .EQ. 1) GOTO 510
  500     CONTINUE
  510     IF (L .EQ. 3) GOTO 620
          CALL GEN074 (CO, 0.0, 1, 9)
          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))
        ENDIF
        NMS = 1
        GOTO 120
      ENDIF
  520 IF (NTEST .NE. 0 .AND. MDEG .NE. 0) THEN
        IF (MDEG .EQ. 1) THEN
          IAXV = 0
          DO 540 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 .EQ. 3) THEN
              ITRAC = INT((SIM(1, 1, I) + SIM(2, 2, I) + SIM(3, 3, I))
     1              * 1.001)
              IAX = ITRAC
              IF (ITRAC .NE. NINT(SIM(3, 3, I))) GOTO 540
              IAX = - ITRAC * I
              DO 530 J = 1, 2
                IF (ITRAC .NE. NINT(SIM(J, J, I))) ICOM = J
  530         CONTINUE
              IF (IAX .GT. 0) GOTO 550
            ENDIF
  540     CONTINUE
          GOTO 620
  550     V3(3)        = 0.0
          V3(ICOM)     = 1.0
          V3(3 - ICOM) = 0.0
          IAXV         = IABS(IAX)
          IF (IAX .EQ. 0) GOTO 620
          CALL PLA216 (V3, N, IAXV, LU6)
          COST = 0.0
          DO 560 I = 1, 3
            IF (ABS(V3(I)) .GT. COST) THEN
              COST = ABS(V3(I))
              ICOM = I
            ENDIF
  560     CONTINUE
          COST = 1.0
          IF (V3(ICOM) .LT. 0.0) COST = -1.0
          CALL GEN074 (AAY, 0.0, 1, 9)
          AAY(3, 3)    = 1.0
          AAY(1, ICOM) = COST * V3(1)
          AAY(2, ICOM) = COST * V3(2)
          AAY(3, ICOM) = COST * V3(3)
          IF (ICOM .EQ. 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)
          ENDIF
          CALL GEN082 (AAY, 1)
          CALL GEN082 (AAY, 2)
          GOTO 610
        ENDIF
        IF (MDEG .EQ. 3) THEN
          CALL GEN074 (CO, 0.0, 1, 9)
          CO(1, 1) =  1.0
          CO(2, 2) = -1.0
          CO(3, 3) = -1.0
          DO 570 K = 1, NMS
            L = NINT (GEN086 (SIM, CO, 0.001, K, 1))
            IF (L .EQ. 1) GOTO 580
  570     CONTINUE
  580     V3(1) = 1.0
          V3(2) = 0.0
          V3(3) = 0.0
          CALL PLA216 (V3, N, K, LU6)
          AAY(1, 1) = V3(1)
          AAY(2, 1) = V3(2)
          AAY(3, 1) = V3(3)
          CO(1, 1)  = -1.0
          CO(2, 2)  =  1.0
          CO(3, 3)  = -1.0
          DO 590 K = 1, NMS
            L = NINT (GEN086 (SIM, CO, 0.001, K, 1))
            IF (L .EQ. 1) GOTO 600
  590     CONTINUE
  600     V3(1)     = 0.0
          V3(2)     = 1.0
          V3(3)     = 0.0
          AAY(1, 2) = V3(1)
          AAY(2, 2) = V3(2)
          AAY(3, 2) = V3(3)
          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)
        ENDIF
  610   CALL GEN081 (AAY, AAY, 1, 1)
        CALL PLA214 (AAY, N)
      ENDIF
  620 CSM(1)  = 0.0
      DEVX(1) = 0.0
      DO 650 I = 2, NMS
        NES      = 1
        ISU(1)   = NES
        K        = I
  630   NES      = NES + 1
        ISU(NES) = K
        L        = MTG(I, K)
        IF (L .NE. 1) THEN
          K = L
          GOTO 630
        ENDIF
        CALL PLA217 (COMT, NES, N)
        DEVX(I) = DELM(4)
        CSM(I)  = COMT
  650 CONTINUE
      DO 660 I = 1, NMS
        ISU(I) = I
  660 CONTINUE
      CALL PLA217 (CSMT, NMS, N)
      N1 = N
      CALL GEN097 (IASU, 1, N1, 2)
      DO 680 I = 1, N1
        IF (IASU(I) .EQ. 2) THEN
          DO 670 J = 1, NMS
            K = MK(I, J)
            IF (K .NE. I) THEN
              IF (K .EQ. 0) THEN
                IASU(I) = 0
                GOTO 680
              ENDIF
              IASU(K) = 1
            ENDIF
  670     CONTINUE
        ENDIF
  680 CONTINUE
      DO 690 I = 1, 4
        DEL(I) = DEL(I) / FLOAT(N)
  690 CONTINUE
      DO 720 I = 1, N
        DO 710 J = 1, NMS
          K = MK(I, J)
          CALL GEN078 (SIM, XS, V3, J, I, 1)
          DO 700 L = 1, 3
            DIFF = ABS(XS(L, K) - V3(L))
            IF (DIFF .GT. 0.001) THEN
              GOTO 730
            ENDIF
  700     CONTINUE
  710   CONTINUE
  720 CONTINUE
  730 IPGR    = 0
      MAXASP  = 0
      MAXASI  = 0
      MPLANE  = 0
      INVERS  = 0
      NPLANE  = 0
      LBLS(1) = 'E'
      IF (MDEG .EQ. 5) THEN
        PT = 'C(inf)v'
        DO 740 I = 1, NMS
          CALL GEN088 (SIM, I, M, MSIGN, INV)
          IF (INV .EQ. 1) THEN
            PT = 'D(inf)h'
            GOTO 750
          ENDIF
  740   CONTINUE
  750   NMS = 1
        GOTO 810
      ENDIF
      IF (NMS .EQ. 1) THEN
        PT   = 'C1 '
        IPGR = 1
        GOTO 860
      ENDIF
      DO 770 I = 2, NMS
        TOT = '    '
        S1  = ' '
        S2  = ' '
        SN  = '  '
        CALL GEN088 (SIM, I, M, MSIGN, INV)
        IF (M .GT. MAXASP .AND. MSIGN .EQ.  1) MAXASP = M
        IF (M .GT. MAXASI .AND. MSIGN .EQ. -1) MAXASI = M
        IF (M .EQ. 2 .AND. MPLANE .EQ. 0) MPLANE = 1
        S1 = 'C'
        IF (M .EQ. 2) THEN
          IF (INV .EQ. 1) THEN
            INVERS = 1
            SN     = 'i '
            GOTO 760
          ENDIF
          SN = '2 '
          IF (MSIGN .EQ. -1) THEN
            SN     = 's '
            NPLANE = NPLANE + 1
          ENDIF
          GOTO 760
        ENDIF
        WRITE (SN, '(I2)') M
        IF (MSIGN .EQ. -1) S1 = 'S'
  760   TOT = S1//SN//S2
        CALL GEN085 (TOT, 4, K)
        LBLS(I) = TOT(1:3)
  770 CONTINUE
      PT = '   '
      IF (NMS .EQ.  48) PT = 'Oh '
      IF (NMS .EQ.  60) PT = 'I  '
      IF (NMS .EQ. 120) PT = 'Ih '
      IF (PT  .NE. '   ') GOTO 790
      IF (MDEG .EQ. 3) THEN
        IF (NMS .EQ. 12)   PT = 'T23'
        IF (INVERS .EQ. 1) PT = 'Th '
        IF (MAXASI .EQ. 4) PT = 'Td '
        IF (PT .EQ. '   ') PT = 'O  '
        GOTO 790
      ENDIF
      IF (NMS .EQ. 2) THEN
        PT = LBLS(2)
        GOTO 780
      ENDIF
      S2 = ' '
      S1 = 'C'
      WRITE (SN, 99986) MAXASP
      IF (MOD(NMS, 2) .EQ. 0 .AND. MAXASI .EQ. NMS) THEN
        S1 = 'S'
        WRITE (SN, 99986) MAXASI
        IF (NMS .NE. 6) GOTO 780
        PT = 'C3i'
        GOTO 790
      ENDIF
      IF (NMS .NE. MAXASP) THEN
        IF (NMS .LT. MAXASI) THEN
          WRITE (SN, 99986) MAXASI
          S1 = 'S'
          GOTO 780
        ENDIF
        S1 = 'D'
        IF (NMS .EQ. MAXASP * 2) THEN
          IF (NPLANE .EQ. 0) GOTO 780
          S1 = 'C'
          S2 = 'v'
          IF (NPLANE .EQ. MAXASP) GOTO 780
          S2 = 'h'
          GOTO 780
        ENDIF
        S2 = 'h'
        IF (NPLANE .EQ. MAXASP) S2 = 'd'
      ENDIF
  780 TOT = '    '
      TOT = S1//SN//S2
      CALL GEN085 (TOT, 4, K)
      PT = TOT(1:3)
  790 DO 800 M = 1, 32
        IF (PT .EQ. PNTGR(M)) IPGR = M
  800 CONTINUE
  810 IF (PT .NE. OLDPT) THEN
        CALL PLA269 (6)
        WRITE (PRBUF, 99996)
        WRITE (LU7, 99987) PRBUF(1:80)
        IF (IWIN .EQ. 1 .AND. MO .GT. MOO) THEN
          MOO = MO
          VRT = VRT - 1.5
          CALL GGIP20 (0.0, PRBUF, 80, 0.37, 5 + IGBL(68), 2, 0.1, VRT)
        ENDIF
        WRITE (LU6, 99994) MO, PT, CSMT, RMST, DCM
        WRITE (PRBUF, 99997) MO, RIN, ND, PT, CSMT, RMST, DCM
        WRITE (LU7, 99989) PRBUF(1:80)
        IF (IWIN .EQ. 1) THEN
          VRT = VRT - 1.0
          CALL GGIP20 (0.0, PRBUF, 80, 0.37, 1, 2, 0.1, VRT)
          CALL GGIP (0.0, 0.0, 0.0, 6)
        ENDIF
        IF (IPGR .GE. 16 .AND. IPGR .LE. 27) THEN
          IF (IES .EQ. 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 820 I = 1, NMS
              CALL GEN077 (ALX, SIM, AAY, 1, I, 1)
              CALL GEN077 (AAY, AL, SIM, 1, 1, I)
  820       CONTINUE
            GOTO 830
          ENDIF
          GOTO 850
        ENDIF
      ELSE
        GOTO 850
      ENDIF
  830 CALL GEN074 (TRL, 0.0, 1, 3 * NMS)
      I1 = - 39
      I  = 1
      IF (NMS .GT. 1) I = 2
      CALL PLA269 (3)
      WRITE (LU7, 99988)
     1      (' Symmetry element     CSM and Max.Diff. ', K = 1, I)
      WRITE (LU7, '(80(''-''))')
      DO 840 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) M, LBLS(M), RIGA
        WRITE (LINE(I3:I4), 99991) CSM(M), DEVX(M)
        IF (I1 .EQ. 41) THEN
          CALL PLA269 (1)
          WRITE (LU7, 99989) LINE
          CALL GEN038 (LINE, 1, 80)
          I1 = -39
        ENDIF
  840 CONTINUE
      IF (I1 .GE. 1) THEN
        CALL PLA269 (1)
        WRITE (LU7, 99989) LINE(1 : I1 + 39)
      ENDIF
  850 DCM = DCM + 0.1
      IF (DCM .LT. 0.8) THEN
        OLDPT = PT
        GOTO 20
      ELSE
        GOTO 10
      ENDIF
  860 IF (IWIN .EQ. 1) CALL PLA297 (0)
  870 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',
     7 ' Measure), see: H. Zabrodsky et al. (1993) JACS, 115,',
     8 ' 8278-8289')
99997 FORMAT (I5, 3F10.0, I5,3X, A, F8.4, 6X, F8.4, F5.2)
99996 FORMAT ('Resd #', 9X, 'Inertial  Moments',
     1 4X, 'Degree Symbol    CSM', 11X, 'RMS    Tol')
99995 FORMAT (/, ':: Resd #', I3,
     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.')
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)
      END
      SUBROUTINE PLA212 (A, MV, N)
      PARAMETER (NMA=550, NMG=120)
      COMMON /AT2/ DCM, INDWGH
      COMMON /SRC/ XO(3, NMA), XS(3, NMA), D(NMA), CO(3, NMA), IV(NMA),
     1 COY(3,NMA), WWW(NMA), NGE(NMA), WGHT(NMA), DC(NMA), TRL(3, NMG),
     2 CF(NMA), MK(NMA, NMG), MN(NMA), MD(NMA, 2), RMSX(3, NMA),
     3 ISU(NMG), IASU(NMA), SIM(3, 3, NMG), DEVX(NMG), CSM(NMG),
     4 MTG(NMG, NMG), IAT(NMA), DA(NMA), MEQ(NMA), AL(3, 3), ALX(3, 3),
     5 AAY(3, 3), DEL(4), DELM(4), ORI(3, 3), CSMT, NMS, RMST
      DIMENSION A(3, 3), V(3), W(3)
      MV = 1
      DO 10 I = 1, NMS
        IF (GEN086 (A, SIM, 1.E-2, 1, I) .NE. 0.0) GOTO 90
   10 CONTINUE
      NMS = NMS + 1
      DO 30 I = 1, N
        MK(I, NMS) = 0
        JJ         = 0
        FMIN       = DCM
        CALL GEN078 (A, XO, V, 1, I, 1)
        DO 20 J = 1, N
          IF (MN(I) .EQ. 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 .LE. FMIN) THEN
              FMIN = F
              JJ   = J
            ENDIF
          ENDIF
   20   CONTINUE
        IF (JJ .EQ. 0) GOTO 80
        MK(I, NMS) = JJ
   30 CONTINUE
      CALL GEN097 (IAT, 1, N, 0)
      DO 70 K = 1, N
        IF (IAT(K) .EQ. 0) THEN
          IAT(K) = 1
          NEQ    = 1
          L      = K
   50     M      = MK(L, NMS)
          IF (M .NE. K) THEN
            IAT(M) = 1
            NEQ    = NEQ + 1
            IF (NEQ .GT. N) GOTO 80
            L = M
            GOTO 50
          ENDIF
          CALL GEN088 (A, 1, NORD, MSIGN, INV)
          IF (NEQ .EQ. 1 .OR. NEQ .EQ. 2) GOTO 70
          IF (NEQ .EQ. NORD) GOTO 70
          IF (NEQ .EQ. 2 * NORD) GOTO 70
          GOTO 80
        ENDIF
   70 CONTINUE
      CALL GEN079 (A, SIM, 1, NMS)
      RETURN
   80 NMS = NMS - 1
   90 MV  = 0
      RETURN
      END
      SUBROUTINE PLA213 (N, II, MDEG, IER, LU6)
      PARAMETER (NMA=550, NMG=120)
      COMMON /AT2/ DCM, INDWGH
      COMMON /SRC/ XO(3, NMA), XS(3, NMA), D(NMA), CO(3, NMA), IV(NMA),
     1 COY(3,NMA), WWW(NMA), NGE(NMA), WGHT(NMA), DC(NMA), TRL(3, NMG),
     2 CF(NMA), MK(NMA, NMG), MN(NMA), MD(NMA, 2), RMSX(3, NMA),
     3 ISU(NMG), IASU(NMA), SIM(3, 3, NMG), DEVX(NMG), CSM(NMG),
     4 MTG(NMG, NMG), IAT(NMA), DA(NMA), MEQ(NMA), AL(3, 3), ALX(3, 3),
     5 AAY(3, 3), DEL(4), DELM(4), ORI(3, 3), CSMT, NMS, RMST
      DIMENSION EQP(4), DP(5), VD(3, 5), MP(5), IO(5), A(3, 3),
     1 B(3, 3), V(3)
      KK  = 0
      RAD = 57.295779
      DO 100 I1 = 1, N - 4
        IF (MD(I1, 1) .NE. II) GOTO 100
        MP(1) = I1
        IO(1) = I1
        IN1 = I1 + 1
        DO 90 I2 = IN1, N - 3
          IF (MD(I1, 1) .NE. II) GOTO 90
          MP(2) = I2
          IN2 = I2 + 1
          DO 80 I3 = IN2, N - 2
            IF (MD(I3, 1) .NE. II) GOTO 80
            MP(3) = I3
            CALL GEN083 (XO(1, I1), XO(1, I2), XO(1, I3), EQP)
            IF (EQP(4) .LT. 0.5) GOTO 80
            IN3 = I3 + 1
            DO 70 I4 = IN3, N - 1
              IF (MD(I4, 1) .NE. II) GOTO 70
              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) .GT. DCM) GOTO 70
              IN4 = I4 + 1
              DO 60 I5 = IN4, N
                IF (MD(I5, 1) .NE. II) GOTO 60
                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) .GT. DCM) GOTO 60
                DMIN = 100.0
                DP(1) = DMIN
                DO 10 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) .LT. DMIN) THEN
                    DMIN = DP(I)
                    JJ = I
                  ENDIF
   10           CONTINUE
                IO(2)  = MP(JJ)
                DP(JJ) = 100.0
                DMIN   = 100.0
                DO 20 I = 2, 5
                  IF (DP(I) .LT. DMIN .AND. IO(2) .NE. MP(I)) THEN
                    DMIN = DP(I)
                    KK = I
                  ENDIF
   20           CONTINUE
                IO(5) = MP(KK)
                DO 30 I = 2, 5
                  IF (MP(I) .NE. IO(2) .AND. MP(I) .NE. IO(5)
     1               .AND. IO(3) .EQ. 0) IO(3) = MP(I)
                  IF (MP(I) .NE. IO(2) .AND. MP(I) .NE. IO(5)
     1               .AND. MP(I) .NE. IO(3)) JJ = MP(I)
   30           CONTINUE
                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 .LT. D1) THEN
                  IO(4) = IO(3)
                  IO(3) = JJ
                ENDIF
                DMED = 0.0
                DO 40 I = 1, 5
                  K = I + 1
                  IF (K .GT. 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)
   40           CONTINUE
                DMED = DMED * 0.2
                CALL GEN074 (A, 0.0, 1, 9)
                DO 50 I = 1, 5
                  IF (ABS(DMED - DP(I)) .GT. DCM * 0.5) GOTO 60
                  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))
   50           CONTINUE
                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)
                ROT = 72.0 / RAD
                CALL GEN043 (3, B, ROT)
                CALL PLA212 (B, MV, N)
                IF (MV .EQ. 0) GOTO 60
                CALL PLA216 (V, N, 2, LU6)
                CALL GEN074 (A, 0.0, 1, 9)
                IF (V(3) .LT. 0) THEN
                  V(1) = - V(1)
                  V(2) = - V(2)
                  V(3) = - V(3)
                ENDIF
                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)
                GOTO 110
   60         CONTINUE
   70       CONTINUE
   80     CONTINUE
   90   CONTINUE
  100 CONTINUE
      IF (NMS .EQ. 1) RETURN
  110 IER = 0
      CALL PLA215 (N, IER)
      DM = 0.0
      DO 130 I = 1, N
        IF (MD(I1, 1) .EQ. II) THEN
          DA(I) = XO(1, I)**2 + XO(2, I)**2
          IF (DM .LE. DA(I)) THEN
            KK = I
            DM = DA(I)
          ENDIF
        ENDIF
  130 CONTINUE
      IO(1) = KK
      DP1   = XO(3, KK)
      DO 140 K = 1, 4
        K1     = K + 1
        IO(K1) = MK(IO(K), 2)
        DP1    = DP1 + XO(3, IO(K1))
  140 CONTINUE
      DP1 = - 0.2 * DP1
      ME = 0
      DO 160 I = 1, N
        COM = ABS(DP1 - XO(3, I))
        IF (COM .LE. DCM) THEN
          DO 150 K = 1, 5
            IF (I .EQ. IO(K)) GOTO 160
  150     CONTINUE
          ME      = ME + 1
          MEQ(ME) = I
        ENDIF
  160 CONTINUE
  170 DO 180 I = 1, ME
        IF (MEQ(I) .NE. 0) GOTO 190
  180 CONTINUE
      MDEG = 1
      RETURN
  190 MP(1)  = MEQ(I)
      MEQ(I) = 0
      K = 1
      DO 210 K = 1, 4
        K1 = K + 1
        MP(K1) = MK(MP(K), 2)
        DO 200 L = 1, ME
          IF (MP(K1) .EQ. MEQ(L)) MEQ(L) = 0
  200   CONTINUE
  210 CONTINUE
      CALL GEN074 (A,  0.0, 1, 9)
      CALL GEN074 (VD, 0.0, 1, 15)
      DO 250 I = 1, 5
        K = IO(I)
        DO 220 L = 1, NMS
          IF (MK(K, L) .EQ. IO(1)) THEN
            CALL GEN078 (SIM, XO, VD, L, K, 3)
            CALL GEN073 (VD, VD, VD, 1.0, 1.0, 3, 1, 1)
            GOTO 230
          ENDIF
  220   CONTINUE
  230   K = MP(I)
        DO 240 L = 1, NMS
          IF (MK(K, L) .EQ. MP(1)) THEN
            CALL GEN078 (SIM, XO, VD, L, K, 3)
            CALL GEN073 (VD, VD, VD, 1.0, 1.0, 3, 2, 2)
            GOTO 250
          ENDIF
  240   CONTINUE
  250 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 260 I = 1, 5
        CALL GEN078 (SIM, VD, VD, 2, 2, 2)
        CALL GEN075 (VD, VD, COSA, 1, 2, 1)
        IF (COSA .GE. COST) GOTO 270
  260 CONTINUE
  270 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, 0.0, 1, 9)
      B(1, 1) =  1.0
      B(2, 2) = -1.0
      B(3, 3) = -1.0
      CALL PLA212 (B, MV, N)
      IF (MV .NE. 1) THEN
        CALL GEN081 (A, A, 1, 1)
        CALL PLA214 (A, N)
        CALL GEN074 (A, 0.0, 1, 9)
        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 .NE. 1) THEN
          CALL GEN081 (A, A, 1,1)
          CALL PLA214 (A, N)
          GOTO 170
        ENDIF
      ENDIF
      CALL GEN021 (B, -1)
      CALL PLA212 (B, MV, N)
      ROT = -63.434949 / RAD
  290 CALL GEN043 (1, A, - ROT)
      ROT18 = -18.0 / RAD
  300 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 .NE. 1) THEN
        IF (ROT18 .LT. 0.0) THEN
          ROT18 = - ROT18
          GOTO 300
        ENDIF
        IF (ROT .GT. 0.0) RETURN
        ROT = - ROT
        GOTO 290
      ENDIF
      IER = 0
      CALL PLA215 (N, IER)
      IER = 1
      RETURN
      END
      SUBROUTINE PLA214 (COZ, N)
      PARAMETER (NMA=550, NMG=120)
      COMMON /ORIE/ ORX(3, 3), OT(3, 3), OTI(3, 3), BARC(3), BARO(3),
     1 RIN(3)
      COMMON /SRC/ XO(3, NMA), XS(3, NMA), D(NMA), CO(3, NMA), IV(NMA),
     1 COY(3,NMA), WWW(NMA), NGE(NMA), WGHT(NMA), DC(NMA), TRL(3, NMG),
     2 CF(NMA), MK(NMA, NMG), MN(NMA), MD(NMA, 2), RMSX(3, NMA),
     3 ISU(NMG), IASU(NMA), SIM(3, 3, NMG), DEVX(NMG), CSM(NMG),
     4 MTG(NMG, NMG), IAT(NMA), DA(NMA), MEQ(NMA), AL(3, 3), ALX(3, 3),
     5 AAY(3, 3), DEL(4), DELM(4), ORI(3, 3), CSMT, NMS, RMST
      DIMENSION COZ(3, 3)
      DO 10 I = 1, N
        CALL GEN078 (COZ, XO, XO, 1, I, I)
   10 CONTINUE
      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 PLA215 (N, IER)
      PARAMETER (NMA=550, NMG=120)
      COMMON /SRC/ XO(3, NMA), XS(3, NMA), D(NMA), CO(3, NMA), IV(NMA),
     1 COY(3,NMA), WWW(NMA), NGE(NMA), WGHT(NMA), DC(NMA), TRL(3, NMG),
     2 CF(NMA), MK(NMA, NMG), MN(NMA), MD(NMA, 2), RMSX(3, NMA),
     3 ISU(NMG), IASU(NMA), SIM(3, 3, NMG), DEVX(NMG), CSM(NMG),
     4 MTG(NMG, NMG), IAT(NMA), DA(NMA), MEQ(NMA), AL(3, 3), ALX(3, 3),
     5 AAY(3, 3), DEL(4), DELM(4), ORI(3, 3), CSMT, NMS, RMST
      DIMENSION COX(3, 3)
   10 NN = NMS
      DO 50 I = 1, NN
        DO 40 J = 1, NN
          CALL GEN077 (SIM, SIM, COX, I, J, 1)
          DO 20 JJ = 1, NN
            L = NINT(GEN086 (COX, SIM, 1.E-2, 1, JJ))
            IF (L .EQ. 1) GOTO 30
   20     CONTINUE
          GOTO 60
   30     MTG(I, J) = JJ
   40   CONTINUE
   50 CONTINUE
      GOTO 80
   60 NMS = NMS + 1
      IF (NMS .LE. NMG) THEN
        CALL GEN079 (COX, SIM, 1, NMS)
        DO 70 K = 1, N
          K1         = MK(K, J)
          MK(K, NMS) = MK(K1, I)
   70   CONTINUE
        GOTO 10
      ENDIF
      IER = 1
   80 RETURN
      END
      SUBROUTINE PLA216 (V3, N, IAX, LU6)
      PARAMETER (NMA=550, NMG=120)
      COMMON /SRC/ XO(3, NMA), XS(3, NMA), D(NMA), CO(3, NMA), IV(NMA),
     1 COY(3,NMA), WWW(NMA), NGE(NMA), WGHT(NMA), DC(NMA), TRL(3, NMG),
     2 CF(NMA), MK(NMA, NMG), MN(NMA), MD(NMA, 2), RMSX(3, NMA),
     3 ISU(NMG), IASU(NMA), SIM(3, 3, NMG), DEVX(NMG), CSM(NMG),
     4 MTG(NMG, NMG), IAT(NMA), DA(NMA), MEQ(NMA), AL(3, 3), ALX(3, 3),
     5 AAY(3, 3), DEL(4), DELM(4), ORI(3, 3), CSMT, NMS, RMST
      DIMENSION V3(3), VS(3)
      CALL GEN097 (IV, 1, N, 0)
      NG   = 0
      COST = GEN084 (SIM, IAX)
   10 DO 20 I = 1, N
        IF (IV(I) .EQ. 0) GOTO 30
   20 CONTINUE
      GOTO 70
   30 NG = NG + 1
      IV(I) = NG
      DO 40 J = 1, 3
        COY(J, NG) = XO(J, I)
   40 CONTINUE
      WWW(NG) = WGHT(I)
      NGE(NG) = 1
      K = I
   50 L = MK(K, IAX)
      IF (L .EQ. I) GOTO 10
      IV(L) = NG
      DO 60 J = 1, 3
        COY(J, NG) = COY(J, NG) + COST * XO(J, L)
   60 CONTINUE
      WWW(NG) = WWW(NG) + WGHT(L)
      NGE(NG) = NGE(NG) + 1
      K = L
      GOTO 50
   70 DO 80 I = 1, NG
        WWW(I) = WWW(I) / NGE(I)
   80 CONTINUE
      CALL GEN074 (V3, 0.0, 1, 3)
      DISM = 0.0
      DO 90 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 .GT. DISM) THEN
          DISM = DIS
          IM = I
        ENDIF
   90 CONTINUE
      CALL GEN074 (V3, 0.0, 1, 3)
      IF (IM .LE. 0 .OR. IM .GT. NMA) THEN
        WRITE (LU6,'(''IM = '', I10)') IM
      ELSE
        CALL GEN075 (COY, COY, DIM, IM, IM, 2)
        IF (NG .GT. NMA) THEN
          WRITE (LU6,'(''NG = '', I10)') NG
        ELSE
          DO 100 I = 1, NG
            CALL GEN075 (COY, COY, ABCOS, IM, I, 1)
            CALL GEN075 (COY, COY, DI, I, I, 2)
            ABSABCOS = ABS(ABCOS)
            IF (ABSABCOS .GT. 1.E-5) THEN
              COST = WWW(I) * ABCOS / ABSABCOS
              CALL GEN073 (V3, COY, V3, 1.0, COST, 1, I, 1)
            ENDIF
  100     CONTINUE
          CALL GEN082 (V3, 1)
          IF (V3(1) .LE. 0.0) THEN
            V3(1) = - V3(1)
            V3(2) = - V3(2)
            V3(3) = - V3(3)
          ENDIF
        ENDIF
      ENDIF
      RETURN
      END
      SUBROUTINE PLA217 (XCSM, NES, N)
      PARAMETER (NMA=550, NMG=120)
      COMMON /SRC/ XO(3, NMA), XS(3, NMA), D(NMA), CO(3, NMA), IV(NMA),
     1 COY(3,NMA), WWW(NMA), NGE(NMA), WGHT(NMA), DC(NMA), TRL(3, NMG),
     2 CF(NMA), MK(NMA, NMG), MN(NMA), MD(NMA, 2), RMSX(3, NMA),
     3 ISU(NMG), IASU(NMA), SIM(3, 3, NMG), DEVX(NMG), CSM(NMG),
     4 MTG(NMG, NMG), IAT(NMA), DA(NMA), MEQ(NMA), AL(3, 3), ALX(3, 3),
     5 AAY(3, 3), DEL(4), DELM(4), ORI(3, 3), CSMT, NMS, RMST
      DIMENSION V3(3)
      NAZ = 3 * N
      CALL GEN074 (CO,   0.0, 1, NAZ)
      CALL GEN074 (XS,   0.0, 1, NAZ)
      CALL GEN074 (RMSX, 0.0, 1, NAZ)
      CALL GEN074 (DEL,  0.0, 1, 4)
      CALL GEN074 (DELM, 0.0, 1, 4)
      CALL GEN074 (CF,   0.0, 1, N)
      DO 20 I = 1, N
        CALL GEN075 (XO, XO, D(I), I, I, 2)
        DO 10 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)
   10   CONTINUE
   20 CONTINUE
      DO 40 I = 1, N
        DO 30 J = 1, 3
          XS(J, I) = XS(J, I) / FLOAT(NES)
   30   CONTINUE
        CALL GEN075 (XS, XS, DC(I), I, I, 2)
   40 CONTINUE
      DO 70 I = 1, N
        DO 50 J = 1, NES
          K = MK(I, ISU(J))
          CF(I) = CF(I) + D(K)
   50   CONTINUE
        IF (DC(I) .GT. 1.E-01) CF(I) = CF(I) / (DC(I) * NES)
        DO 60 J = 1, 3
          XS(J, I) = XS(J, I) * CF(I)
   60   CONTINUE
   70 CONTINUE
      DO 90 I = 1, N
        DO 80 J = 1, 3
          V3(J)  = XO(J, I) - XS(J, I)
          COM    = ABS(V3(J))
          DEL(J) = DEL(J) + COM
          IF (COM .GT. DELM(J)) DELM(J) = COM
   80   CONTINUE
        CALL GEN075 (V3, V3, COM, 1, 1, 2)
        DEL(4) = DEL(4) + COM
        IF (DELM(4) .LT. COM) DELM(4) = COM
   90 CONTINUE
      XCSM = 0.0
      DO 110 J = 1, NES
        DO 100 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)
          RMSX(1, K) = RMSX(1, K) + V3(1) ** 2
          RMSX(2, K) = RMSX(2, K) + V3(2) ** 2
          RMSX(3, K) = RMSX(3, K) + V3(3) ** 2
          CALL GEN075 (V3, V3, COM, 1, 1, 1)
          XCSM = XCSM + COM
  100   CONTINUE
  110 CONTINUE
      COST = 1.0 / FLOAT(NES)
      RMST = 0.0
      DO 130 I = 1, N
        DO 120 J = 1, 3
          RMST = RMST + RMSX(J, I)
          RMSX(J, I) = SQRT(RMSX(J, I) * COST)
  120   CONTINUE
  130 CONTINUE
      RMST = SQRT (RMST / FLOAT (NES * N))
      XCSM = XCSM * 100.0 / FLOAT (NES * N)
      RETURN
      END
      SUBROUTINE PLA218 (Q, PHI, AAZ, NR, LU7)
      DIMENSION Q(*), PHI(*)
      IF (NR .LE. 18) THEN
        N = (NR - 1) / 2
        CALL PLA269 (3)
        WRITE (LU7, 99999)
        IF (NR / 2 .GT. N) THEN
          IC    = NR / 2
          Q(IC) = AAZ
          R     = Q(IC)
          IF (NR .LE. 8) THEN
            CALL PLA219 (Q, PHI, N, NR, R, LU7)
          ELSE
            CALL PLA220 (Q, PHI, N, NR, R, LU7)
          ENDIF
        ELSE
          CALL PLA221 (Q, PHI, N, NR, LU7)
        ENDIF
      ENDIF
      RETURN
99999 FORMAT(/, 'Conformational Analysis (G.G. Evans & ',
     1 'J.A. Boeyens, Acta Cryst. (1989), B45, 581-590)', /)
      END
      SUBROUTINE PLA219 (Q, PHI, N, NR, R, LU7)
      COMMON /PLA73/ XA(20), XB(20), XXA(20), XXB(20)
      DIMENSION Q(*), PHI(*), TF1(6), TF2(6), TF3(6), UF1(15),
     1 UF2(15), UF3(15), UF4(15), UF5(15), YXZ(15), QX(8), QXA(8)
      REAL K(50), L(50), KMIN(50), LMIN(50)
      CHARACTER NAME(6), NAMEX(15)*3
      DATA NAME /'B', 'T', 'C', 'E', 'S', 'H'/
      DATA TF1  /1.0, 0.0, 0.0, 0.586, 0.0,   0.0/
      DATA TF2  /0.0, 1.0, 0.0, 0.0,   0.707, 0.551/
      DATA TF3  /0.0, 0.0, 1.0, 0.414, 0.293, 0.449/
      DATA NAMEX /
     1 'BB ', 'BB ', 'CR ', 'TC ', 'TC ', 'C  ', 'B  ', 'S  ', 'S  ',
     2 'CC ', 'CC ', 'TCC', 'BC ', 'BC ', 'TBC'/
      DATA UF1 /
     1 1.0, 0.0,   0.0,   0.0, 0.0, 0.0, 0.5, 0.707, 0.293, 0.352,
     2 0.0, 0.234, 0.530, 0.0, 0.229/
      DATA UF2 /
     1 0.0, 1.0, 0.0, 0.0, 0.0, 0.0, 0.5, 0.293, 0.707, 0.0, 0.352,
     2 0.234, 0.0, 0.530, 0.229/
      DATA UF3 /
     1 0.0, 0.0, 0.0, 1.0, 0.0, 0.5, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0,
     2 0.298, 0.0, 0.213/
      DATA UF4 /
     1 0.0, 0.0, 0.0, 0.0, 1.0, 0.5, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0,
     2 0.0, 0.298, 0.213/
      DATA UF5 /
     1 0.0, 0.0, 1.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.648, 0.648,
     2 0.533, 0.172, 0.172, 0.116/
      IF (R .LE. 0) THEN
        AA = -1.0
      ELSE
        AA =  1.0
      ENDIF
      V = ABS(R)
      IF (NR .EQ. 6) THEN
        DO 10 M = 2, N
          CALL PLA225 (M, K, L, KMIN, LMIN, PHI, NR, 7, 4)
   10   CONTINUE
        CALL PLA222 (Q, KMIN, LMIN, N, NR, PHI, V, VV, LU7)
        WRITE (LU7, 99997) NR / 2, VV, AA
        DO 20 I = 1, 6
          YXX = ABS(TF1(I) - XXA(2)) + ABS(TF2(I) - XXB(2))
     1        + ABS(TF3(I) - VV)
          IF (YXX .LE. 0.2 .AND. YXX .GT. 0.1)
     1        WRITE (LU7, 99998) NAME(I)
          IF (YXX .LE. 0.1) THEN
            CALL PLA269 (3)
            WRITE (LU7, 99999) NAME(I)
          ENDIF
   20   CONTINUE
      ELSE
        DO 30 M = 2, N
          IF (M .EQ. 2) THEN
            CALL PLA225 (M, K, L, KMIN, LMIN, PHI, NR, 3, 16)
          ELSE
            CALL PLA225 (M, K, L, KMIN, LMIN, PHI, NR, 5, 8)
          ENDIF
   30   CONTINUE
        CALL PLA222 (Q, KMIN, LMIN, N, NR, PHI, V, VV, LU7)
        WRITE (LU7, 99997) NR / 2, VV, AA
        DO 40 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))
   40   CONTINUE
        DO 50 I = 1, 12
          IF (YXZ(I) .LE. 0.2 .AND. YXZ(I) .GT. 0.1) THEN
            CALL PLA269 (3)
            WRITE (LU7, 99998) NAMEX(I)
          ENDIF
          IF (YXZ(I) .LE. 0.1) THEN
            CALL PLA269 (3)
            WRITE (LU7, 99999) NAMEX(I)
          ENDIF
   50   CONTINUE
        DO 60 I = 2, N
          RZ = ABS(PHI(I) - 360)
          IF (RZ .LT. 5) PHI(I) = 360 - PHI(I)
   60   CONTINUE
        IF (YXZ(13) .LE. 0.2 .OR. YXZ(14) .LE. 0.2) THEN
          DO 70 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
   70     CONTINUE
          QXX  = 10.03
          QXXA = 10.03
          DO 80 J = 1, 8
            IF (QX(J)  .LE. 10 .AND. AA .EQ. -1.0) QXX  = QX(J)
            IF (QXA(J) .LE. 10 .AND. AA .EQ.  1.0) QXXA = QXA(J)
   80     CONTINUE
          IF (QXX .LE. 10) THEN
            IF (YXZ(13) .LE. 0.1 .OR. YXZ(14) .LE. 0.1) THEN
              CALL PLA269 (3)
              WRITE (LU7, 99999) NAMEX(13)
            ENDIF
          ENDIF
          IF (QXXA .LE. 10) THEN
            IF (YXZ(13) .GT. 0.1 .OR. YXZ(14) .GT. 0.1) THEN
              CALL PLA269 (3)
              WRITE (LU7, 99998) NAMEX(13)
            ENDIF
          ENDIF
        ELSE IF (YXZ(15) .LE. 0.2) THEN
          DO 90 J = 1, 8
            ANG  = FLOAT(      45 + (8 * 180 * (J - 1)) / 16)
            ANGA = FLOAT(180 + 45 + (8 * 180 * (J - 1)) / 16)
            ANGL = FLOAT(180 + 360 / 16 + (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
   90     CONTINUE
          QXX  = 10.03
          QXXA = 10.03
          DO 100 J = 1, 8
            IF (QX(J)  .LE. 10 .AND. AA .EQ. -1.0) QXX  = QX(J)
            IF (QXA(J) .LE. 10 .AND. AA .EQ.  1.0) QXXA = QXA(J)
  100     CONTINUE
          IF (QXX .LE. 10 .OR. QXXA .LE. 10) THEN
            CALL PLA269 (3)
            IF (YXZ(15) .LE. 0.1) THEN
              WRITE (LU7, 99999) NAMEX(15)
            ELSE
              WRITE (LU7, 99998) NAMEX(15)
            ENDIF
          ENDIF
        ENDIF
      ENDIF
      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 PLA220 (Q, PHI, N, NR, R, LU7)
      DIMENSION Q(*), PHI(*)
      REAL K(50), L(50), KMIN(50), LMIN(50)
      IF (R .LE. 0) THEN
        AA = -1.0
      ELSE
        AA =  1.0
      ENDIF
      V = ABS(R)
      IF (NR .EQ. 10) THEN
        DO 10 M = 2, N
          CALL PLA225 (M, K, L, KMIN, LMIN, PHI, NR, 11, 4)
   10   CONTINUE
      ELSE IF (NR .EQ. 12) THEN
        DO 20 M = 2, N
          IF (M .EQ. 3) THEN
            CALL PLA225 (M, K, L, KMIN, LMIN, PHI, NR, 3, 24)
          ELSE
            CALL PLA225 (M, K, L, KMIN, LMIN, PHI, NR, 13, 8)
          ENDIF
   20   CONTINUE
      ELSE IF (NR .EQ. 14) THEN
        DO 30 M = 2, N
          CALL PLA225 (M, K, L, KMIN, LMIN, PHI, NR, 15, 4)
   30   CONTINUE
      ELSE IF (NR .EQ. 16) THEN
        DO 40 M = 2, N
          IF (M .EQ. 2 .OR. M .EQ. 6) THEN
            CALL PLA225 (M, K, L, KMIN, LMIN, PHI, NR, 5, 16)
          ELSE IF (M .EQ. 4) THEN
            CALL PLA225 (M, K, L, KMIN, LMIN, PHI, NR, 3, 32)
          ELSE
            CALL PLA225 (M, K, L, KMIN, LMIN, PHI, NR, 9, 8)
          ENDIF
   40   CONTINUE
      ELSE
        DO 50 M = 2, N
          IF (M .EQ. 3 .OR. M .EQ. 6) THEN
            CALL PLA225 (M, K, L, KMIN, LMIN, PHI, NR, 7, 12)
          ELSE
            CALL PLA225 (M, K, L, KMIN, LMIN, PHI, NR, 19, 4)
          ENDIF
   50   CONTINUE
      ENDIF
      CALL PLA222 (Q, KMIN, LMIN, N, NR, PHI, V, VV, LU7)
      WRITE (LU7, 99999) NR / 2, VV, AA
      RETURN
99999 FORMAT (10X, I2, 21X, F5.3, 8X, F4.1)
      END
      SUBROUTINE PLA221 (Q, PHI, N, NR, LU7)
      COMMON /PLA73/ XA(20), XB(20), XXA(20), XXB(20)
      DIMENSION Q(*), PHI(*), SF1(2), SF2(2), XF1(9), XF2(9),
     1 XF3(9), XF4(9), XN1(16), XN2(16), XN3(16), XN4(16), XN5(16),
     2 XN6(16), YZZ(16), QY(14), QX(19), QXA(14),
     3 QYA(14), QX1(18), QX2(18), QX3(18), QX4(18)
      REAL K(50), L(50), KMIN(50), LMIN(50)
      CHARACTER NAME(2), NAMEX(9)*2, NAMX(16)*4
      DATA NAME /'E', 'T'/
      DATA SF1  /1.0, 0.0/
      DATA SF2  /0.0, 1.0/
      DATA NAMEX /
     1 'B ', 'TB', 'C ', 'TC', 'BS', 'S ', 'TS', 'H ', 'T '/
      DATA XF1  /1.00, 0.0, 0.0, 0.0, 0.783, 0.5, 0.0, 0.417, 0.0/
      DATA XF2  /0.0, 1.0, 0.0, 0.0, 0.0, 0.0, 0.444, 0.0, 0.46/
      DATA XF3  /0.0, 0.0, 1.0, 0.0, 0.217, 0.5, 0.0, 0.583, 0.0/
      DATA XF4  /0.0, 0.0, 0.0, 1.0, 0.0, 0.0, 0.555, 0.0, 0.54/
      DATA NAMX /
     1 'BB  ', 'TBB ', 'BC  ', 'TBC ', 'CC  ', 'TCC ', 'BC" ',
     2 'TBC"', 'B   ', 'CC" ', 'TB  ', 'TCC"', 'C   ', 'CB  ',
     3 'TC  ', 'TCB'/
      DATA XN1/
     1 1.00, 0.0, 0.0, 0.0, 0.0, 0.0, 0.308, 0.0, 0.582, 0.401, 0.0,
     2 0.0, 0.280, 0.601, 0.0, 0.0/
      DATA XN2/
     1 0.0, 1.00, 0.0, 0.0, 0.0, 0.0, 0.0, 0.317, 0.0, 0.0, 0.584,
     2 0.397, 0.0, 0.0, 0.340, 0.498/
      DATA XN3/
     1 0.0, 0.0, 1.0, 0.0, 0.379, 0.0, 0.563, 0.0, 0.168, 0.189,
     2 0.0, 0.0, 0.617, 0.245, 0.0, 0.0/
      DATA XN4/
     1 0.0, 0.0, 0.0, 1.0, 0.0, 0.379, 0.0, 0.564, 0.0, 0.0, 0.168,
     2 0.192, 0.0, 0.0, 0.515, 0.319/
      DATA XN5/
     1 0.0, 0.0, 0.0, 0.0, 0.621, 0.0, 0.129, 0.0, 0.250, 0.410, 0.0,
     2 0.0, 0.104, 0.154, 0.0, 0.0/
      DATA XN6/
     1 0.0, 0.0, 0.0, 0.0, 0.0, 0.621, 0.0, 0.119, 0.0, 0.0, 0.248,
     2 0.411, 0.0, 0.0, 0.145, 0.183/
      DO 10 M = 2, N
        NRR = 2 * NR + 1
        IF (NR .EQ. 9 .AND. M .EQ. 3) THEN
          CALL PLA225 (M, K, L, KMIN, LMIN, PHI, NR, 7, 6)
        ELSE IF (NR .EQ. 15 .AND. M .EQ. 5) THEN
          CALL PLA225 (M, K, L, KMIN, LMIN, PHI, NR, 7, 10)
        ELSE IF (NR .EQ. 15 .AND. M .EQ. 3 .OR. NR .EQ. 15
     1           .AND. M .EQ. 6) THEN
          CALL PLA225 (M, K, L, KMIN, LMIN, PHI, NR, 11, 6)
        ELSE
          CALL PLA225 (M, K, L, KMIN, LMIN, PHI, NR, NRR, 2)
        ENDIF
   10 CONTINUE
      V = 0
      CALL PLA222 (Q, KMIN, LMIN, N, NR, PHI, V, VV, LU7)
      IF (NR .GT. 9) GOTO 500
      IF (NR .EQ. 5) THEN
        DO 20 I = 1, 2
          YX = ABS(SF1(I) - XXA(2)) + ABS(SF2(I) - XXB(2))
          IF (YX .LE. 0.1) WRITE (LU7, 99999) NAME(I)
          IF (YX .GT. 0.1 .AND. YX .LE. 0.2) WRITE (LU7, 99998) NAME(I)
   20   CONTINUE
      ELSE IF (NR .EQ. 7) THEN
        DO 30 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))
   30   CONTINUE
        DO 40 I = 2, N
          RZ = ABS(PHI(I) - 360)
          IF (RZ .LT. 5) PHI(I) = 360 - PHI(I)
   40   CONTINUE
        IF (YZZ(5) .LE. 0.2) THEN
          DO 50 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
   50     CONTINUE
          QXX = 10.03
          DO 60 J = 1, 14
            IF (QX(J) .LE. 10) QXX = QX(J)
   60     CONTINUE
          IF (QXX .LE. 10 .AND. YZZ(5) .LE. 0.1) WRITE (LU7, 99999) 'BS'
          IF (QXX .LE. 10 .AND. YZZ(5) .GT. 0.1) WRITE (LU7, 99998) 'BS'
        ELSE IF (YZZ(6) .LE. 0.2 .OR. YZZ(8) .LE. 0.2) THEN
          DO 70 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
   70     CONTINUE
          QXX  = 10.03
          QXXA = 10.03
          DO 80 J = 1, 14
            IF (QX(J)  .LE. 10) QXX  = QX(J)
            IF (QXA(J) .LE. 10) QXXA = QXA(J)
   80     CONTINUE
          IF (QXX .LE. 10 .AND. YZZ(6) .LE. 0.1) WRITE (LU7, 99999) 'S'
          IF (QXX .LE. 10 .AND. YZZ(6) .GT. 0.1 .AND. YZZ(6) .LE. 0.2)
     1      WRITE (LU7, 99998) 'S'
          IF (QXXA .LE. 10 .AND. YZZ(8) .LE. 0.1) WRITE (LU7, 99999) 'H'
          IF (QXXA .LE. 10 .AND. YZZ(8) .GT. 0.1 .AND. YZZ(8) .LE. 0.2)
     1      WRITE (LU7, 99998) 'H'
          GOTO 500
        ELSE IF (YZZ(7) .LE. 0.2 .OR. YZZ(9) .LE. 0.2) THEN
          DO 90 J = 1, 14
            ANGM  =
     1       FLOAT(      ((3 * 180) / 14) + ((6 * 180 * (J - 1)) / 14))
            ANGMA =
     1       FLOAT(180 + ((3 * 180) / 14) + ((6 * 180 * (J - 1)) / 14))
            ANGLM =
     1       FLOAT(            (180 / 14) + ((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
   90     CONTINUE
          QYY  = 10.03
          QYYA = 10.03
          DO 100 J = 1, 14
            IF (QY(J)  .LE. 10) QYY  = QY(J)
            IF (QYA(J) .LE. 10) QYYA = QYA(J)
  100     CONTINUE
          IF (QYY .LE. 10 .AND. YZZ(7) .LE. 0.1) WRITE (LU7, 99999) 'TS'
          IF (QYY .LE. 10 .AND. YZZ(7) .GT. 0.1 .AND. YZZ(7) .LE. 0.2)
     1      WRITE (LU7, 99998) 'TS'
          IF (QYYA .LE. 10 .AND. YZZ(9) .LE. 0.1) WRITE (LU7, 99999) 'T'
          IF (QYYA .LE. 10 .AND. YZZ(9) .GT. 0.1 .AND. YZZ(9) .LE. 0.2)
     1      WRITE (LU7, 99998) 'T'
        ELSE
          DO 110 I = 1, 9
            IF (YZZ(I) .LE. 0.1) WRITE (LU7, 99999) NAMEX(I)
            IF (YZZ(I) .GT. 0.1 .AND. YZZ(I) .LE. 0.2)
     1        WRITE (LU7, 99998) NAMEX(I)
  110     CONTINUE
        ENDIF
      ELSE
        DO 120 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))
  120   CONTINUE
        DO 130 I = 2, N
          RH = ABS(PHI(I) - 360)
          IF (RH .LT. 5) PHI(I) = 360 - PHI(I)
  130   CONTINUE
        IF (YZZ(5) .LE. 0.2) THEN
          DO 140 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
  140     CONTINUE
          QXX = 10.03
          DO 150 J = 1, 18
            IF (QX(J) .LE. 10) QXX = QX(J)
  150     CONTINUE
          IF (QXX .LE. 10 .AND. YZZ(5) .GT. 0.1)
     1      WRITE (LU7, 99998) NAMX(5)
          IF (QXX .LE. 10 .AND. YZZ(5) .LE. 0.1)
     1      WRITE (LU7, 99999) NAMX(5)
        ELSE IF (YZZ(6) .LE. 0.2) THEN
          DO 160 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
  160     CONTINUE
          QXX = 10.03
          DO 170 J = 1, 18
            IF (QX(J) .LE. 10) QXX = QX(J)
  170     CONTINUE
          IF (QXX .LE. 10 .AND. YZZ(6) .GT. 0.1)
     1      WRITE (LU7, 99998) NAMX(6)
          IF (QXX .LE. 10 .AND. YZZ(6) .LE. 0.1)
     1      WRITE (LU7, 99999) NAMX(6)
        ELSE IF (YZZ(7) .LE. 0.2 .OR. YZZ(9) .LE. 0.2 .OR. YZZ(10)
     1    .LE. 0.2 .OR. YZZ(13) .LE. 0.2 .OR. YZZ(14) .LE. 0.2) THEN
          DO 180 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
  180     CONTINUE
          QXX = 15.03
          DO 190 J = 1, 18
            IF (QX(J) .LE. 15) QXX = QX(J)
  190     CONTINUE
          IF (QXX .LE. 15 .AND. YZZ(7) .GT. 0.1 .AND. YZZ(7) .LE. 0.2)
     1      WRITE (LU7, 99998) NAMX(7)
          IF (QXX .LE. 15 .AND. YZZ(7) .LE. 0.1)
     1      WRITE (LU7, 99999) NAMX(7)
          DO 200 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
  200     CONTINUE
          QXX1 = 15.03
          DO 210 J = 1, 18
            IF (QX1(J) .LE. 15) QXX1 = QX1(J)
  210     CONTINUE
          IF (QXX1 .LE. 15 .AND. YZZ(9) .GT. 0.1 .AND. YZZ(9)
     1      .LE. 0.2) WRITE (LU7, 99998) NAMX(9)
          IF (QXX1 .LE. 15 .AND. YZZ(9) .LE. 0.1)
     1      WRITE (LU7, 99999) NAMX(9)
          IF (QXX1 .LE. 15 .AND. YZZ(10) .GT. 0.1 .AND. YZZ(10)
     1      .LE. 0.2) WRITE (LU7, 99998) NAMX(10)
          IF (QXX1 .LE. 15 .AND. YZZ(10) .LE. 0.1)
     1      WRITE (LU7, 99999) NAMX(10)
          DO 220 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
  220     CONTINUE
          QXX2 = 15.03
          DO 230 J = 1, 18
            IF (QX2(J) .LE. 15) QXX2 = QX2(J)
  230     CONTINUE
          IF (QXX2 .LE. 15 .AND. YZZ(13) .GT. 0.1 .AND. YZZ(13)
     1       .LE. 0.2) WRITE (LU7, 99998) NAMX(13)
          IF (QXX2 .LE. 15 .AND. YZZ(13) .LE. 0.1)
     1       WRITE (LU7, 99999) NAMX(13)
          IF (QXX2 .LE. 15 .AND. YZZ(14) .GT. 0.1 .AND. YZZ(14)
     1      .LE. 0.2) WRITE (LU7, 99998) NAMX(14)
          IF (QXX2 .LE. 15 .AND. YZZ(14) .LE. 0.1)
     1      WRITE (LU7, 99999) NAMX(14)
        ELSE IF (YZZ(8) .LE. 0.2 .OR. YZZ(11) .LE. 0.2 .OR. YZZ(12)
     1      .LE. 0.2 .OR. YZZ(15) .LE. 0.2 .OR. YZZ(16) .LE. 0.2) THEN
          DO 240 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)
            QX(J) = RL + RLL + RLM
  240     CONTINUE
          QXX = 15.03
          DO 250 J = 1, 18
            IF (QX(J) .LE. 15) QXX = QX(J)
  250     CONTINUE
          IF (QXX .LE. 15 .AND. YZZ(8) .GT. 0.1 .AND. YZZ(8) .LE. 0.2)
     1        WRITE (LU7, 99998) NAMX(8)
          IF (QXX .LE. 15 .AND. YZZ(8) .LE. 0.1)
     1        WRITE (LU7, 99999) NAMX(8)
          DO 260 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
  260     CONTINUE
          QXX3 = 15.03
          DO 270 J = 1, 18
            IF (QX3(J) .LE. 15) QXX3 = QX3(J)
  270     CONTINUE
          IF (QXX3 .LE. 15 .AND. YZZ(11) .GT. 0.1 .AND. YZZ(11)
     1      .LE. 0.2) WRITE (LU7, 99998) NAMX(11)
          IF (QXX3 .LE. 15 .AND. YZZ(11) .LE. 0.1)
     1      WRITE (LU7, 99999) NAMX(11)
          IF (QXX3 .LE. 15 .AND. YZZ(12) .GT. 0.1 .AND. YZZ(12)
     1      .LE. 0.2) WRITE (LU7, 99998) NAMX(12)
          IF (QXX3 .LE. 15 .AND. YZZ(12) .LE. 0.1)
     1      WRITE (LU7, 99999) NAMX(12)
          DO 280 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
  280     CONTINUE
          QXX4 = 15.03
          DO 290 J = 1, 18
            IF (QX4(J) .LE. 15) QXX4 = QX4(J)
  290     CONTINUE
          IF (QXX4 .LE. 15 .AND. YZZ(15) .GT. 0.1 .AND. YZZ(15)
     1        .LE. 0.2) WRITE (LU7, 99998) NAMX(15)
          IF (QXX4 .LE. 15 .AND. YZZ(15) .LE. 0.1)
     1        WRITE (LU7, 99999) NAMX(15)
          IF (QXX4 .LE. 15 .AND. YZZ(16) .GT. 0.1 .AND. YZZ(16)
     1        .LE. 0.2) WRITE (LU7, 99998) NAMX(16)
          IF (QXX4 .LE. 15 .AND. YZZ(16) .LE. 0.1)
     1        WRITE (LU7, 99999) NAMX(16)
        ELSE
          DO 300 I = 1, 4
            IF (YZZ(I) .LE. 0.2 .AND. YZZ(I) .GT. 0.1) THEN
              CALL PLA269 (3)
              WRITE (LU7, 99998) NAMX(I)
            ENDIF
            IF (YZZ(I) .LE. 0.1) THEN
              CALL PLA269 (3)
              WRITE (LU7, 99999) NAMX(I)
            ENDIF
  300     CONTINUE
        ENDIF
      ENDIF
  500 RETURN
99999 FORMAT (/, ':: Note: This is a ', A, '-Form', /)
99998 FORMAT (/, ':: Note: This is Very Similar to a ', A,'-Form', /)
      END
      SUBROUTINE PLA222 (Q, KMIN, LMIN, N, NR, PHI, V, VV, LU7)
      COMMON /PLA73/ XA(20), XB(20), XXA(20), XXB(20)
      DIMENSION Q(*), PHI(*), A(20), B(20), W(20), RHI(20)
      REAL KMIN(50), LMIN(50)
      PI   = 4 * ATAN2 (1.0, 1.0)
      FACT = PI / 180.0
      DO 10 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)))
        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))))
   10 CONTINUE
      TOTL = 0.0
      VV   = 0.0
      DO 20 M = 2, N
        TOTL = TOTL + XA(M) + XB(M)
   20 CONTINUE
      TOTL = TOTL + V
      IF (TOTL .NE. 0.0) THEN
        CALL PLA269 (2 * N + 4)
        WRITE (LU7, 99999)
        DO 30 M = 2, N
          XXA(M) = XA(M) / TOTL
          XXB(M) = XB(M) / TOTL
          WRITE (LU7, 99998) M, XA(M), XXA(M), KMIN(M)
          WRITE (LU7, 99997)    XB(M), XXB(M), LMIN(M)
   30   CONTINUE
        VV = V / TOTL
      ENDIF
      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)
      END
      SUBROUTINE PLA223 (MODE, ANG, PHI, RL, N)
      DIMENSION PHI(*)
      IF (MODE .EQ. 1) THEN
        RL   = ABS(PHI(2) - ANG)
        IF (ANG .GE. 360 .AND. ANG .LT. 720)
     1      RL = ABS(PHI(N) + 360 - ANG)
        IF (ANG .GE. 720) RL = ABS(PHI(N) + 720 - ANG)
      ELSE IF (MODE .EQ. 2) THEN
        RL   = ABS(PHI(N) - ANG)
        IF (ANG .GE.  360 .AND. ANG .LT.  720)
     1      RL = ABS(PHI(N) +  360 - ANG)
        IF (ANG .GE.  720 .AND. ANG .LT. 1080)
     1      RL = ABS(PHI(N) +  720 - ANG)
        IF (ANG .GE. 1080 .AND. ANG .LT. 1440)
     1      RL = ABS(PHI(N) + 1080 - ANG)
        IF (ANG .GE. 1440 .AND. ANG .LT. 1800)
     1      RL = ABS(PHI(N) + 1440 - ANG)
        IF (ANG .GE. 1800) RL = ABS(PHI(N) + 1800 - ANG)
      ELSE IF (MODE .EQ. 3) THEN
        RL = ABS(PHI(N) - ANG)
        IF (ANG .GE.  360 .AND. ANG .LT.  720)
     1      RL = ABS(PHI(N) + 360 - ANG)
        IF (ANG .GE.  720 .AND. ANG .LT. 1080)
     1      RL = ABS(PHI(N) + 720 - ANG)
        IF (ANG .GE. 1080) RL = ABS(PHI(N) + 1080 - ANG)
      ELSE IF (MODE .EQ. 4) THEN
        RL = ABS(PHI(N) - ANG)
        IF (ANG .GE. 360) RL = ABS(PHI(N) + 360 - ANG)
      ENDIF
      RETURN
      END
      SUBROUTINE PLA224 (N, KK, KM, NR, PHI)
      REAL KK(50), KM
      YM = 380
      DO 10 I = 1, N
        Y = ABS(((KK(I) * 180) / (2 * NR)) - PHI)
        IF (Y .LT. YM) GOTO 20
        GOTO 10
   20   YM = Y
        KM = KK(I)
   10 CONTINUE
      RETURN
      END
      SUBROUTINE PLA225 (M, RK, RL, RKMIN, RLMIN, PHI, NR, N, N0)
      DIMENSION RK(*), RL(*), RKMIN(*), RLMIN(*), PHI(*)
      DO 10 I = 1, N
        RK(I) = N0 * (I - 1)
        RL(I) = FLOAT(N0 * (I - 1) + N0 / 2)
   10 CONTINUE
      CALL PLA224 (N, RK, RKMIN(M), NR, PHI(M))
      CALL PLA224 (N, RL, RLMIN(M), NR, PHI(M))
      RETURN
      END
      SUBROUTINE PLA226 (MTYPE, ANGLE)
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16,
     1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP25=99,NP29=63,
     2 NP38=125,NP39=30,NP41=200,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      IPR(201) = 0
      IGBL(67) = 1
      IF (MTYPE .GE. 0) CALL GEN021 (RMAT, 1)
      IF (MTYPE .NE. 0 .AND. IABS(MTYPE) .LE. 3) THEN
        CALL GEN051 (0, RMAT, ANGLE, IABS(MTYPE))
      ELSE IF (MTYPE .EQ. -4) THEN
        DO 20 L = 1, 3
          DO 10 L9 = 1, 3
            RMAT(L, L9) = - RMAT(L, L9)
   10     CONTINUE
   20   CONTINUE
      ENDIF
      CALL GEN005 (RMAT, DUMV)
      CALL GEN096 (DUMV, IROTX, IROTY, IROTZ, IDET, V6, YANK, QM)
      WRITE (LU6, 99999) IROTX, IROTY, IROTZ, IDET
      GL(28)   = IROTX
      GL(29)   = IROTY
      GL(30)   = IROTZ
      IGBL(87) = IDET
      IPR(330) = (1 - IDET) / 2
      RETURN
99999 FORMAT (':: NEW Xrot, Yrot, Zrot =', 3I5, ', Idet =', I2)
      END
      SUBROUTINE PLA227 (IAT, JAT, V)
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16,
     1 NP11=128,NP19=31,NP25=99,NP29=63,NP41=200,NP47=9)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      DIMENSION V(*)
      DO 10 K = 1, 3
        V(K) = XXO(JAT, K + 3) - XXO(IAT, K + 3)
   10 CONTINUE
      D = GEN017 (V)
      RETURN
      END
      SUBROUTINE PLA228
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118,
     1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,
     2 NP25=99,NP29=63,NP38=125,NP39=30,NP41=200,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9),
     1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10),
     2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10),
     3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770)
      IGBL(71) = 0
      NAT      = IPR(37)
      DO 10 I = 1, NP10
        IENLB(I) = 0
   10 CONTINUE
      DO 20 I = 1, NAT
        CALL GEN048 (2, IFG(I), 1, 0)
   20 CONTINUE
   30 N   = 0
      M   = 0
      NUM = 0
      DO 40 I = 1, NAT
        CALL GEN048 (-1, IFG(I), 2, IVAL)
        IF (IVAL .EQ. 0) THEN
          CALL GEN048 (-1, IFG(I), 1, IVAL)
          IF (IVAL .EQ. 0) THEN
            CALL GEN048 (-10, JFG(I), 14, NBUT)
            IF (NBUT .GT. M) THEN
              M = NBUT
              N = I
            ENDIF
          ENDIF
        ENDIF
   40 CONTINUE
      IF (N .GT. 0) THEN
        CALL PLA229 (NUM, N, N2)
   50   NC = - NINT(CON(N, NP4))
        IF (NC .LT. 0) NC = NP4
        N1 = 0
        M1 = 0
        DO 60 J = 1, NC
          K = NINT(CON(N, J))
          CALL GEN048 (-1, IFG(K), 1, IVAL)
          IF (IVAL .EQ. 0) THEN
            CALL GEN048 (-10, JFG(K), 14, NBUT)
            IF (NBUT .GT. M1) THEN
              M1 = NBUT
              N1 = K
            ENDIF
          ENDIF
   60   CONTINUE
        IF (N1 .GT. 0) THEN
          CALL PLA229 (NUM, N1, N2)
          N   = N1
          GOTO 50
        ELSE
          CALL GEN048 (1, IFG(N), 2, 1)
          N2 = N2 - 1
          IF (N2 .GT. 0) THEN
            N = JR(N2)
            GOTO 50
          ENDIF
          GOTO 30
        ENDIF
      ENDIF
      RETURN
      END
      SUBROUTINE PLA229 (NUM, NR, N2)
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118,
     1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP22=256,
     2 NP25=99,NP29=63,NP36=1000,NP38=125,NP39=30,NP41=200,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9),
     1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10),
     2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10),
     3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770)
      COMMON /ALIASES/ ALAB(NP36), BLAB(NP36)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      CHARACTER ALAB*7, BLAB*7
      CHARACTER NQ*2
      NUM     = NUM + 1
      N2      = NUM
      JR(NUM) = NR
      CALL GEN048 ( 1, IFG(NR), 1, 1)
      CALL GEN048 (-4, IFG(NR), 15, NO)
      NO        = NO + 1
      NQ        = LMT(NO, 1)
      IENLB(NO) = IENLB(NO) + 1
      NUM0      = IENLB(NO)
      IF (NQ(1:1) .EQ. ' ') THEN
        NQ2 = NQ(2:2)
        K0  = 2
      ELSE
        NQ2 = NQ
        K0  = 3
      ENDIF
      IF (NUM0 .LT. 10) THEN
        WRITE(NQ2(K0:), 99999) NUM0
      ELSE IF (NUM0 .LT. 100) THEN
        WRITE(NQ2(K0:), 99998) NUM0
      ELSE
        WRITE(NQ2(K0:), 99997) NUM0
      ENDIF
      CALL PLA047 (XLAB(NR), NQ1, IDUM, IENR, IGBL(55), IPR(119), 0, 0)
      IGBL(71)       = IGBL(71) + 1
      ALAB(IGBL(71)) = NQ2
      BLAB(IGBL(71)) = NQ1
      RETURN
99999 FORMAT (I1, 1X)
99998 FORMAT (I2, 1X)
99997 FORMAT (I3, 1X)
      END
      SUBROUTINE PLA230 (MODE)
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16,
     1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP22=256,NP25=99,
     2 NP29=63,NP38=125,NP39=30,NP41=200,NP45=2048,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /Q/ ICL, IFL(NP17)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /FNAME/ KNM(8), KXT, KNM16
      COMMON /NAMES/ NAME(8), EXTENS, PROGNM, FNLU1, FNLU16, RDTYPE
      CHARACTER NAME*80, EXTENS*9, PROGNM*28, FNLU1*80, FNLU16*80,
     1          RDTYPE*7, FPARSU*17
      COMMON /BONDTYPE/ BNDTP(11)
      CHARACTER BNDTP*5
      COMMON /CGG11/ BCD, SBCD
      CHARACTER BCD*132, SBCD*132
      COMMON /PAGENM/ PAGET, PAGEIND(25)
      CHARACTER PAGET*8, PAGEIND*8
      COMMON /VALDOC/ NDOC(999)
      CHARACTER SPLC*11
      CHARACTER WLEVEL(3)*8, MESS*60, CHK*4, ICH*1, WR*5, CNT*2,
     1 TYPE*1, FORM*18, FORMC*106, FORMD*95
      DIMENSION IATYPE(4)
      COMMON /ALERT/ ATYPE
      CHARACTER ATYPE(4)*61
      DATA 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.'/
      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,'')'')'
      FORMD(1:36)   = '(''# WaveLength'',F8.5,4X,''Volume'',2X,'
      FORMD(37:66)  = '''Reported'',F9.2,''('',I2,'')'',2X,'
      FORMD(67:95)  = '''Calculated'',F9.2,''('',I2,'')'')'
      FORM          = '(F8.5,''('',I2,'') '')'
      FPARSU        = '(F5.2,''('',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(51:51)  = CHAR(ICHAR('0') + IPR(314))
      FORMD(83:83)  = CHAR(ICHAR('0') + IPR(294))
      IF (MODE .EQ. 0) THEN
        NALERT   = 0
        IGBL(14) = 1
        CALL GEN097 (NALV,   1, 4, 0)
        CALL GEN097 (IATYPE, 1, 4, 0)
        CALL GEN108 (LU20, 1)
        IF (IGBL(36) .GT. 0) THEN
          LU = LU10
        ELSE
          LU = LU7
          PAGET = 'CHECKCIF'
          CALL PLA269 (0)
          CALL PLA269 (26)
        ENDIF
        IF (IGBL(19) .GT. 0) THEN
          DO 110 NAL = 1, 3
            CALL GEN108 (LU19, 0)
   10       READ (LU19, 99966, END = 110) ICL(1:80)
            IF (ICL(1:1) .EQ. CHAR(32)) GOTO 10
            IF (ICL(1:1) .EQ. '$') GOTO 110
            IF (ICL(1:1) .EQ. '#') THEN
              IF (ICL(3:5) .EQ. '>>>') THEN
                READ (ICL(2:2), 99959) ISKP
              ENDIF
              GOTO 10
            ENDIF
            READ (ICL, 99967, ERR = 190) CHK, V2, TYPE
            READ (TYPE, '(I1)') ITYPE
            READ (LU19, 99966, END = 110) MESS
            READ (ICL, 99970, ERR = 190) ICHK
            IF (ISKP .EQ. 1 .AND. IABS(IGBL(8)) .NE. 3) GOTO 10
            IF (NAL .GT. 1 .AND. ICHK .LE. 15) GOTO 10
            IF (CHK .EQ. '_000') THEN
              READ (MESS, 99966) (WLEVEL(L), L = 1, 3)
              GOTO 10
            ELSE IF (CHK .EQ. '_001') THEN
              WRITE (MESS(17:22), '(I6)') IGBL(9)
              WRITE (LU, 99979) MESS, JID(1:9)
              N = MAX (1, KNM(3) + KXT + 1)
              LINE(1:N) = NAME(3)(1:KNM(3))//'.'//EXTENS(1:KXT)
              WRITE (PRBUF, 99982) LINE(1:N), DTYPE(IABS(IGBL(8)))
              WRITE (PRBUF(50:), 99976) BNDTP(1), PAR(318)
              WRITE (LU, 99962) PRBUF(1:80)
              IF (IGBL(29) .GT. 0 .AND. IGBL(29) .LT. 20) THEN
                IF (LU .EQ. LU7) CALL PLA269 (1)
                WRITE (LU, 99981) FNLU16(1:KNM16), RDTYPE
              ENDIF
              WRITE (LU, 99960)
              NALV(4) = NINT (10000.0 * PAR(318))
            ELSE IF (CHK .EQ. '_002') THEN
              WRITE (PRBUF, FORMC) PAR(101), IPR(281), PAR(102),
     1          IPR(282), PAR(103), IPR(283), PAR(104), IPR(284),
     2          PAR(105), IPR(285), PAR(106), IPR(286)
              CALL GEN065 (LU, PRBUF, 80, 3)
              WRITE (PRBUF, FORMD) MAX (PAR(17), 0.0),
     1          PAR(164), IPR(313), PAR(98),  IPR(293)
              CALL GEN065 (LU, PRBUF, 80, 3)
            ELSE IF (CHK .EQ. '_003') THEN
              IF (SPGRNM(3)(1:1) .EQ. ' ') THEN
                N0 = 2
              ELSE
                N0 = 1
              ENDIF
              IF (SPGRNM(1)(9:9) .NE. ' ') THEN
                SPLC = ZSPG
              ELSE
                SPLC = SPGRNM(4)(1:11)
              ENDIF
              CALL GEN020 (-1, SPLC, 2, 11)
            WRITE (LU, 99980) SPLC, SPGRNM(3)(N0:17),
     1                        CCIF(6)(1:11), CCIF(16)
            ELSE IF (CHK .EQ. '_004') THEN
              CALL PLA283 (0, 1, N, IDM)
              DO 20 N1 = 1, 65
                IF (RLWS(4)(N1:N1) .EQ. '''') GOTO 30
   20         CONTINUE
   30         IF (N .LE. 80 .AND. N1 .GT. 1)
     1          WRITE (LU, 99978) IDM(N:80), RLWS(4)(1 : N1 - 1)
            ELSE IF (CHK .EQ. '_005') THEN
              CALL PLA283 (2, IPR(260), N, IDM)
              DO 40 N1 = 1, 65
                IF (RLWS(5)(N1:N1) .EQ. '''') GOTO 50
   40         CONTINUE
   50         IF (N .LE. 80 .AND. N1 .GT. 1)
     1          WRITE (LU, 99977) IDM(N : 80), RLWS(5)(1 : N1 - 1)
            ELSE IF (CHK .EQ. '_006') THEN
              WRITE (LU, 99989) PAR(163) / IPR(260), PAR(308)
            ELSE IF (CHK .EQ. '_007') THEN
              WRITE (LU, 99987) PAR(160), PAR(267)
            ELSE IF (CHK .EQ. '_008') THEN
              WRITE (LU, 99988) IPR(260), IPR(276)
            ELSE IF (CHK .EQ. '_009') THEN
              WRITE (LU, 99998) PAR(162), PAR(301)
            ELSE IF (CHK .EQ. '_010') THEN
              WRITE (LU, 99975) PAR(157), PAR(324), PAR(426)
            ELSE IF (CHK .EQ. '_011') THEN
              IF (PAR(306) .LT. 99998.0 .AND. PAR(307) .LT. 99998.0)
     1          WRITE (LU, 99997) PAR(307), PAR(306), RLWS(3)(1:15)
            ELSE IF (CHK .EQ. '_012') THEN
              IF (IGBL(94) .EQ. 0)
     1          WRITE (LU, 99999) PAR(315), PAR(316), PAR(317)
            ELSE IF (CHK .EQ. '_013') THEN
              MH = MAX (0, -IPR(267), IPR(268))
              MK = MAX (0, -IPR(269), IPR(270))
              ML = MAX (0, -IPR(271), IPR(272))
              IF (IGBL(94) .EQ. 0)
     1          WRITE (LU, 99986) MH, MK, ML,
     2                 MAX (0, IPR(263)), MAX (0.0, PAR(168))
            ELSE IF (CHK .EQ. '_014') THEN
              IF (IPR(559) .NE. 0) THEN
                RATIO1 = FLOAT(MAX(0, IPR(263))) / IPR(559)
              ELSE
                RATIO1 = 0.0
              ENDIF
              IF (IPR(560) .NE. 0) THEN
                RATIO2 = FLOAT(MAX(0, IPR(263))) / IPR(560)
              ELSE
                RATIO2 = 0.0
              ENDIF
              IF (IGBL(29) .GT. 0) THEN
                IF (IGBL(29) .LT. 20 .OR. IGBL(29) .EQ. 21) THEN
                  IF (LU .EQ. LU7) CALL PLA269 (1)
                  WRITE (LU, 99968) IPR(585), IPR(586), IPR(587),
     1                              IPR(373), PAR(446)
                ENDIF
              ENDIF
              IF (IGBL(94) .EQ. 0) THEN
                IF (IPR(257) .EQ. 1) THEN
                  WRITE (LU, 99985) IPR(561), IPR(562), IPR(563),
     1                              IPR(559), IPR(560), RATIO1, RATIO2
                ELSE
                  WRITE (LU, 99969) IPR(561), IPR(562), IPR(563),
     1                              IPR(559), RATIO1
                ENDIF
              ENDIF
            ELSE IF (CHK .EQ. '_015') THEN
              IF (PAR(437) .GT. 0.0) THEN
                IF (LU .EQ. LU7) CALL PLA269 (1)
                WRITE (LU, 99957) PAR(437), PAR(438)
              ENDIF
              IF (ABS(PAR(173)) .LT. 100.0) THEN
                IF (IPR(309) .EQ. 2) THEN
                  WR  = ' wR2='
                  WGR = PAR(174)
                ELSE
                  WR  = '  wR='
                  WGR = MAX (PAR(174), PAR(310))
                ENDIF
                FPARSU(5:5) = CHAR(ICHAR('0') + IPR(280))
                WRITE (PRBUF, FPARSU) PAR(433), IPR(279)
                CALL GEN065 (0, PRBUF, 10, 1)
                WRITE (IDM, 99984) PAR(173), IPR(264), WR, WGR,
     1                 IPR(265), PAR(299), IPR(266), PRBUF(1:9)
                IF (IGBL(94) .EQ. 0) THEN
                  WRITE (LU, 99958)
     1                   MIN (0.0, PAR(176)), MAX (0.0, PAR(177))
                  IF (PAR(433) .LT. 999999) THEN
                    WRITE (LU, 99966) IDM
                  ELSE
                    WRITE (LU, 99966) IDM(1:60)
                  ENDIF
                ENDIF
              ENDIF
            ELSE
              CALL GEN108 (LU20, 0)
   60         READ (LU20, 99966, END = 10) ICL(1:80)
              IF (ICL(1:4) .EQ. CHK) THEN
                IF (ICL(15:15) .EQ. '*' .OR.
     1              ICL(25:25) .EQ. '*') GOTO 60
                IF (CHK .EQ. '_790' .AND. IPR(322) .NE. 0) GOTO 60
                READ (ICL(5:40), '(2F10.0, 3A)', ERR = 190)
     1                VALUE, VALUE1, NQ1, NQ2, CNT
                IF (CHK .NE. '_126' .AND. CHK .NE. '_127') THEN
                  CALL GEN121 (NQ1)
                  CALL GEN121 (NQ2)
                ENDIF
                NB  = 1
                NE  = 7
                NQ4 = ' '
                CALL GEN039 (1, NQ1, 1, 7, NB, NE)
                NQ4 (8 - NE : 7) = NQ1(1 : NE)
                IF (CNT .EQ. ' =') READ (LU20, 99962) ICL(1:80)
                DO 100 I = 1, NAL
                  IF (VALUE .GT. V2(4 - I))  THEN
                    IF (I .LT. NAL) GOTO 60
                    N = 4 - I
                    IF (NALV(I) .EQ. 0) THEN
                      IF (LU .EQ. LU7) CALL PLA269 (1)
                      WRITE (LU, 99994)
                    ENDIF
                    NALV(I)       = NALV(I) + 1
                    IF (ITYPE .GT. 0 .AND. ITYPE .LT. 5)
     1                IATYPE(ITYPE) = IATYPE(ITYPE) + 1
                    IDM(1:14) =
     1                CHK(2:4)//'_ALERT_'//TYPE//'_'//WLEVEL(N)(7:8)
                    IVAR = 0
                    L    = 14
                    K    = 0
   70               K    = K + 1
                    IF (K .GT. 59) GOTO 90
                    ICH = MESS(K:K)
                    IF (IVAR .EQ. 0) THEN
                      IF (ICH .EQ. '$') THEN
                        IVAR = 1
                      ELSE
                        IF (L .LT. 80) THEN
                          L = L + 1
                          IDM(L:L) = ICH
                        ENDIF
                      ENDIF
                    ELSE
                      IF (ICH .EQ. 'A') THEN
                        IF (L .GT. 52 .AND. NQ2 .EQ. '       ') THEN
                          IDM(L + 1:L + 7) = NQ4
                        ELSE
                          IDM(L + 1:L + 7) = NQ1
                        ENDIF
                        L = L + 7
                      ELSE IF (ICH .EQ. 'B') THEN
                        DO 80 L0 = 1, 7
                          IF (L .LT. 80) THEN
                            L = L + 1
                            IDM(L:L) = NQ2(L0:L0)
                          ENDIF
   80                   CONTINUE
                      ELSE IF (ICH .EQ. 'I') THEN
                        WRITE (IDM(L+1:L+10), 99964) NINT(VALUE1)
                        L = L + 10
                      ELSE IF (ICH .EQ. 'F') THEN
                        WRITE (IDM(L+1:L+10), 99963) VALUE1
                        L = L + 10
                      ELSE IF (ICH .EQ. 'X' .OR. ICH .EQ. 'Y') THEN
                        IF (CHK .EQ. '_701' .OR. CHK .EQ. '_704' .OR.
     1                      CHK .EQ. '_705' .OR. CHK .EQ. '_706' .OR.
     2                      CHK .EQ. '_707' .OR. CHK .EQ. '_721' .OR.
     3                      CHK .EQ. '_724' .OR. CHK .EQ. '_725' .OR.
     4                      CHK .EQ. '_726' .OR. CHK .EQ. '_727' .OR.
     5                      CHK .EQ. '_731' .OR. CHK .EQ. '_734' .OR.
     6                      CHK .EQ. '_735' .OR. CHK .EQ. '_736' .OR.
     7                      CHK .EQ. '_737' .OR. CHK .EQ. '_741' .OR.
     8                      CHK .EQ. '_744' .OR. CHK .EQ. '_745' .OR.
     9                      CHK .EQ. '_746' .OR. CHK .EQ. '_747' .OR.
     *                      CHK .EQ. '_751' .OR. CHK .EQ. '_754' .OR.
     1                      CHK .EQ. '_755' .OR. CHK .EQ. '_756' .OR.
     2                      CHK .EQ. '_757') THEN
                          NDECM = 5
                        ELSE IF (CHK .EQ. '_702' .OR. CHK .EQ. '_708'
     1                     .OR.  CHK .EQ. '_722' .OR. CHK .EQ. '_728'
     2                     .OR.  CHK .EQ. '_732' .OR. CHK .EQ. '_738'
     3                     .OR.  CHK .EQ. '_742' .OR. CHK .EQ. '_748'
     4                     .OR.  CHK .EQ. '_752' .OR. CHK .EQ. '_758')
     5                    THEN
                          NDECM = 2
                        ELSE IF (CHK .EQ. '_703' .OR. CHK .EQ. '_723'
     1                     .OR.  CHK .EQ. '_733' .OR. CHK .EQ. '_743'
     2                     .OR.  CHK .EQ. '_753')  THEN
                          NDECM = 2
                        ENDIF
                        IF (ICH .EQ. 'Y') THEN
                          READ (ICL, 99965) A1, SA1
                          CALL GEN038 (ICL, 1, 14)
                        ELSE
                          READ (NQ1, 99965) A1
                          READ (NQ2, 99965) SA1
                        ENDIF
                        CALL GEN041 (A1, SA1, ISA1, NDECM, NDEC, 2)
                        FORM(5:5) = CHAR(ICHAR('0') + NDEC)
                        WRITE (PRBUF, FORM) A1, ISA1
                        CALL GEN065 (0, PRBUF, 13, 1)
                        IDM(L+1:L+12) = PRBUF(1:12)
                        L = L + 12
                      ENDIF
                      IVAR = 0
                    ENDIF
                    GOTO 70
   90               NALERT = NALERT + 1
                    IF (NALERT .EQ. 1) THEN
                      IF (LU .EQ. LU7) CALL PLA269 (5)
                      WRITE (LU, 99996)
                    ENDIF
                    READ (CHK, 99970) IDOC
                    NDOC(IDOC) = 1
                    IF (LU .EQ. LU7) CALL PLA269 (1)
                    WRITE (LU, 99966) IDM(1:L)
                    IF (CNT .EQ. ' =') THEN
                      IF (LU .EQ. LU7) CALL PLA269 (1)
                      WRITE (LU, 99966) ICL(1:80)
                    ENDIF
                    GOTO 60
                  ENDIF
  100           CONTINUE
              ENDIF
              GOTO 60
            ENDIF
            GOTO 10
  110     CONTINUE
          IF (NALERT .EQ. 0) THEN
            WRITE (LU, 99994)
            WRITE (LU, 99995)
          ELSE
            IF (LU .EQ. LU7) CALL PLA269 (14)
            WRITE (LU, 99994)
            WRITE (LU, 99990)
            IF (NALV(1) .GT. 0) WRITE (LU, 99993) NALV(1)
            IF (NALV(2) .GT. 0) WRITE (LU, 99992) NALV(2)
            IF (NALV(3) .GT. 0) WRITE (LU, 99991) NALV(3)
            WRITE (LU, 99961)
            DO 120 I = 1, 4
              IF (IATYPE(I) .GT. 0)
     1            WRITE (LU, 99971) IATYPE(I), I, ATYPE(I)
  120       CONTINUE
          ENDIF
          WRITE (LU, 99994)
          IF (LU .EQ. LU10) THEN
            IF (IGBL(25) * IGBL(32) .EQ. 1) THEN
              WRITE (BCD, 99983) JID(1:9), (NALV(I), I = 1, 3), CHAR(0)
              CALL GGIP (-999.0, 5.0 + FLOAT(IGBL(68)), 80.0, 112)
              CALL GGIP (0.0, 0.0, 0.0, 6)
            ENDIF
            IGBL(53) = IGBL(53) + 1
            IF (IGBL(53) .LT. 11) THEN
              BNDTP(IGBL(53)) = BNDTP(1)
              DO 130 KK = 1, 4
                NALV(IGBL(53) * 4 + KK) = NALV(KK)
  130         CONTINUE
            ENDIF
          ENDIF
        ENDIF
      ELSE IF (MODE .EQ. 1) THEN
C * ALERT SUMMARY FOR TEXT WINDOW
        NAENTRY = MIN (10, IGBL(53))
        DO 140 J = 1, NAENTRY
          WRITE (LU6, 99972) J, (NALV(J * 4 + I), I = 1, 3),
     1                           BNDTP(J), NALV(J * 4 + 4) / 10000.0
  140   CONTINUE
        IF (IGBL(53) .GT. 10) WRITE (LU6, 99956) IGBL(53)
C * VALIDATION-DOC (COMMENT/HINTS)
        IF (IGBL(83) .NE. 0) THEN
          REWIND LU19
          NEXP = 0
          DO 170 I = 20, 999
            IF (NDOC(I) .GT. 0) THEN
              NEXP = NEXP + 1
              IF (NEXP .EQ. 1) WRITE (LU10, 99974)
              IF (I .LT. 100) THEN
                WRITE (CHK, '(''_0'', I2)') I
              ELSE
                WRITE (CHK, '(''_'', I3.0)') I
              ENDIF
  150         READ (LU19, 99966, END = 180) ICL(1:80)
              IF (ICL(1:4) .NE. CHK) GOTO 150
              READ (ICL(20:21), '(I2)') IVALTYPE
              READ (LU19, 99966) ICL(1:80)
              READ (LU19, 99966) ICL(1:80)
              IF (ICL(1:1) .EQ. '#') GOTO 170
              IF (ICL(1:2) .EQ. '  ') THEN
                WRITE (LU10, 99973) CHK, IVALTYPE, ATYPE(IVALTYPE)
  160           READ (LU19, 99966, END = 180) ICL(1:80)
                IF (ICL(1:1) .EQ. '#') GOTO 170
                WRITE (LU10, 99966) ICL(1:80)
                GOTO 160
              ENDIF
              GOTO 150
            ENDIF
  170     CONTINUE
        ENDIF
        GOTO 190
      ENDIF
  180 CALL GEN108 (LU20, 0)
  190 RETURN
99999 FORMAT ('# Calculated T limits: Tmin=', F5.3,
     1       ' Tmin''=', F5.3, '  Tmax=', F5.3)
99998 FORMAT ('# Mu (mm-1) =', F10.3, '[Calc],', F10.3, '[Rep]')
99997 FORMAT ('# Reported   T limits: Tmin=', F5.3,
     1       14X, 'Tmax=', F5.3, 1X, A)
99996 FORMAT (/, 10X, '>>> The Following ALERTS were generated <<<',
     1        /, 10X, 43('-'), /, 5X,
     2        'Format: alert-number_ALERT_alert-type_alert-level',
     2        ' text', /)
99995 FORMAT (/, '!! Congratulations !! :', 1X,
     1           'No (Serious) ALERT Situations were Detected')
99994 FORMAT ('#', 79('='))
99993 FORMAT (I3, ' ALERT_Level_A = In General: Serious Problem')
99992 FORMAT (I3, ' ALERT_Level_B = Potentially Serious Problem')
99991 FORMAT (I3, ' ALERT_Level_C = Check & Explain')
99990 FORMAT (/, 15X, 'ALERT_Level and ALERT_Type Summary', /,
     1        15X, 34('='))
99989 FORMAT ('# Mr        =', F10.2, '[Calc],', F10.2, '[Rep]')
99988 FORMAT ('# Z         =', I10  , '[Calc],', I10,   '[Rep]')
99987 FORMAT ('# Dx,gcm-3  =', F10.3, '[Calc],', F10.3, '[Rep]')
99986 FORMAT ('# Reported   Hmax=', I3, ', Kmax=', I3, ', Lmax=', I3,
     1        ', Nref=', I5, 7X, ', Th(max)=', F6.2)
99985 FORMAT ('# Calculated Hmax=', I3, ', Kmax=', I3, ', Lmax=', I3,
     1        ', Nref=', I5, '(', I5, '), Ratio=', F5.2, '(', F5.2, ')')
99984 FORMAT ('# R=', F7.4, '(', I5, '),', A, F7.4, '(', I5, '), S =',
     1        F6.3, ', Npar=', I4, ', Flack=', A)
99983 FORMAT ('Entry ', A, ' - ', I3, 'A,', I3, 'B,',
     1        I3, 'C-Alerts', A)
99982 FORMAT ('# Data From: ', A, ' - Data Type: ', A, 20X)
99981 FORMAT ('# Refl Data: ', A, ' - Data Type: ', A)
99980 FORMAT ('# SpaceGroup from Symmetry ', A, 3X, 'Hall: ', A,
     1     /, '#                 Reported ', A, 9X          , A)
99979 FORMAT (/, '#', 78('='), '#', /, A, ' for 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 (/, 'Explanation and Advice for the Reported ALERTS',
     1        /, 80('='), /)
99973 FORMAT (80('='), /, 'ALERT', A, ' Type_', I1, 1X, A, /,
     1        80('='), /)
99972 FORMAT (24X, 'Entry #', I3, ' - ', I3, 'A,', I3, 'B,',
     1        I3, 'C-Alerts, BP ', A, ' =', F7.4)
99971 FORMAT (I3, 1X, 'ALERT_Type_', I1, 1X, A)
99970 FORMAT (1X, I3)
99969 FORMAT ('# Calculated Hmax=', I3, ', Kmax=', I3, ', Lmax=', I3,
     1        ', Nref=', I5, 7X, ', Ratio  =', F6.2)
99968 FORMAT ('# Obs in FCF Hmax=', I3, ', Kmax=', I3, ', Lmax=', I3,
     1        ', Nref=', I5, 7X, ', Th(max)=', F6.2)
99967 FORMAT (A, 3F5.0, 1X, A)
99966 FORMAT (3A)
99965 FORMAT (2F7.0)
99964 FORMAT (I10)
99963 FORMAT (F10.2)
99962 FORMAT (A)
99961 FORMAT (1X)
99960 FORMAT ('#')
99959 FORMAT (I1)
99958 FORMAT ('# rho(min) =', F6.2, ', rho(max) =', F6.2, ' e/Ang^3')
99957 FORMAT ('# Squeeze: Volume = ', F8.1, ' Ang^3^, Total El.Count =',
     1        F8.1, ' e')
99956 FORMAT (/, 24X, 'etc..    (', I3, ' Entries Total)')
      END
      SUBROUTINE PLA231 (MERR)
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16,
     1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP22=256,NP25=99,
     2 NP29=63,NP38=125,NP39=30,NP41=200,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      CHARACTER ICH*1, JCH*1
      DIMENSION TABT(7, 3)
      DATA ((TABT(I, J), I = 1, 7), J = 1, 3)/
     1   1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0,
     2   1.0, 1.01, 1.04, 1.09, 1.15, 1.25, 1.4,
     3   1.0, 1.05, 1.15, 1.25, 1.5,  1.9,  2.5/
      IF (MERR .EQ. 20) THEN
        IF (IPR(263) .GT. IPR(262)) WRITE (LU20, 99998) '_030', 1, 1
        P168  = MAX (0.0, PAR(168))
        RESOL = SIN (P168 / GL(5)) / PAR(17)
        IF (P168 .GT. 0.0) THEN
          IF (IPR(559) .NE. 0) THEN
            RATIO  = FLOAT (MAX (0, IPR(263))) / FLOAT(IPR(559))
            RATMAX = 3.0 - IPR(257)
            IF (RATIO .GT. RATMAX) THEN
              WRITE (LU20, 99997) '_021', (RATIO - RATMAX) / RATMAX,
     1               RATIO
            ELSE IF (RATIO .LT. 1.0) THEN
              IF (RESOL .LT. 0.65) THEN
                WRITE (LU20, 99997) '_022', 1.0 - RATIO, RATIO
              ENDIF
            ENDIF
          ENDIF
          IF (PAR(434) .GT. 0.2) THEN
            IF (RATIO .GT. 1.002 .AND. IPR(257) .EQ. 1 .AND.
     1        IPR(22) .LE. 14)
     2        WRITE (LU20, 99998) '_024',  1, 1
          ENDIF
          IF (IPR(263) .NE. 0) THEN
            IRATIO = NINT (MAX(0, IPR(264)) / FLOAT(IPR(263)) * 100.0)
          ELSE
            IRATIO = 0
          ENDIF
          WRITE (LU20, 99998) '_026', 100 - IRATIO, IRATIO
        ENDIF
C * CHECK RESOLUTION
        IF (IGBL(94) .EQ. 0) THEN
          WRITE (LU20, 99997) '_023', 0.6 - RESOL, P168
          P313 = MAX (0.0, PAR(313))
          IF (P313 .EQ. 0.0) WRITE (LU20, 99998) '_038', 1, 1
          P312 = MAX (0.0, PAR(312))
          RESOL1 = SIN (P312 / GL(5)) / PAR(17)
          IF (P312 .EQ. 0.0) WRITE (LU20, 99998) '_037', 1, 1
          P314 = MAX (0.0, PAR(314))
          IF (P314 .EQ. 0.0) WRITE (LU20, 99998) '_039', 1, 1
          IF (P314 .GE. P313) THEN
            WRITE (LU20, 99997) '_029', 1.0 - P314, P314
            WRITE (LU20, 99997) '_027', 0.6 - RESOL1, P312
          ELSE
            WRITE (LU20, 99997) '_028', 1.0 - P313, P313
          ENDIF
          DO 10 I = 267, 272
            IF (IABS(IPR(I)) .EQ. 999999) THEN
              WRITE (LU20, 99999) '_025', 1.0, 1.0
              GOTO 50
            ENDIF
   10     CONTINUE
        ENDIF
      ELSE IF (MERR .EQ. 50) THEN
        IF (IGBL(94) .EQ. 0) THEN
          IF (PAR(301) .EQ. 0.0 .AND. IGBL(94) .EQ. 0) THEN
            WRITE (LU20, 99999) '_050', 1.0, 1.0
          ELSE IF (IPR(493) .GT. 0 .AND. IPR(493) .LT. 4) THEN
            IF (ABS(PAR(162) - PAR(301)) .GT. 0.03) THEN
              DEVIA = ABS(1.0 - PAR(162) / PAR(301)) * 100.0
              WRITE (LU20, 99999) '_051', DEVIA, DEVIA
            ENDIF
            IF (IPR(485) .LT. 0) THEN
              WRITE (LU20, 99999) '_052', 1.0, 1.0
            ELSE IF (IPR(485) .GT. 0) THEN
              IF (PAR(306) .EQ. 0.0)
     1            WRITE (LU20, 99999) '_058', 1.0, 1.0
              IF (PAR(307) .EQ. 0.0)
     1            WRITE (LU20, 99999) '_059', 1.0, 1.0
            ENDIF
            IF (PAR(307) .GT. PAR(306))
     1          WRITE (LU20, 99999) '_064', 1.0, 1.0
            IF (ABS(PAR(157) - PAR(324)) .GT. 0.1)
     1          WRITE (LU20, 99999) '_068', 1.0, 1.0
            IF (IPR(485) .EQ. 7 .OR. IPR(486) .EQ. 8) THEN
              V1(1) = 2 * PAR(305)
              IF (V1(1) .EQ. 0.0) WRITE (LU20, 99999) '_056', 1.0, 1.0
              V1(2) = V1(1)
              V1(3) = V1(1)
              WRITE (LU20, 99999) '_063', V1(3), V1(3)
            ELSE
              IF (PAR(305) .LE. 0.0) THEN
                NERR  = 0
                V1(1) = PAR(304)
                V1(2) = PAR(303)
                V1(3) = PAR(302)
                IF (V1(1) .GT. 0.0 .AND. V1(3) .GT. 0.0) THEN
                   IF (V1(1) .GT. V1(3)) THEN
                       WRITE (LU20, 99999) '_067', 1.0, 1.0
                       NERR = 1
                   ENDIF
                ENDIF
                IF (V1(1) .LE. 0.0) THEN
                  WRITE (LU20, 99999) '_053', 1.0, 1.0
                  NERR = 1
                ENDIF
                IF (V1(2) .LE. 0.0) THEN
                  WRITE (LU20, 99999) '_054', 1.0, 1.0
                  NERR = 1
                ENDIF
                IF (V1(3) .LE. 0.0) THEN
                  WRITE (LU20, 99999) '_055', 1.0, 1.0
                  NERR = 1
                ELSE
                  WRITE (LU20, 99999) '_063', V1(3), V1(3)
                ENDIF
                IF (NERR .NE. 0) GOTO 50
              ENDIF
            ENDIF
            IF (V1(1) * V1(2) * V1(3) .GT. 0.0) THEN
              IF (IPR(493) .GT. 0 .AND. IPR(493) .LT. 4) THEN
                TMIDMU   = V1(2) * PAR(301)
                J        = MAX (1, IPR(493))
                I        = MIN (7, 1 + INT((TMIDMU + 0.25) * 2))
                V1(4)    = MAX (V1(2), MIN (1.2 * V1(2), V1(3)))
                PAR(317) = EXP(-V1(1) * PAR(301))
                PAR(315) = EXP(-V1(4) * PAR(301)) * TABT(I, J)
                PAR(316) = EXP(-V1(3) * PAR(301)) * TABT(I, J)
                V3(1)    = 1.0
                V3(2)    = PAR(317) / PAR(315)
                V3(3)    = PAR(317) / PAR(316)
                IF (IPR(485) .LT. 1)
     1            WRITE (LU20, 99999) '_057', V3(2), V3(2)
                VERS  = ABS(PAR(317) - PAR(306)) + ABS(PAR(316)
     1                - PAR(307))
                VERS1 = ABS(PAR(317) - PAR(306)) + ABS(PAR(315)
     1                - PAR(307))
                IF (VERS .LT. 0.0025 .OR. VERS1 .LT. 0.0025)
     1            WRITE (LU20, 99999) '_066', 1.0, 1.0
                IF (IPR(485) .LT. 1 .OR. IPR(485) .GT. 3) THEN
                  IF (TMIDMU .GT. 1.0)
     1              WRITE (LU20, 99999) '_065', TMIDMU, TMIDMU
                ENDIF
                IF (IPR(485) .GE. 0) THEN
                  IF (IPR(485) .GT. 3) THEN
                    IF (PAR(306) * PAR(307) .NE. 0.0 .AND. PAR(306)
     1                 .LT. 99999 .AND. PAR(307) .LT. 99999) THEN
                      V3(1) = PAR(306) / PAR(307)
                      RR    = V3(2) / V3(1)
                      RRP   = MIN(99999.0, V3(3) / V3(1))
                      WRITE (LU20, 99997) '_060', RR, RR
                      WRITE (LU20, 99997) '_061', 1.0 - RRP, RRP
                      IF (ABS(PAR(317) - PAR(306)) .GT. 0.01)
     1                  WRITE (LU20, 99997)
     2                     '_062', 1.0, PAR(317) / PAR(306)
                    ENDIF
                  ENDIF
                ENDIF
              ENDIF
            ENDIF
          ENDIF
        ENDIF
      ELSE IF (MERR .EQ. 70) THEN
        IF (IPR(215) .GT. 0) WRITE (LU20, 99999) '_077', 0.5, 0.5
        IF (IPR(484) .LE. 0) THEN
          IF (CCIF(12)(1:NCIF(12)) .EQ. 'geom')
     1      WRITE (LU20, 99998) '_078', 1, 1, 'geom'
          IF (CCIF(13)(1:NCIF(13)) .EQ. 'mixed')
     1      WRITE (LU20, 99998) '_079', 1, 1, 'mixed'
        ELSE
          IF (IPR(564) .EQ. 0 .AND. CCIF(13)(1:NCIF(13)) .EQ. 'mixed')
     1      WRITE (LU20, 99998) '_093', 1, 1, 'mixed'
        ENDIF
      ELSE IF (MERR .EQ. 80) THEN
C * NO Hall SPACEGROUP SPECIFIED
        IF (IGBL(94) .EQ. 0) THEN
          IF (CCIF(16)(1:1) .EQ. '?' .OR. CCIF(16)(1:1) .EQ. ' ') THEN
            WRITE (LU20, 99998) '_125', 1, 1
          ELSE
            IF (SPGRNM(3)(1:1) .EQ. CHAR(32)) THEN
              I = 1
            ELSE
              I = 0
            ENDIF
            IF (SPGRNM(3)(I+1:I+1) .EQ. ' ') THEN
              WRITE (LU20, 99996) '_127', 1.0, 1.0,
     1                       CCIF(16)(1:7), CCIF(16)(8:14)
              GOTO 40
            ENDIF
            J   = 0
   20       I   = I + 1
            IF (I .GT. 17) GOTO 40
            ICH = SPGRNM(3)(I:I)
            IF (ICH .EQ. '_' .OR. ICH .EQ. CHAR(32)) GOTO 20
   30       J   = J + 1
            IF (J .LT. 18) THEN
              JCH = CCIF(16)(J:J)
              IF (JCH .EQ. '_' .OR. JCH .EQ. CHAR(32)) GOTO 30
              IF (ICH .EQ. JCH) GOTO 20
            ENDIF
            WRITE (LU20, 99996) '_127', 1.0, 1.0,
     1                       CCIF(16)(1:7), CCIF(16)(8:14)
          ENDIF
        ENDIF
   40   IF (IGBL(94) .EQ. 0) THEN
          IF (PAR(178) .GT. -999999.0) THEN
            WRITE (LU20, 99999) '_080', ABS(PAR(178)), ABS(PAR(178))
          ELSE
            WRITE (LU20, 99999) '_081', 1.0, 1.0
          ENDIF
        ENDIF
        WRITE (LU20, 99999) '_082', PAR(173), PAR(173)
        WRITE (LU20, 99999) '_084', PAR(174), PAR(174)
        IF (IPR(265) .GT. 0 .AND. IPR(266) .GT. 0) THEN
          RATO = FLOAT(IPR(266)) / FLOAT(IPR(265))
          IF (IPR(257) .EQ. 2) THEN
            WRITE (LU20, 99999) '_088', 100 * RATO, 1.0 / RATO
          ELSE
            WRITE (LU20, 99999) '_089', 100 * RATO, 1.0 / RATO
          ENDIF
        ENDIF
        IF (IGBL(94) .EQ. 0) THEN
          IF (PAR(299) .LT. 0.99) THEN
            WRITE (LU20, 99999) '_086', 1.0 - PAR(299),
     1             MAX (0.0, PAR(299))
          ELSE IF (PAR(299) .GT. 1.01) THEN
            WRITE (LU20, 99999) '_087', PAR(299), PAR(299)
          ENDIF
        ENDIF
C * RESIDUAL DENSITY TESTS
        IF (IGBL(94) .EQ. 0) THEN
          IF (PAR(177) .LT. -1000.0) THEN
            WRITE (LU20, 99999) '_095', 1.0, 1.0
          ELSE
            WRITE (LU20, 99999) '_097', 10 * PAR(177) / IPR(22),
     1        PAR(177)
            IF (PAR(176) .NE. 0.0 .AND. PAR(177) .GT. 0.40) THEN
              RMXMI = PAR(177) /  ABS(PAR(176))
              WRITE (LU20, 99999) '_094', RMXMI, RMXMI
            ENDIF
          ENDIF
          IF (PAR(176) .GT. 1000.0) THEN
            WRITE (LU20, 99999) '_096', 1.0, 1.0
          ELSE IF (PAR(176) .LT. -0.1) THEN
            WRITE (LU20, 99999) '_098', - 10 * PAR(176) / IPR(22),
     1                           PAR(176)
          ELSE IF (PAR(176) .GE. 0.0) THEN
            WRITE (LU20, 99999) '_099', 1.0, PAR(176)
          ENDIF
        ENDIF
      ENDIF
   50 RETURN
99999 FORMAT (A, 2F10.2)
99998 FORMAT (A, 2I10, 2A)
99997 FORMAT (A, 2F10.3)
99996 FORMAT (A, 2F10.0, 2A)
      END
      SUBROUTINE PLA240
C **********************************************************************
C *                                                                    *
C * * * * * * * * P R O G R A M    H E L E N A * * * * * * * * * * * * *
C *                                                                    *
C **********************************************************************
C *                                                                    *
C *      PROGRAM FOR THE HANDLING OF CAD4-DIFFRACTOMETER OUTPUT        *
C * AN SHELX(S/L) OR  XTAL-SYSTEM STYLE OF HKL-CARD FILE IS PREPARED   *
C *       ALONG WITH A DOCUMENT ON THE DATA COLLECTION                 *
C *                         A.L. SPEK,                                 *
C *                     UTRECHT UNIVERSITY,                            *
C *          BIJVOET CENTER FOR BIOMOLECULAR RESEARCH,                 *
C *            VAKGROEP KRISTAL- EN STRUCTUURCHEMIE,                   *
C *       PADUALAAN 8, 3584 CH UTRECHT, THE NETHERLANDS.               *
C *                                                                    *
C *--------------------------------------------------------------------*
C **********************************************************************
C **********************************************************************
      PARAMETER (IP1=500, IP2=50, IP3=16, IP4=100, IP5=6, IP6=99,
     1 IP7=25, IP8=25, IP9 = 100)
      PARAMETER (NP4=9,NP10=16,NP12=600,NP13=500,NP17=99,NPVD=40000000,
     1 NP22=256,NP23=18000,NP45=2048,
     2 NP99=NPVD+NP23*2-6*IP1-IP2-2*IP3-39*IP4-9*IP6-IP7-IP8-5*IP9
     3 -(7*IP5+11)*(IP2*IP3)-149,NP38=125,NP39=30)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON // X(IP1), F(IP1), W(IP1), IONR(IP1), WAV(IP1), FAV(IP1),
     1 A(IP5, IP3, IP2), B(IP5, IP3, IP2), C(IP5, IP3, IP2),
     2 D(IP5, IP3, IP2), P(IP5, IP3, IP2), G(IP5, IP3, IP2),
     3 V(IP5, IP3, IP2), FMN(9, IP3, IP2), PC(IP3, IP2), IRFZ(IP3, IP2),
     4 IRFY(IP3), XRF(IP3), XRAYT(IP2), PSIS(36, IP4), IHKLP(3, IP4),
     5 BAK(IP9, 5), ORM(3, 3, IP6), IHPR(IP7), HPAR(IP8), IORREF(25, 4),
     6 ISW(3), NMBR(20), ROR(3, 3), DC(6), R(3, 3), ANPI, ISG, XR(NP99)
      COMMON /PROT/ IRADIUS, SLIT, APMIN, APMAX, ISCANT, NPIPRE,
     1 NFRIDL, ICHKT, SIGMI, FADING, NORCHK, DANG, CON1, CON2, DTHMIN,
     2 DTHMAX, DOMA, DOMB, APTA, APTB, SIGPRE, SIGMA, ITMAX,NBALF,NEQFL,
     3 NRPSI, PSIST, DELPSI, DVECT(3), NFMS, IZZH, IHMIN, IHMAX, IZZK,
     4 KMIN, KMAX, IZZL, LMIN, LMAX, FLAM1, FLAM2, BETA,
     5 IORF, WL21,WL11,CILT, PERF, RLPMN,
     6 RLPMX, XIMX, SIMX, SCFOVFL, CELL(12)
      COMMON /Q/ ICL, IFL(NP17)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0
      COMMON /XCHAR/ COMPID, TEXT, XNPSIFL, DATC, XSEQ, RDMP, ICAD,
     1 HTAOIS
      CHARACTER TEXT*36, COMPID*6, XNPSIFL*6, DATC*6,
     1 NFMS*4, XSEQ*6, RDMP(26)*62, ICAD*4, HTAOIS(25)*6
      COMMON /GGT/ MEDIUM
      COMMON /CGGT/ IGGT
      CHARACTER IGGT*80
      CHARACTER FLNAM*25
      COMMON /NAMES/ NAME(8), EXTENS, PROGNM, FNLU1, FNLU16, RDTYPE
      CHARACTER NAME*80, EXTENS*9, PROGNM*28, FNLU1*80, FNLU16*80,
     1          RDTYPE*7
      COMMON /FNAME/ KNM(8), KXT, KNM16
      CHARACTER VERSION*10
      COMMON /CGG11/ BCD, SBCD
      CHARACTER BCD*132, SBCD*132
      COMMON /PAGENM/ PAGET, PAGEIND(25)
      CHARACTER PAGET*8, PAGEIND*8
      PAGET = 'HELENA'
      CALL GEN038 (JID, 1, 80)
C * NUMBER OF LINES/PAGE (LINE PRINTER)
      IPR(83)   = 0
      IPR(370)  = 0
      IGBL(63)  = 3
      IGBL(49)  = 0
      IGBL(102) = 56
      NAUTO     = 0
      LUNIT     = LU16
      FLNAM = NAME(1)(1:KNM(1))//'.'//EXTENS(1:KXT)
      OPEN (UNIT = LU16, FILE = FLNAM, STATUS = 'UNKNOWN', ERR = 160)
      LUNIT = LU11
      OPEN (UNIT = LU11, STATUS = 'SCRATCH', FORM = 'UNFORMATTED',
     1      ERR = 160)
      LUNIT = LU10
      OPEN (UNIT = LU10, STATUS = 'SCRATCH', FORM = 'UNFORMATTED',
     1 ERR = 160)
      LUNIT = LU9
      OPEN (UNIT = LU9, STATUS = 'SCRATCH', FORM = 'UNFORMATTED',
     1 ERR = 160)
      LUNIT = LU7
      OPEN (UNIT = LU7, FILE = NAME(1)(1:KNM(1))//'.lis',
     1      STATUS = 'UNKNOWN', ERR = 160)
      IGBL(23) = 15
      VERT     = 25.0
      HORS     = VERT * 4.0 / 3.0
      LU15     = LU1
      OPEN (UNIT = LU15, FILE = NAME(1)(1:KNM(1))//'.ins',
     1      STATUS = 'UNKNOWN')
      CALL GEN108 (LU10, 0)
      CALL GEN108 (LU11, 0)
      CALL GEN108 (LU9, 0)
      CALL GEN040 (IGBL(9), VERSION, IP)
      CALL PLA269 (0)
      WRITE (LU7, 99999) VERSION(1:IP)
      CALL GEN097 (IHPR, 1, IP7, 0)
      IHPR(1)  = IP3 - 1
      IHPR(2)  = IP1
      IHPR(3)  = IP2
      IHPR(4)  = IP4
      IHPR(5)  = IP5 - 1
      IPR(446) = 1
      XIMX     = 0
      SIMX     = 0
      SCFOVFL  = 1.0
      IORF     = 0
      PERF     = 0.5
      XNPSIFL  = '******'
      CALL GEN097 (IORREF, 1, 100, 0)
      DO 10 I = 1, 25
        HTAOIS(I) = XNPSIFL
   10 CONTINUE
      CILT = 2.5
      CALL GEN097 (IPR(371), 1, 9, 1)
      CALL GEN097 (ISW, 1, 3, 0)
      CALL GEN074 (CELL, 0.0, 1, 12)
      CALL GEN097 (NMBR, 1, 20, 0)
      CALL GEN097 (IRFY, 1, IP3, 0)
      CALL GEN074 (XRF , 0.0, 1, IP3)
      DO 20 I = 1, 26
        CALL GEN038 (RDMP(I), 1, 62)
   20 CONTINUE
      CALL GEN074 (PSIS, 0.0, 1, IP4 * 36)
      ANPI     = 0.0
      HPAR(1)  = 1.0000
      HPAR(2)  = 1.0000
      HPAR(3)  = 0
      HPAR(4)  = 0
      HPAR(20) = 2
      HPAR(21) = 2
      HPAR(24) = GL(5)
      IPR(424) = 1
      IPR(425) = 0
      IPR(426) = 0
      IPR(428) = 0
      STM      = (SIN (35.0 / HPAR(24)) / 0.71073) ** 3 / IP9
      DO 40 I = 1, IP9
        BAK(I, 1) = (STM * I) ** 0.3333333
        DO 30 J = 2, 5
          BAK(I, J) = 0.0
   30   CONTINUE
   40 CONTINUE
      WRITE (LU6, 99998) VERSION
      GOTO 60
   50 LU15 = LU5
   60 IF (LU15 .EQ. LU5) THEN
        BCD(1:12) = 'H.E.L.E.N.A'//CHAR(0)
        CALL GGIP (HORS, VERT, 0.0, 1)
        LINE = 'H E L E N A'
        CALL GGIP20 (0.0, LINE, 11, 2.2, 4, 15, 5.0, VERT - 3.0)
        CALL GGIP20 (0.0, LINE, 11, 2.2, 2, 15, 4.7, VERT - 3.2)
        LINE =
     1   'Version '//VERSION(1:IP)//' - A.L.Spek, Utrecht University'
        CALL GGIP20 (0.0, LINE, 50, 0.6, 1, 2, 4.0, VERT - 5.0)
        LINE = 'INSTRUCTIONS + SUB-KEYWORDS (# = DEFAULT)'
        CALL GGIP20 (0.0, LINE, 50, 0.6, 5 + IGBL(68), 2, 4.0,
     1               VERT - 7.0)
        LINE = 'CALC            - TO EXECUTE THE CALCULATION'
        CALL GGIP20 (0.0, LINE, 60, 0.5, 1, 2, 4.0, VERT - 8.0)
        LINE = '      - #SHELX  - INPUT FILE FOR SHELX (TYPE=4)'
        CALL GGIP20 (0.0, LINE, 60, 0.5, 1, 2, 4.0, VERT - 9.0)
        LINE = '      -  ABSPSI - ABSOLUTE PSI - VALUES'
        CALL GGIP20 (0.0, LINE, 60, 0.5, 1, 2, 4.0, VERT - 10.0)
        LINE = '      - #LSR    - NORMAL  BACKGROUND PROCEDURE'
        CALL GGIP20 (0.0, LINE, 60, 0.5, 1, 2, 4.0, VERT - 11.0)
        LINE = '      -  MSM    - SPECIAL BACKGROUND PROCEDURE'
        CALL GGIP20 (0.0, LINE, 60, 0.5, 1, 2, 4.0, VERT - 12.0)
        LINE = '      -  MSA    - SPECIAL BKG PROC. (ADD B+ TO ISC)'
        CALL GGIP20 (0.0, LINE, 60, 0.5, 1, 2, 4.0, VERT - 13.0)
        LINE = '      -  SUB    - SKIP REFLECTIONS WITH UNUSUAL BG,BL'
        CALL GGIP20 (0.0, LINE, 60, 0.5, 1, 2, 4.0, VERT - 14.0)
        LINE = '      -  AVE    - AVERAGE BACKGROUND SCALING'
        CALL GGIP20 (0.0, LINE, 60, 0.5, 1, 2, 4.0, VERT - 15.0)
        LINE = 'MONOCHR         - SET MONOCHROMATOR TYPE'
        CALL GGIP20 (0.0, LINE, 60, 0.5, 1, 2, 4.0, VERT - 16.0)
        LINE = '      -  BETA   - BETA-FILTER'
        CALL GGIP20 (0.0, LINE, 60, 0.5, 1, 2, 4.0, VERT - 17.0)
        LINE = '      -  PERP   - MONOCHROMATOR PERPENDICULAR'
        CALL GGIP20 (0.0, LINE, 60, 0.5, 1, 2, 4.0, VERT - 18.0)
        LINE = '      -  PARAL  - MONOCHROTOR PARALLEL'
        CALL GGIP20 (0.0, LINE, 60, 0.5, 1, 2, 4.0, VERT - 19.0)
        LINE = 'SCALE           - SCALING FUNCTION'
        CALL GGIP20 (0.0, LINE, 60, 0.5, 1, 2, 4.0, VERT - 20.0)
        LINE = '      -  DEGREE [ value ]'
        CALL GGIP20 (0.0, LINE, 60, 0.5, 1, 2, 4.0, VERT - 21.0)
        LINE = '      -  NONE    - SCALE = 1.0'
        CALL GGIP20 (0.0, LINE, 60, 0.5, 1, 2, 4.0, VERT - 22.0)
        LINE = 'Data Read From: '//FLNAM
        CALL GGIP20 (0.0, LINE, 60, 0.5, 3, 2, 4.0, VERT - 24.0)
        CALL PLA013 (5, 1)
        IF (LRET .EQ. 2 .OR. IGGT(1:4) .EQ. 'PLOT') THEN
          GOTO 60
        ELSE IF (IGGT(1:1) .EQ. '!') THEN
          CALL PLA280 ('CALC')
        ENDIF
        IF (IGGT(1:1) .NE. ' ') THEN
          ICL = IGGT
          CALL GEN038 (IGGT, 1, 80)
        ELSE
          GOTO 60
        ENDIF
      ELSE
        READ  (LU15, 99989, END = 50) ICL(1:80)
      ENDIF
      CALL GEN072 (ICL, IFL, FN, KL, KN, 0, LU6, 1, 1, 80, 7, NP17)
      IF (IFL(1)(1:3) .EQ. 'SET') THEN
        IF (IFL(2)(1:4) .EQ. 'DISP') THEN
          MEDIUM = 1
        ELSE IF (IFL(2)(1:4) .EQ. 'META') THEN
          MEDIUM = 2
        ENDIF
        IF (KL .GT. 2) THEN
          IGGT(16:22) = IFL(3)(1:7)
          CALL GGIP(-999.0, 0.0, 0.0, 6)
        ENDIF
        GOTO 60
      ENDIF
      IF (IFL(1)(1:3) .EQ. 'MON') THEN
        IF (KL .EQ. 2) THEN
          IF (IFL(2)(1:4) .EQ. 'BETA') THEN
            IPR(424) = 0
          ELSE IF (IFL(2)(1:4) .EQ. 'PERP') THEN
            IPR(424) = 1
          ELSE IF (IFL(2)(1:3) .EQ. 'PAR') THEN
            IPR(424) = 2
          ENDIF
          GOTO 60
        ENDIF
      ENDIF
      IF (IFL(1)(1:4) .EQ. 'CALC') THEN
        K = 0
        IF (KL .GT. 1) THEN
          DO 70 I = 2, KL
            IF (IFL(I)(1:6) .EQ. 'ABSPSI') THEN
              IPR(426) = 1
            ELSE IF (IFL(I)(1:3) .EQ. 'LSR') THEN
              IF (IPR(370) .EQ. 0) IPR(425) =  0
            ELSE IF (IFL(I)(1:3) .EQ. 'MSM') THEN
              IF (IPR(370) .EQ. 0) IPR(425) =  1
            ELSE IF (IFL(I)(1:3) .EQ. 'MSA') THEN
              IF (IPR(370) .EQ. 0) IPR(425) =  2
            ELSE IF (IFL(I)(1:3) .EQ. 'AVE') THEN
              IF (IPR(370) .EQ. 0) IPR(425) =  3
            ELSE IF (IFL(I)(1:3) .EQ. 'SUB') THEN
              IF (IPR(370) .EQ. 0) IPR(425) = -1
            ELSE IF (IFL(I)(1:4) .EQ. 'AUTO') THEN
              NAUTO = 1
              GOTO 130
            ENDIF
   70     CONTINUE
        ENDIF
        IF (LU15 .EQ. LU1 .AND. NAUTO .EQ. 0) GOTO 60
        GOTO 130
      ELSE IF (IFL(1)(1:4) .EQ. 'HELP') THEN
          WRITE (LU6, 99991)
        GOTO 60
      ELSE IF (IFL(1)(1:4) .EQ. 'STOP') THEN
        GOTO 140
      ELSE IF (IFL(1)(1:4) .EQ. 'EXIT') THEN
        GOTO 140
      ELSE IF (IFL(1)(1:4) .EQ. 'QUIT') THEN
        GOTO 140
      ELSE IF (IFL(1)(1:5) .EQ. 'SCALE') THEN
        IF (KL .GT. 1) THEN
          K = 0
          IPR(428) = 0
          DO 80 I = 2, KL
            IF (IFL(I)(1:6) .EQ. 'DEGREE') THEN
              K      = K + 1
              IPR(446) = MIN (IP5 - 1, NINT(FN(K)))
            ELSE IF (IFL(I)(1:4) .EQ. 'NONE') THEN
              IPR(428) = 1
            ENDIF
   80     CONTINUE
        ENDIF
        CALL PLA241
        GOTO 60
      ELSE IF (IFL(1)(1:2) .EQ. 'RR') THEN
        N = NINT(FN(1))
        IPR(370 + N) = MOD(IPR(370 + N) + 1, 2)
        IF (IPR(370 + N) .EQ. 1) THEN
          GOTO 90
        ELSE
          GOTO 100
        ENDIF
      ELSE IF (IFL(1)(1:2) .EQ. 'IN') THEN
        GOTO 90
      ELSE IF (IFL(1)(1:2) .EQ. 'EX') THEN
        GOTO 100
      ELSE IF (IFL(1)(1:3) .EQ. 'END') THEN
        GOTO 140
      ENDIF
      WRITE (LU6, 99997) ICL(1:80)
      GOTO 60
   90 INS = 1
      GOTO 110
  100 INS = -1
  110 IF (IPR(370) .EQ. 0) CALL PLA248
      DO 120 I = 1, KN
         IVAL = NINT(FN(I))
         IF (IVAL .GT. 0 .AND. IVAL .LE. IHPR(9)) THEN
           IRFY(IVAL) = INS * IABS(IRFY(IVAL))
         ENDIF
  120 CONTINUE
      GOTO 60
  130 OPEN (UNIT = LU17, FILE = NAME(2)(1:KNM(2))//'.hkl',
     1    STATUS = 'UNKNOWN', ERR = 160)
      CALL GEN108 (LU17, 0)
      OPEN (UNIT = LU30, FILE = NAME(5)(1:KNM(5))//'.rap',
     1    STATUS = 'UNKNOWN', ERR = 160)
      OPEN (UNIT = LU4, FILE = NAME(2)(1:KNM(2))//'.psi',
     1    STATUS = 'UNKNOWN', ERR = 160)
        WRITE (LU6, 99993)
      IF (ISW(1) .EQ. 0) CALL PLA241
      CALL PLA244 (2)
      CALL PLA247
      CALL PLA244 (3)
  140 WRITE (LU6, 99994) NAME(2)(1:KNM(2)), NAME(2)(1:KNM(2))
      CLOSE (LU17)
      IF (IGBL(70) .EQ. 1) THEN
        WRITE (LU6, 99995) NAME(1)(1:KNM(1)), NAME(1)(1:KNM(1))
        CALL GEN108 (LU7, 1)
        CLOSE  (LU1)
        READ (LU7, 99989, END = 150) PRBUF
        CALL GEN108 (LU7, 0)
        FNLU1  = NAME(1)(1:KNM(1)) //'.lps'
        OPEN (UNIT = LU1,  FILE = FNLU1, STATUS = 'UNKNOWN')
        CALL GEN089 (LU7, LU1, IGBL(49), IGBL(102))
        GOTO 170
  150   CLOSE (LU7, STATUS = 'DELETE')
      ELSE
        WRITE (LU6, 99990) NAME(1)(1:KNM(1))
      ENDIF
      GOTO 170
  160 WRITE (LU6, 99996) LUNIT
  170 IF (IPR(426) .EQ. 0) THEN
        CLOSE (LU30, STATUS = 'DELETE')
      ELSE
        WRITE (LU6, 99992) NAME(5)(1:KNM(5))
      ENDIF
      RETURN
99999 FORMAT ('P R O G R A M   H E L E N A   F O R   T H E   ',
     1 'H A N D L I N G   O F   C A D 4 - O U T P U T : V E R S I',
     2 ' O N = ', A, /, 120('='), //)
99998 FORMAT(/, 'HELENA - Version:', A,
     1 ' - <RETURN> for default run (= CALC SHELX)',/)
99997 FORMAT (':: Instruction Ignored', /, A, /)
99996 FORMAT (':: Cannot Open Unit:', I5)
99995 FORMAT (/, 80('='), /, ':: List Output   on: ', A, '.lis', /,
     1                       ':: EPS  Output   on: ', A, '.lps')
99994 FORMAT (':: SHELX-HKL     on: ', A, '.hkl', /,
     1        ':: SHELX-PSI     on: ', A, '.psi')
99993 FORMAT (/, '>> SHELX(L) - HKLF 4 FILE Will be Produced', /)
99992 FORMAT (':: ABSPSI-HKL    on: ', A, '.rap')
99991 FORMAT ('*EXCLUDE - EXCLUDES SPECIFIED REF.REFL NRS'//)
99990 FORMAT (/, 80('='), /, ':: List Output   on: ', A, '.lis')
99989 FORMAT (A)
      END
      SUBROUTINE PLA241
      PARAMETER (IP1=500, IP2=50, IP3=16, IP4=100, IP5=6, IP6=99,
     1 IP7=25, IP8=25, IP9 = 100)
      PARAMETER (NP12=600,NP13=500,NP17=99,NPVD=40000000,NP23=18000,
     1 NP99=NPVD+NP23*2-6*IP1-IP2-2*IP3-39*IP4-9*IP6-IP7-IP8-5*IP9
     2 -(7*IP5+11)*(IP2*IP3)-149,NP38=125,NP39=30)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON // X(IP1), F(IP1), W(IP1), IONR(IP1), WAV(IP1), FAV(IP1),
     1 A(IP5, IP3, IP2), B(IP5, IP3, IP2), C(IP5, IP3, IP2),
     2 D(IP5, IP3, IP2), P(IP5, IP3, IP2), G(IP5, IP3, IP2),
     3 V(IP5, IP3, IP2), FMN(9, IP3, IP2), PC(IP3, IP2), IRFZ(IP3, IP2),
     4 IRFY(IP3), XRF(IP3), XRAYT(IP2), PSIS(36, IP4), IHKLP(3, IP4),
     5 BAK(IP9, 5), ORM(3, 3, IP6), IHPR(IP7), HPAR(IP8), IORREF(25, 4),
     6 ISW(3), NMBR(20), ROR(3, 3), DC(6), R(3, 3), ANPI, ISG, XR(NP99)
      COMMON /PROT/ IRADIUS, SLIT, APMIN, APMAX, ISCANT, NPIPRE,
     1 NFRIDL, ICHKT, SIGMI, FADING, NORCHK, DANG, CON1, CON2, DTHMIN,
     2 DTHMAX, DOMA, DOMB, APTA, APTB, SIGPRE, SIGMA, ITMAX,NBALF,NEQFL,
     3 NRPSI, PSIST, DELPSI, DVECT(3), NFMS, IZZH, IHMIN, IHMAX, IZZK,
     4 KMIN, KMAX, IZZL, LMIN, LMAX, FLAM1, FLAM2, BETA,
     5 IORF, WL21,WL11,CILT, PERF, RLPMN,
     6 RLPMX, XIMX, SIMX, SCFOVFL, CELL(12)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      CHARACTER NFMS*4
      NST    = 0
      ISW(1) = 1
      IF (IPR(370) .EQ. 0) CALL PLA248
      IF (IPR(428) .EQ. 1) THEN
        WRITE (LU7, 99999)
        GOTO 90
      ENDIF
      CALL GEN074 (FMN, 0.0, 1, IP2 * IP3 * 9)
      IRFX = IHPR(9) + 1
      ISW(2) = 0
      DO 80 ICY = 1, 7, 6
        DO 70 ISGR = 1, ISG
          PC(IRFX, ISGR) = 0.0
          IPC = 0
          IMX = IHPR(2)
          CALL GEN074 (WAV, 1.0, 1, IMX)
          CALL GEN074 (FAV, 0.0, 1, IMX)
          DO 60 IRF = 1, IRFX
            IX = IRFY(IRF)
            IF (IX .EQ. 0) THEN
              IF (ICY .NE. 1) GOTO 60
              NRF = IRFZ(ISW(2), ISGR)
              IRFZ(IRF, ISGR) = NRF
              DO 10 I = 1, NRF
                F(I) = FAV(I)
                W(I) = WAV(I)
   10         CONTINUE
            ELSE IF (IX .GT. 0) THEN
              CHISI = 0.0
              SJKIJ = 0.0
              STIJ  = 0.0
              NST   = 0
              IF (ISW(2) .EQ. 0) ISW(2) = IRF
              CALL GEN108 (LU9, 0)
   20         READ (LU9, END = 30) NIRF, XI, SI, XRT, ISGX, IORGR
              IF (NIRF .EQ. IRF) THEN
                IF (ISGR .LT. ISGX) THEN
                  GOTO 30
                ELSE IF (ISGR .EQ. ISGX) THEN
                  NST = NST + 1
                  IF (NST .GT. IHPR(2)) CALL PLA245 (4)
                  SCF = 1
                  IF (ICY .NE. 1) THEN
                    CALL PLA246 (SCF, IRFX, ISGR, XRT)
                    CHISI = CHISI + (XI - P(1, IRF, 1) / SCF)**2
                    SJKIJ = SJKIJ + XI**2
                    STIJ  = STIJ + SI**2
                    XI    = XI * SCF
                    SI    = SI * SCF
                  ENDIF
                  IF (SI .GT. 0.0) THEN
                    WGHT = 1.0 / (SI**2)
                  ELSE
                    WGHT = 0.0
                  ENDIF
                  X(NST) = XRT
                  F(NST) = XI
                  W(NST) = WGHT
                  IF (IRF .EQ. ISW(2)) IONR(NST) =  IORGR
                  FMN(ICY, IRF, ISGR)     = FMN(ICY, IRF, ISGR) + XI
                  FMN(ICY + 1, IRF, ISGR) = FMN(ICY + 1, IRF, ISGR)
     1                                    + XI**2
                ENDIF
              ENDIF
              GOTO 20
   30         IF (NST .GT. 0) THEN
                IF (ICY .NE. 1) THEN
                  IF (IX .EQ. 0) THEN
                    PC(IRFX, ISGR) = PC(IRFX, ISGR) / IPC
                  ELSE IF (IX .GT. 0) THEN
                    PC(IRF, ISGR)  = (ABS(CHISI - STIJ)) / SJKIJ
                    PC(IRFX, ISGR) = PC(IRFX, ISGR) + PC(IRF, ISGR)
                    IPC = IPC + 1
                  ENDIF
                ENDIF
              ENDIF
              IRFZ(IRF, ISGR) = NST
              IF (NST .EQ. 0) THEN
                GOTO 60
              ELSE IF (NST .EQ. 1) THEN
                P(1, IRF, ISGR) = F(1)
                GOTO 40
              ELSE
                FMNX  = FMN(ICY,     IRF, ISGR) / NST
                FMNXK = FMN(ICY + 1, IRF, ISGR) / NST
                FMN(ICY, IRF, ISGR) = FMNX
                DELTA = ABS(FMNXK - FMNX**2)
                FMN(ICY + 1, IRF, ISGR) = SQRT(DELTA) * 100.0 / FMNX
              ENDIF
            ELSE
              GOTO 60
            ENDIF
            IF (NST .EQ. 0) THEN
              GOTO 60
            ELSE IF (NST .EQ. 1) THEN
              P(1, IRF, ISGR) = F(1)
            ELSE
              CALL GEN070 (IRFZ(IRF, ISGR), X, F, W, IPR(446),
     1         A(1, IRF, ISGR), B(1, IRF, ISGR), C(1, IRF, ISGR),
     2         G(1, IRF, ISGR), V(1, IRF, ISGR))
              CALL GEN069 (IPR(446), A(1, IRF, ISGR), B(1, IRF, ISGR),
     1        C(1, IRF, ISGR), P(1, IRF, ISGR), SIGMA,
     2         D(1, IRF, ISGR), G(1, IRF, ISGR))
            ENDIF
   40       CALL PLA249 (IRF, ISGR)
            IF (IX .GT. 0) THEN
              DO 50 J = 1, NST
                XRT = X(J)
                CALL PLA246 (SCF, IRF, ISGR, XRT)
                FJ   = F(J) * SCF
                WGHT = W(J)
                IF (ICY .EQ. 1) THEN
                  FMN(4, IRF, ISGR) = FMN(4, IRF, ISGR) + FJ
                  FMN(5, IRF, ISGR) = FMN(5, IRF, ISGR) + FJ**2
                  FAV(J)            = FAV(J) + 1.0 / SCF
                ENDIF
   50         CONTINUE
              IF (ICY .EQ. 1) THEN
                FMNX  = FMN(4, IRF, ISGR) / NST
                FMNXK = FMN(5, IRF, ISGR) / NST
                FMN(4, IRF, ISGR) = FMNX
                FMN(5, IRF, ISGR) = SQRT(ABS(FMNXK - FMNX**2))
     1                            * 100.0 / FMNX
              ENDIF
            ENDIF
   60     CONTINUE
   70   CONTINUE
        CALL PLA249 (0, 0)
   80 CONTINUE
   90 RETURN
99999 FORMAT (/, '>>>> SCF = 1.00 <<<< ', /)
      END
      SUBROUTINE PLA242 (CELL, DC, VOL, OR, D, NR, COMPID, LU, RAD)
      DIMENSION OR(3, 3), D(3, 3), GD(3, 3), GR(3, 3), CELL(12),
     1 RC(9), DC(6), SA(9), SAR(9)
      CHARACTER COMPID*6
      IF (NR .LE. 1 .AND. LU .GT. 0) THEN
        CALL PLA269 (0)
        WRITE (LU, 99998) COMPID, NR
      ENDIF
      CALL GEN003 (OR, D, V, 0)
      IF (NR .LT. 1 .AND. LU .GT. 0)
     1  WRITE (LU, 99996) ((OR(I, J), J = 1, 3),
     2                      (D(I, J), J = 1, 3), I = 1, 3)
      DO 20 I = 1, 3
        J = I + 3
        K = MOD(I, 3) + 1
        L = MOD(I + 1, 3) + 1
        RC(I) = 0.0
        RC(J) = 0.0
        DO 10 M = 1, 3
          RC(I) = RC(I) + OR(M, I)**2
          RC(J) = RC(J) + OR(M, K) * OR(M, L)
   10   CONTINUE
   20 CONTINUE
      DO 30 I = 1, 3
        RC(I) = SQRT(RC(I))
   30 CONTINUE
      DO 40 I = 1, 3
        J = I + 3
        K = MOD(I, 3) + 1
        L = MOD(I + 1, 3) + 1
        RC(J) = RC(J) / (RC(K) * RC(L))
   40 CONTINUE
      DO 50 J = 1, 3
        RC(J + 6) = RC(J + 3)
        RC(J + 3) = ACOS(RC(J + 6)) * RAD
   50 CONTINUE
      CALL GEN026 (1, GR, RC, RAD)
      CALL GEN003 (GR, GD, DET, 0)
      CALL GEN026 (-1, GD, DC, RAD)
      VOL = 1 / SQRT(DET)
      IF (NR .LT. 1 .AND. LU .GT. 0) THEN
        WRITE (LU, 99995) ((GR(I, J), J = 1, 3),
     1                      (GD(I, J), J = 1, 3), I = 1, 3)
        WRITE (LU, 99994) GD(1, 1), GD(2, 2), GD(3, 3),
     1                     GD(2, 3), GD(1, 3), GD(1, 2)
      ENDIF
      VSTAR = 1.0 / VOL
      SV    = 0.0
      SVS   = 0.0
      CALL GEN074 (SAR, 0.0, 1, 9)
      CALL GEN074 (SA,  0.0, 1, 9)
      IF (LU .GT. 0) THEN
        IF (NR .LT. 1) WRITE (LU, 99993)
     1    (DC(I), SA(I), RC(I), SAR(I), I = 1, 6), VOL, SV, VSTAR, SVS
        IF (NR .EQ. 0) THEN
          IF (CELL(1) .EQ. 0.0) THEN
            DO 60 I = 1, 6
              CELL(I) = DC(I)
   60       CONTINUE
          ENDIF
          WRITE (LU, 99999) (CELL(I), I = 1, 6),
     1     (CELL(I), I = 7, 12)
        ENDIF
        IF (NR .GT. 0) THEN
          WRITE (LU, 99997) NR, ((OR(I, J), J = 1, 3), I = 1, 3), VOL
        ENDIF
      ENDIF
      CONTINUE
      RETURN
99999 FORMAT (//, 'CELL : ', 3F10.4, 3F10.3/'CESD : ', 3F10.4, 3F10.3)
99998 FORMAT ('L A T T I C E  G E O M E T R Y  D O C U M E N T  O F :'
     1 , 5X, A, /, 65('=')//25X, 'MATRIX NR:', I2, /, 25X, 12('=')//)
99997 FORMAT (I5, 2X, 9F10.6, F10.2)
99996 FORMAT (4X, 'RECIPROCAL AXES MATRIX', 12X,'DIRECT AXES MATRIX'/
     1 , 2(30('-'), 5X)/3(3F10.6, 3X, 3F11.5/))
99995 FORMAT (4X, 'RECIPROCAL METRICAL TENSOR', 9X, 'DIRECT METRICAL',
     1 ' TENSOR', /, 2(30('-'), 5X), /, 3(3F10.6, 3X, 3F11.5/))
99994 FORMAT (21X, 'NIGGLI VALUES ', /, 21X, '-------------'/, 2X,
     1 'A.A = ', F9.4, '  B.B = ', F9.4, ' C.C = ', F9.4/2X, 'B.C = ',
     2 F9.4, '  A.C = ', F9.4, ' A.B = ', F9.4/)
99993 FORMAT (//, 22X, 'CELL PARAMETERS'/, 22X, 15('-')//'A      = ',
     1 F9.4, '(', F6.4, ')', 7X, 'A(STAR)      = ', F8.5, '(',
     2 F7.5, ')', /, 'B      = ', F9.4, '(', F6.4, ')', 7X, 'B(STAR',
     3 ')      = ', F8.5, '(', F7.5, ')'/'C      = ', F9.4, '(',
     4 F6.4, ')', 7X, 'C(STAR)      = ', F8.5, '(', F7.5, ')'/
     5 'ALPHA  = ', F9.2, '(', F6.2, ')', 7X, 'ALPHA(STAR)  = ',
     6 F8.2, '(', F7.2, ')'/'BETA   = ', F9.2, '(', F6.2, ')', 7X,
     7 'BETA(STAR)   = ', F8.2, '(', F7.2, ')'/'GAMMA  = ',
     8 F9.2, '(', F6.2, ')', 7X, 'GAMMA(STAR)  = ', F8.2, '(',
     9 F7.2, ')', /, 'V      = ', F9.1, '(', F6.1, ')', 7X, 'V(STAR',
     * ')      = ', F8.5, '(', F7.5, ')')
      END
      SUBROUTINE PLA243 (ISW, NMBR, IPRT)
      DIMENSION NMBR(20)
      NMBR(ISW) = NMBR(ISW) + 1
      NMBR(ISW + 10) = NMBR(ISW + 10) + 1
      IF (ISW .EQ. 1) THEN
        IPRT = 0
      ELSE IF (ISW .EQ. 2) THEN
        IPRT = IPRT + 2
      ELSE IF (ISW .EQ. 3) THEN
        IPRT = IPRT + 1
      ELSE IF (ISW .EQ. 5) THEN
        IPRT = IPRT + 4
      ELSE IF (ISW .EQ. 6) THEN
        IPRT = IPRT + 8
      ELSE IF (ISW .EQ. 7) THEN
        IPRT = IPRT + 32
      ELSE IF (ISW .EQ. 8) THEN
        IPRT = IPRT + 64
      ELSE IF (ISW .EQ. 10) THEN
        IPRT = IPRT + 16
      ENDIF
      RETURN
      END
      SUBROUTINE PLA244 (MODE)
      PARAMETER (IP1=500, IP2=50, IP3=16, IP4=100, IP5=6, IP6=99,
     1 IP7=25, IP8=25, IP9 = 100)
      PARAMETER (NP12=600,NP13=500,NP17=99,NPVD=40000000,NP23=18000,
     1 NP99=NPVD+NP23*2-6*IP1-IP2-2*IP3-39*IP4-9*IP6-IP7-IP8-5*IP9
     2 -(7*IP5+11)*(IP2*IP3)-149,NP38=125,NP39=30)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON // X(IP1), F(IP1), W(IP1), IONR(IP1), WAV(IP1), FAV(IP1),
     1 A(IP5, IP3, IP2), B(IP5, IP3, IP2), C(IP5, IP3, IP2),
     2 D(IP5, IP3, IP2), P(IP5, IP3, IP2), G(IP5, IP3, IP2),
     3 V(IP5, IP3, IP2), FMN(9, IP3, IP2), PC(IP3, IP2), IRFZ(IP3, IP2),
     4 IRFY(IP3), XRF(IP3), XRAYT(IP2), PSIS(36, IP4), IHKLP(3, IP4),
     5 BAK(IP9, 5), ORM(3, 3, IP6), IHPR(IP7), HPAR(IP8), IORREF(25, 4),
     6 ISW(3), NMBR(20), ROR(3, 3), DC(6), R(3, 3), ANPI, ISG, XR(NP99)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /PROT/ IRADIUS, SLIT, APMIN, APMAX, ISCANT, NPIPRE,
     1 NFRIDL, ICHKT, SIGMI, FADING, NORCHK, DANG, CON1, CON2, DTHMIN,
     2 DTHMAX, DOMA, DOMB, APTA, APTB, SIGPRE, SIGMA, ITMAX,NBALF,NEQFL,
     3 NRPSI, PSIST, DELPSI, DVECT(3), NFMS, IZZH, IHMIN, IHMAX, IZZK,
     4 KMIN, KMAX, IZZL, LMIN, LMAX, FLAM1, FLAM2, BETA,
     5 IORF, WL21,WL11,CILT, PERF, RLPMN,
     6 RLPMX, XIMX, SIMX, SCFOVFL, CELL(12)
      COMMON /XCHAR/ COMPID, TEXT, XNPSIFL, DATC, XSEQ, RDMP, ICAD,
     1 HTAOIS
      CHARACTER TEXT*36, COMPID*6, XNPSIFL*6, DATC*6, XSEQ*6,
     1 NFMS*4, RDMP(26)*62, ICAD*4, HTAOIS(25)*6
      COMMON /TODAY/ DATIJD
      CHARACTER DATIJD*25
      IF (MODE .EQ. 3) THEN
        CALL PLA269 (0)
        WRITE (LU7,  99986) COMPID
        WRITE (LU7, 99985) HPAR(1), HPAR(2), IPR(446)
        WRITE (LU7, 99995) DTHMIN, DTHMAX, RLPMN,
     1                    RLPMX, IHMIN, IHMAX, KMIN, KMAX, LMIN, LMAX
        ANPI = ANPI / NMBR(11)
        WRITE (LU7, 99990) (NMBR(I), RDMP(26), I = 11, 20)
        IF (IHPR(12) .GT. 0) THEN
          WRITE (LU7, 99978) IHPR(12)
        ENDIF
        WRITE (LU7, 99989) ANPI
        SSSI = HPAR(3) / HPAR(4)
        WRITE (LU7, 99977) SSSI
        IF (IPR(425) .EQ. 1) WRITE (LU7,  99973)
        IF (IPR(425) .EQ. 2) WRITE (LU7,  99972)
        CALL PLA169 (-1, IDUM, IDUM, DUM, LU6)
        CALL PLA169 (-2, IDUM, IDUM, DUM, LU6)
        CALL PLA169 (-2, IDUM, IDUM, DUM, LU7)
      ELSE IF (MODE .EQ. 1) THEN
        NR = IHPR(8)
        DO 20 I = 1, 3
          DO 10 J = 1, 3
            R(I, J) = ORM(I, J, NR)
   10     CONTINUE
   20   CONTINUE
        CALL PLA242 (CELL, DC, VOL, R, ROR, NR - 1, COMPID, 0, GL(5))
        CALL PLA269 (0)
        WRITE (LU7, 99994) COMPID, DATC, ISG, DATIJD(5:24)
        WRITE (LU7, 99993) TEXT(31:36), RDMP(1), TEXT(23:25), RDMP(2),
     1    TEXT(8:11), TEXT(27:29), RDMP(3), TEXT(13:16), TEXT(17:21),
     2    RDMP(4)
        WRITE (LU7, 99992) IRADIUS, RDMP(5), SLIT, RDMP(6), APTA, APTB,
     1   RDMP(7), APMIN, APMAX, RDMP(8), DTHMIN, DTHMAX, RDMP(9), DOMA,
     2   DOMB, RDMP(10)
        WRITE (LU7, 99991) ISCANT, RDMP(11), NPIPRE, RDMP(12), SIGPRE,
     1    SIGMA, RDMP(13), ITMAX, RDMP(14), NBALF,NFRIDL,NEQFL, RDMP(15)
        WRITE (LU7, 99981) IHPR(11), RDMP(16)
        WRITE (LU7, 99990) (NMBR(I), RDMP(I + 16), I = 1, 10)
        WRITE (LU7, 99988) IHMIN, IHMAX, NR - 1, KMIN, KMAX, LMIN,
     1    LMAX, XSEQ, PSIST, DELPSI, NRPSI, NFMS, (R(1, I), I = 1, 3),
     2   (ROR(1, I), I = 1, 3), IZZH, IZZK, IZZL, (R(2, I), I = 1, 3),
     3   (ROR(2, I), I = 1, 3), XNPSIFL, (R(3, I), I = 1, 3),
     4   (ROR(3, I), I = 1, 3), (DVECT(I), I = 1, 3), IHPR(9), ICHKT,
     5    SIGMI, FADING, NORCHK, DANG
        ICAD = '    '
        IF (NINT(CON1 *  1000000) .EQ. 586423) THEN
          ICAD = 'CAD0'
          IPR(424) = 0
        ELSE IF (NINT(CON1 * 1000000) .EQ. 586211) THEN
          ICAD = 'CAD1'
          IPR(424) = 0
        ELSE IF (NINT(CON1 * 1000000) .EQ. 587277) THEN
          ICAD = 'CAD2'
          IPR(424) = 2
        ENDIF
        WRITE (LU7, 99987) FLAM1, FLAM2, WL21, PERF, IPR(424), DC(1),
     1    0.0, DC(4), 0.0, BETA, DC(2), 0.0, DC(5), 0.0, ICAD, CON1,
     2    CON2, DC(3), 0.0, DC(6), 0.0, XRAYT(ISG), VOL, 0.0
      ELSE IF (MODE .EQ. 2) THEN
        KOR = IHPR(8)
        DO 50 K = 1, KOR
          DO 40 I = 1, 3
            DO 30 J = 1, 3
              R(I, J) = ORM(I, J, K)
   30       CONTINUE
   40     CONTINUE
          CALL PLA242 (CELL, DC, VOL, R, ROR, K - 1, COMPID, LU7, GL(5))
   50   CONTINUE
        IF (IPR(428) .EQ. 0) THEN
          DO 80 ISGR = 1, ISG
            IF (IRFZ(ISW(2), ISGR) .GT. 1) THEN
              CALL PLA269 (0)
              WRITE (LU7,  99999) COMPID, ISGR
              IRFX = IHPR(9) + 1
              DO 70 IRF = 1, IRFX
                IX = IRFY(IRF)
                IH = 0
                IK = 0
                IL = 0
                IF (IX .LT. 0) THEN
                  GOTO 70
                ELSE IF (IX .GT. 0) THEN
                  IH = IORREF(IX, 1)
                  IK = IORREF(IX, 2)
                  IL = IORREF(IX, 3)
                ENDIF
                IF (IRF .EQ. 4) CALL PLA269 (0)
                WRITE (LU7,  99984) IH, IK, IL
                KK = IPR(446) + 1
                DO 60 I = 1, KK
                  II = I - 1
                  WRITE (LU7, 99983) II, P(I, IRF, ISGR),
     1                               II, D(I, IRF, ISGR)
   60           CONTINUE
                NST = IRFZ(IRF, ISGR)
                WRITE (LU7, 99998) NST
                SQPC = SQRT(PC(IRF, ISGR))
                WRITE (LU7,  99997) (FMN(I, IRF, ISGR), I = 1, 9), SQPC
   70         CONTINUE
            ENDIF
   80     CONTINUE
        ENDIF
      ENDIF
      RETURN
99999 FORMAT ('R E F E R E N C E   A N D   S C A L I N G   D A T A'
     1 , '   FOR: ', A, /, 65('='), //, 25X, 'DATCOL SET:', I3,
     2 /, 25X, 14('=')/)
99998 FORMAT ('FREQUENCY OF THIS REFERENCE REFLECTION', 18('.'), I9)
99997 FORMAT ('MEAN OF UNSCALED REFERENCE REFLECTION', 19('.'),
     1 F9.0, /, 11X, 'R.M.S. DEVIATION (PERCENT)', 19('.'),
     2 F9.2, /, 26X, 'CHI-SQUARED', 19('.'),
     3 F9.2, /, 'MEAN OF 1-SCALED REFERENCE REFLECTION', 19('.'),
     4 F9.0, /, 11X, 'R.M.S. DEVIATION (PERCENT)', 19('.'),
     5 F9.2, /, 26X, 'CHI-SQUARED', 19('.'),
     6 F9.2, /, 'MEAN OF RESCALED REFERENCE REFLECTION', 19('.'),
     7 F9.0, /, 11X, 'R.M.S. DEVIATION (PERCENT)', 19('.'),
     8 F9.2, /, 26X, 'CHI-SQUARED', 19('.'),
     9 F9.2, /, 'INSTABILITY CONSTANT P ', 33('.'), F9.4)
99995 FORMAT ('THETA MIN / THETA MAX (DEG) (ACTUAL VALUES)', 4('.'),
     1 2F9.2,/,'1/LP  MIN / 1/LP  MAX', 26('.'), 2F9.2/'HMIN , HMAX ',
     2 ' (ACTUAL)', 26('.'), 2I9/'KMIN , KMAX  (ACTUAL)', 26('.'),
     3 2I9/'LMIN , LMAX  (ACTUAL)', 26('.'), 2I9)
99994 FORMAT (65('='), /, 'D A T A  C O L L E C T I O N  ',
     1 'D O C U M E N T  F O R :', 5X, A, /, 65('='), /, A,
     2 ' SET:', I3, 7X, 'ANALYSIS DATE: ', A, '   TIME: ', A, 22X,
     3 'R E F D U M P  L I S T', /, 65('-'), 22X, 22('='), /)
99993 FORMAT ('COLLECTION DATE', 43('.'), 1X, A, 4X, A, /,
     1 'DIFFRACTOMETER AND TEMPERATURE', 23('.'), 'CAD4', 5X, A3,
     2 4X, A, /, 'RADIATION AND FILTER', 33('.'), A4, 5X, A3, 4X,
     3 A, /, 'VOLTAGE AND CURRENT', 34('.'), A, 3X, A, 4X, A)
99992 FORMAT ('DETECTOR TO CRYSTAL DISTANCE (MM)', 25('.'), I7, 4X,
     1 A, /, 'VERTICAL APERTURE (MM)', 36('.'), F7.2, 4X, A, /,
     2 'HORIZONTAL APERTURE (MM), A + B TAN( THETA)', 7('.'), F7.2,
     3 ',', F7.2, 4X, A, /, 'HORIZONTAL APERTURE LIMITS (MM)',
     4 19('.'), F7.2, ',', F7.2, 4X, A, /,
     5 'THETA MIN / THETA MAX ( DEG )', 21('.'), F7.2, ',', F7.2,
     6 4X, A, /, 'OMEGA SCAN ANGLE (DEG),   A + B TAN( THETA)',
     7 7('.'), F7.2, ',', F7.2, 4X, A)
99991 FORMAT ('THETA/OMEGA MOVEMENT RATIO', 32('.'), I5, '/6',4X,A/
     1 'PRESCAN SPEED 20/N (DEG/MIN)', 30('.'), I7, 4X, A/,
     2 'PRE- AND FINAL SCAN SIGMA(I)/I RATIO',14('.'),
     3 F7.2,',',F7.2,4X,A/,'FINAL SCAN TIME LIMIT (SEC.)', 30('.'),
     4 I7,4X,A/,
     5 'NBALF,NFRIDL,NEQFL FLAGS',18('.'),I7,',',I7,',',I7,4X,A)
99990 FORMAT (
     1 'TOTAL NUMBER OF MEASURED REFLECTIONS', 22('.'), I7, 4X, A, /
     2 'TOTAL NUMBER OF NORMAL   REFLECTIONS', 22('.'), I7, 4X, A, /
     3 'NUMBER OF MEASURED REFF. REFLECTIONS', 22('.'), I7, 4X, A, /
     4 'NUMBER OF TOO WEAK       REFLECTIONS', 22('.'), I7, 4X, A, /
     5 'NUMBER OF STRONG         REFLECTIONS', 22('.'), I7, 4X, A, /
     6 'NUMBER OF TOO STRONG     REFLECTIONS', 22('.'), I7, 4X, A, /
     7 'NUMBER OF SIGN. DEV.     REFLECTIONS', 22('.'), I7, 4X, A, /
     8 'NUMBER OF FILTER         REFLECTIONS', 22('.'), I7, 4X, A, /
     9 'NUMBER OF IMPOSSIBLE     REFLECTIONS', 22('.'), I7, 4X, A, /
     * 'NUMBER OF NEG. RESCANNED REFLECTIONS', 22('.'), I7, 4X, A)
99989 FORMAT ('AVERAGE SCAN SPEED NPI', 36('.'), F7.1)
99988 FORMAT ('HMIN , HMAX', 39('.'), I7, ',', I7, 20X,
     1 'ORIENTATION MATRIX NR:', I3, /, 'KMIN , KMAX', 39('.'), I7,
     2 ',', I7, 20X, 25('='), /, 'LMIN , LMAX', 39('.'), I7, ',',
     3 I7, /, 'DATA COLLECTION TYPE', 38('.'), 1X, A, 6X,
     4 'RECIPROCAL AXES MATRIX', 10X, 'DIRECT AXES MATRIX', /,
     5 'PSI SCAN PARAMETERS(PSIST,DELPSI,NRPSI)', 3('.'), F7.2, ',',
     6 F7.2, ',', I7, 5X, 2(25('-'), 5X), /,
     7 'HKL INCREMENT ORDER(FAST,MEDIUM,SLOW)', 21('.'), 4X, A4,
     8 3F10.6, 2X, 3F10.5, /, 'STARTING VALUES OF H, K, L',
     9 16('.'), I7, ',', I7, ',', I7, 1X, 3F10.6, 2X, 3F10.5, /,
     * 'DATA COLLECTION METHOD', 36('.'), 1X, A, 1X, 3F10.6, 2X,
     1 3F10.5, /, 'FLAT OR NEEDLE VECTOR(WHEN USED)', 10('.'),
     2 F7.3, ',', F7.3, ',', F7.3, /,
     3 'NUMBER OF REFERENCE REFLECTIONS', 27('.'), I7, /,
     4 'REF. REFLECTION MEASURED EVERY (SEC)', 22('.'), I7, /,
     5 'SIGMA(I)/I RATIO FOR CONTROL REFL.', 24('.'), F7.3, /,
     6 'MAX. DROP IN REF. REFL. INTENSITY', 25('.'), F7.2, /,
     7 'ORIENTATION CONTROL EVERY N REFL.', 25('.'), I7, /,
     8 'MAXIMUM ROTATION OF SCATT. VECTOR', 25('.'), F7.3)
99987 FORMAT ('WAVE LENGTH ALPHA1,ALPHA2 AND MEAN', 8('.'), 2(F7.5,
     1 ','), F7.5, /, 'MONOCHROMATOR PERF ( 0=NO, 1/ 2=YES )',
     2 13('.'), ',', F7.2, I7, 5X, ' A  = ', F8.4, '(', F6.4, ')',
     3 4X, 'ALPHA =', F7.2, '(', F6.2, ')', /, 'FILTER FACTOR',
     4 45('.'), F7.2, 5X, ' B  = ', F8.4, '(', F6.4, ')', 4X,
     5 'BETA  =', F7.2, '(', F6.2, ')', /,
     6 'DIFFR. CONSTANTS CAD, CON1 AND CON2', 7('.'), 2X, A, ' ,',
     7 F7.6, ',', F7.6, 5X, ' C  = ', F8.4, '(', F6.4, ')', 4X,
     8 'GAMMA =', F7.2, '(', F6.2, ')', /,
     9 'TOTAL OF XRAY EXPOSURE TIME (HOUR)', 24('.'), F7.1, 5X,
     * ' V  = ', F8.1, '(', F6.1, ')')
99986 FORMAT ('D A T A   R E D U C T I O N   D O C U M E N T  F O R '
     1 , ':', 5X, A, /, 65('='), //)
99985 FORMAT ('MINIMUM AND MAXIMUM OF APPLIED SCF.', 12('.'), 2F9.3,
     1 /, 'DEGREE OF POLYNOMIAL THROUGH REF.R.', 21('.'), I9)
99984 FORMAT (/, 'POLYNOMIAL COEFFICIENTS FOR REFERENCE REFLECTION',
     1 8('.'), 3I3)
99983 FORMAT ((14X, 'A(', I2, ')= ', F16.5, ',SIG(A(', I2, '))= ',
     1 F15.5))
99981 FORMAT ('NUMBER  OF LAST MEASURED REFLECTION ', 22('.'), I7,
     1 4X, A)
99978 FORMAT ('NUMBER OF SKIPPED <SUB>  REFLECTIONS', 22('.'), I7)
99977 FORMAT ('SUM(SIGMA)/SUM(INTENSITY) RATIO', 27('.'), F7.4)
99973 FORMAT (//, 'MSM-Peak/Background option applied')
99972 FORMAT (//, 'MSA-Peak/Background option applied')
      END
      SUBROUTINE PLA245 (NR)
      PARAMETER (IP1=500, IP2=50, IP3=16, IP4=100, IP5=6, IP6=99,
     1 IP7=25, IP8=25, IP9 = 100)
      PARAMETER (NPVD=40000000,NP23=18000,
     1 NP99=NPVD+NP23*2-6*IP1-IP2-2*IP3-39*IP4-9*IP6-IP7-IP8-5*IP9
     2 -(7*IP5+11)*(IP2*IP3)-149)
      COMMON // X(IP1), F(IP1), W(IP1), IONR(IP1), WAV(IP1), FAV(IP1),
     1 A(IP5, IP3, IP2), B(IP5, IP3, IP2), C(IP5, IP3, IP2),
     2 D(IP5, IP3, IP2), P(IP5, IP3, IP2), G(IP5, IP3, IP2),
     3 V(IP5, IP3, IP2), FMN(9, IP3, IP2), PC(IP3, IP2), IRFZ(IP3, IP2),
     4 IRFY(IP3), XRF(IP3), XRAYT(IP2), PSIS(36, IP4), IHKLP(3, IP4),
     5 BAK(IP9, 5), ORM(3, 3, IP6), IHPR(IP7), HPAR(IP8), IORREF(25, 4),
     6 ISW(3), NMBR(20), ROR(3, 3), DC(6), R(3, 3), ANPI, ISG, XR(NP99)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      IF (NR .LT. 0) THEN
        GOTO 10
      ELSE IF (NR .EQ. 1) THEN
        WRITE (LU6, 99999) IHPR(3)
        WRITE (LU7, 99999) IHPR(3)
      ELSE IF (NR .EQ. 2) THEN
        WRITE (LU6, 99998) IHPR(1)
        WRITE (LU7, 99998) IHPR(1)
      ELSE IF (NR .EQ. 3) THEN
        WRITE (LU6, 99997)
        WRITE (LU7, 99997)
      ELSE IF (NR .EQ. 4) THEN
        WRITE (LU6, 99996) IHPR(2)
        WRITE (LU7, 99996) IHPR(2)
      ELSE IF (NR .EQ. 5) THEN
        WRITE (LU6, 99995)
        WRITE (LU7, 99995)
      ELSE IF (NR .EQ. 6) THEN
        WRITE (LU6, 99994) ISG
        WRITE (LU7, 99994) ISG
      ELSE
        GOTO 10
      ENDIF
      STOP ' '
   10 RETURN
99999 FORMAT (//, ':: STOP, THERE ARE MORE THAN', I4,
     1 ' SCALING GROUPS')
99998 FORMAT (/, ':: EXIT - REASON : MORE THAN', I2,
     1 ' REFERENCE REFLECTIONS')
99997 FORMAT (/, ':: N O  D A T A  O N  F I L E   C A D 4'/)
99996 FORMAT (/, ':: MAXIMUM NUMBER OF REFL./SCGR:',I4,' EXCEEDED')
99995 FORMAT (/, ':: STOP - PROBLEM WITH REFDUMP REFLECTIONS',/)
99994 FORMAT (/, ':: STOP - INCOMPLETE REF. REFL. SET IN GROUP',I5,/)
      END
      SUBROUTINE PLA246 (SCF, IR, ISGR, XRT)
      PARAMETER (IP1=500, IP2=50, IP3=16, IP4=100, IP5=6, IP6=99,
     1 IP7=25, IP8=25, IP9 = 100)
      PARAMETER (NP12=600,NP13=500,NP17=99,NPVD=40000000,NP23=18000,
     1 NP99=NPVD+NP23*2-6*IP1-IP2-2*IP3-39*IP4-9*IP6-IP7-IP8-5*IP9
     2 -(7*IP5+11)*(IP2*IP3)-149,NP38=125,NP39=30)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON // X(IP1), F(IP1), W(IP1), IONR(IP1), WAV(IP1), FAV(IP1),
     1 A(IP5, IP3, IP2), B(IP5, IP3, IP2), C(IP5, IP3, IP2),
     2 D(IP5, IP3, IP2), P(IP5, IP3, IP2), G(IP5, IP3, IP2),
     3 V(IP5, IP3, IP2), FMN(9, IP3, IP2), PC(IP3, IP2), IRFZ(IP3, IP2),
     4 IRFY(IP3), XRF(IP3), XRAYT(IP2), PSIS(36, IP4), IHKLP(3, IP4),
     5 BAK(IP9, 5), ORM(3, 3, IP6), IHPR(IP7), HPAR(IP8), IORREF(25, 4),
     6 ISW(3), NMBR(20), ROR(3, 3), DC(6), R(3, 3), ANPI, ISG, XR(NP99)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
       DATA J0, ISGR0, DER / 0, 0, 0.0/
      SCF = 1.0
      I   = IR
      J   = ISGR
   10 IF (IRFZ(I, J) .EQ. 0) THEN
        J = J - 1
        IF (J .GT. 0) GOTO 10
      ELSE IF (IRFZ(I, J) .EQ. 1) THEN
        SCF = P(1, I, 1) / P(1, I, J)
      ELSE
        SCF = P(1, I, 1) / GEN071 (IPR(446), A(1, I, J), B(1, I, J),
     1        C(1, I, J), XRT, DER)
      ENDIF
      IF (J .LT. ISGR) THEN
        IF (J .NE. J0 .AND. ISGR .NE. ISGR0) THEN
          WRITE (LU7, 99999) J, ISGR
          J0 = J
          ISGR0 = ISGR
        ENDIF
      ENDIF
      RETURN
99999 FORMAT (':: Note: SCALING GROUP', I3,' Used for SCALING GROUP',
     1   I3)
      END
      SUBROUTINE PLA247
      PARAMETER (IP1=500, IP2=50, IP3=16, IP4=100, IP5=6, IP6=99,
     1 IP7=25, IP8=25, IP9 = 100)
      PARAMETER (NP12=600,NP13=500,NP17=99,NPVD=40000000,NP23=18000,
     1 NP99=NPVD+NP23*2-6*IP1-IP2-2*IP3-39*IP4-9*IP6-IP7-IP8-5*IP9
     2 -(7*IP5+11)*(IP2*IP3)-149,NP38=125,NP39=30)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON // X(IP1), F(IP1), W(IP1), IONR(IP1), WAV(IP1), FAV(IP1),
     1 A(IP5, IP3, IP2), B(IP5, IP3, IP2), C(IP5, IP3, IP2),
     2 D(IP5, IP3, IP2), P(IP5, IP3, IP2), G(IP5, IP3, IP2),
     3 V(IP5, IP3, IP2), FMN(9, IP3, IP2), PC(IP3, IP2), IRFZ(IP3, IP2),
     4 IRFY(IP3), XRF(IP3), XRAYT(IP2), PSIS(36, IP4), IHKLP(3, IP4),
     5 BAK(IP9, 5), ORM(3, 3, IP6), IHPR(IP7), HPAR(IP8), IORREF(25, 4),
     6 ISW(3), NMBR(20), ROR(3, 3), DC(6), R(3, 3), ANPI, ISG, XR(NP99)
      COMMON /PROT/ IRADIUS, SLIT, APMIN, APMAX, ISCANT, NPIPRE,
     1 NFRIDL, ICHKT, SIGMI, FADING, NORCHK, DANG, CON1, CON2, DTHMIN,
     2 DTHMAX, DOMA, DOMB, APTA, APTB, SIGPRE, SIGMA, ITMAX,NBALF,NEQFL,
     3 NRPSI, PSIST, DELPSI, DVECT(3), NFMS, IZZH, IHMIN, IHMAX, IZZK,
     4 KMIN, KMAX, IZZL, LMIN, LMAX, FLAM1, FLAM2, BETA,
     5 IORF, WL21,WL11,CILT, PERF, RLPMN,
     6 RLPMX, XIMX, SIMX, SCFOVFL, CELL(12)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0
      COMMON /XCHAR/ COMPID, TEXT, XNPSIFL, DATC, XSEQ, RDMP, ICAD,
     1 HTAOIS
      CHARACTER TEXT*36, COMPID*6, XNPSIFL*6, DATC*6, XSEQ*6,
     1 RDMP(26)*62, ICAD*4, HTAOIS(25)*6
      CHARACTER NFMS*4, LINE*80, CODE*6, C1*1, C2*1, NQ1*7
      DIMENSION DX(3), TX(3), RFL(3), SFL(3)
      COMMON /CGGT/ IGGT
      CHARACTER IGGT*80
      XLP    = 0.0
      IRIMIN = - 10000
      IF (IPR(425) .EQ. 3) THEN
        DO 10 I = 1, IP9
          ABAK = BAK(I, 1) * WL21
          IF (ABAK .LT. 1.0) THEN
            ABAK = ASIN(ABAK) * HPAR(24)
          ELSE
            ABAK = 0.0
          ENDIF
          BAK(I, 1) = ABAK
   10   CONTINUE
        CALL GEN108 (LU10, 0)
   20   READ (LU10, END = 50) NREFL, IH, IK, IL, CODE, PSI, NPI,
     1      IBGL, ISC, IBGR, THETA, PHIK, OMK, RKAPPA, WIDTH, IXRYT,
     2      IFRIDL, ILT, ISGR, XI, SI, IPRT, IORM, IBTST, FSCF
        IF (IH .NE. 0 .OR. IK .NE. 0 .OR. IL .NE. 0) THEN
          SCF = 1.0
          IF (IPR(428) .NE. 1) THEN
            XRT = IXRYT / 3600.0
            CALL PLA246 (SCF, IHPR(9) + 1, ISGR, XRT)
          ENDIF
          DO 30 J = 2, IP9, 2
            IF (THETA .LT. BAK(J, 1)) GOTO 40
   30     CONTINUE
   40     XBGL = IBGL * SCF * FSCF / NPI
          XBGR = IBGR * SCF * FSCF / NPI
          BGMIN = MIN (XBGL, XBGR)
          BGMAX = MAX (XBGL, XBGR)
          IF (BGMAX .LT. 3.0 * BGMIN) THEN
            BAK(J, 4) = BAK(J, 4) + 1.0
            BAK(J, 5) = BAK(J, 5) + BGMIN
          ENDIF
          GOTO 20
        ENDIF
   50   DO 60 I = 2, IP9, 2
          IF (NINT(BAK(I, 4)) .GT. 0) THEN
            BAK(I,     5) = 4.0 * BAK(I, 5) / BAK(I, 4)
            BAK(I - 1, 5) = BAK(I, 5)
          ENDIF
   60   CONTINUE
        DO 70 I = 2, IP9 - 2, 2
          IF (NINT(BAK(I, 4)) .GT. 0.0 .AND.
     1        NINT(BAK(I + 2, 4)) .GT. 0.0) THEN
            BAK(I, 5) = (BAK(I - 1, 5) + BAK(I + 1, 5)) / 2.0
          ENDIF
   70   CONTINUE
        DO 80 I = 1, IP9
          IF (BAK(I, 5) .GT. 0.0) THEN
            WRITE (LU6, '(I5, 3F10.2)')
     1     I, BAK(I, 1), BAK(I, 4), BAK(I, 5)
          ENDIF
   80   CONTINUE
      ENDIF
      CALL PLA169 (0, IDUM, IDUM, DUM, LU6)
      DTHMAX = 0.0
      DTHMIN = 90.0
      RLPMX  = 0.0
      RLPMN  = 10.0
      XMONCU = 26.6 / HPAR(24)
      XMONMO = 12.2 / HPAR(24)
      IPNR   = 0
      TMON   = XMONMO
      NN     = 1
      IF (WL21 .GT. 1.0) TMON = XMONCU
      CTTM   = COS(TMON)
      CKWTTM = CTTM**2
      SCFOVFL = 10.0
   90 SCFOVFL = SCFOVFL * 0.1
      IF (SCFOVFL * SIMX .GT. 10000.0) GOTO 90
      IF (SCFOVFL * XIMX .GT. 1.0E8) GOTO 90
      IHMAX  = -999
      IHMIN  =  999
      KMAX   = -999
      KMIN   =  999
      LMAX   = -999
      LMIN   =  999
      MORMO  =  0
      SINAL  = SQRT(CON1)
      COSAL  = CON2
      CALL GEN108 (LU10, 0)
      LX  = LU11
      CALL GEN108 (LX, 0)
      ILN = IGBL(102)
  100 READ (LX, END = 140) NREFL, IH, IK, IL, CODE, PSI, NPI, IBGL,
     1 ISC, IBGR, THETA, PHIK, OMK, RKAPPA, WIDTH, IXRYT, IFRIDL,
     2 ILT, ISGR, XI, SI, IPRT, IORM, IBTST, FSCF
      IF (IH .EQ. 0 .AND. IK .EQ. 0 .AND. IL .EQ. 0) GOTO 130
      IF ((IH .EQ. IK) .AND. (IK .EQ. IL)) THEN
        RFL(1) = REAL(IH)
        RFL(2) = REAL(-IH)
        RFL(3) = 0.0
      ELSE
        RFL(1) = REAL(IK - IL)
        RFL(2) = REAL(IL - IH)
        RFL(3) = REAL(IH - IK)
      ENDIF
      DO 120 I = 1, 3
        SFL(I) = 0.0
        DO 110 J = 1, 3
          SFL(I) = SFL(I) + RFL(J) * ROR(J, I)
  110   CONTINUE
  120 CONTINUE
      SINQ = SIN(PHIK / HPAR(24))
      COSQ = COS(PHIK / HPAR(24))
      RFL(1) =   SFL(1) * COSQ + SFL(2) * SINQ
      RFL(2) = - SFL(1) * SINQ + SFL(2) * COSQ
      RFL(3) =   SFL(3)
      SFL(1) =   RFL(1) * COSAL - RFL(3) * SINAL
      SFL(2) =   RFL(2)
      SFL(3) =   RFL(1) * SINAL + RFL(3) * COSAL
      SINQ   = SIN(RKAPPA / HPAR(24))
      COSQ   = COS(RKAPPA / HPAR(24))
      RFL(1) =   SFL(1) * COSQ + SFL(2) * SINQ
      RFL(2) = - SFL(1) * SINQ + SFL(2) * COSQ
      RFL(3) =   SFL(3)
      SFL(1) =   RFL(1) * COSAL + RFL(3) * SINAL
      SFL(2) =   RFL(2)
      SFL(3) = - RFL(1) * SINAL + RFL(3) * COSAL
      SINQ = SIN((OMK - THETA) / HPAR(24))
      COSQ = COS((OMK - THETA) / HPAR(24))
      RFL(1) =   SFL(1) * COSQ + SFL(2) * SINQ
      RFL(2) = - SFL(1) * SINQ + SFL(2) * COSQ
      RFL(3) =   SFL(3)
      IF (THETA .LT. 0.0) THEN
        RFL(2) = - RFL(2)
        RFL(3) = - RFL(3)
      ENDIF
      PSICRY = HPAR(24) * ATAN2(RFL(1), RFL(3))
      GOTO 230
  130 WRITE (LU7, 99999)
      GOTO 100
  140 IF (LX .EQ. LU10) GOTO 300
      LX   = LU10
      CALL GEN108 (LX, 0)
      IF (IPNR  .GT. 0) THEN
        DO 220 J = 1, IPNR
  150     IF (LU15 .EQ. 1) THEN
            CALL GGIP (-999.0, 0.0, 0.0, -2)
          ELSE
            CALL GGIP (-999.0, 0.0, 0.0, 3)
          ENDIF
          CALL GGIP (25.0, 25.0, 0.0, 1)
          CALL GGIP (0.0,   0.0, 0.0, 3)
          CALL GGIP (0.0,  25.0, 0.0, 2)
          CALL GGIP (25.0, 25.0, 0.0, 2)
          CALL GGIP (25.0,  0.0, 0.0, 2)
          CALL GGIP (0.0,   0.0, 0.0, 2)
          CALL GGIP20 (0.0, COMPID, 6, 0.7, 1, 2, 0.3, 24.0)
          CALL GGIP (12.5, 12.5, 0.0, -3)
          CALL GGIP20 (0.0, 'Psi-Scan', 8,  0.6, 1, 2, -12.0, -12.2)
          CALL GGIP20 (0.0, '0',        1, 0.25, 1, 2,  12.0,  -0.1)
          CALL GGIP20 (0.0, '90',       2, 0.25, 1, 2,  -0.2, -12.0)
          CALL GGIP20 (0.0, '180',      3, 0.25, 1, 2, -12.4,  -0.1)
          CALL GGIP20 (0.0, '270',      3, 0.25, 1, 2,  -0.2,  11.6)
          TEMP  = 0.0
          TEMP1 = 1.0E10
          DO 160 I = 1, 36
            IF (PSIS(I, J) .GE. 0.01) THEN
              TEMP  = MAX (TEMP,  PSIS(I, J))
              TEMP1 = MIN (TEMP1, PSIS(I, J))
            ENDIF
  160     CONTINUE
          IPERC = NINT(TEMP1 * 100.0 / TEMP)
          DO 200 K = 1, 2
            CALL GGIP(0.0, FLOAT(K), 0.0, 0)
            DO 190 I = 1, 36
              PSI = (I - 1) * 10.0 / HPAR(24)
              XPL =  COS(PSI)
              YPL = -SIN(PSI)
              XP  = 6.5
              YP  = 6.5
              DS  = 0.1 * (K - 1)
              IF (K .NE. 1) THEN
                PSS = PSIS(I, J) / TEMP
                IF (PSS .LT. 0.0) PSS = 0.0
                XP = PSS * XP
                YP = PSS * YP
              ENDIF
              XPL = XPL * (XP + 5.0)
              YPL = YPL * (YP + 5.0)
              IF (K .NE. 1) THEN
                IF (I .LT. 2) THEN
                  XP0 = XPL
                  YP0 = YPL
                ELSE
                  CALL GGIP (XPL, YPL, 0.0, 2)
                ENDIF
              ENDIF
              YPL = YPL - DS
              CALL GGIP (XPL, YPL, 0.0, 3)
              IF (K .LT. 2) THEN
                XPL = XPL * (5.0 / 11.5)
                YPL = YPL * (5.0 / 11.5)
                CALL GGIP (XPL, YPL, 0.0, 2)
              ELSE
                DO 180 L = 1, 3, 2
                  DY = DS * (2 - L)
                  DO 170 M = 1, 3, 2
                    DDX  = DS * (2 - M) * (2 - L)
                    XPL = XPL + DDX
                    YPL = YPL + DY
                    CALL GGIP (XPL, YPL, 0.0, 2)
  170             CONTINUE
  180           CONTINUE
                YPL = YPL + DS
                CALL GGIP (XPL, YPL, 0.0, 3)
              ENDIF
  190       CONTINUE
            IF (K .NE. 1) THEN
              CALL GGIP (XP0, YP0, 0.0, 2)
              CALL GGIP (0.0, 0.0, 0.0, 3)
            ENDIF
  200     CONTINUE
          DO 210 JJ = 1, 3
            XPL = 5 + JJ * 2
            CALL GEN040 (IHKLP(JJ, J), NQ1, IPX)
            CALL GGIP20 (0.0, NQ1, IPX, 0.5, 1, 2, XPL, -12.2)
  210     CONTINUE
          IPX = 0
          CALL GEN040 (IPERC, NQ1, IPX)
          CALL GGIP20 (0.0, NQ1, IPX, 0.5, -1, 2, 11.0, 11.5)
          CALL GGIP (0.0, 0.0, 0.0, 3)
          CALL GGIP (0.0, 0.0, 0.0, -1)
          CALL PLA013 (4, 1)
          IF (LRET .EQ. 2 .OR. IGGT(1:4) .EQ. 'PLOT') THEN
            GOTO 150
          ELSE IF (IGGT(1:1) .EQ. '!') THEN
            CALL PLA280 ('NEXT')
          ENDIF
          IF (IGGT(1:4) .EQ. 'EXIT') GOTO 100
          CALL GEN038 (IGGT, 1, 80)
  220   CONTINUE
      ENDIF
      GOTO 100
  230 IF (MORMO .NE. IORM) MORMO = IORM
      SCF  = 1.0
      ANPI = ANPI + IABS(NPI)
      IF (LX .NE. LU11) THEN
        IF (CODE(1:1) .NE. 'I') THEN
          IHMAX = MAX (IHMAX, IH)
          KMAX  = MAX (KMAX,  IK)
          LMAX  = MAX (LMAX,  IL)
          IHMIN = MIN (IHMIN, IH)
          KMIN  = MIN (KMIN,  IK)
          LMIN  = MIN (LMIN,  IL)
        ENDIF
        IF (IPR(428) .NE. 1) THEN
          XRT = IXRYT / 3600.0
          CALL PLA246 (SCF, IHPR(9) + 1, ISGR, XRT)
          HPAR(2) = MAX (HPAR(2), SCF)
          HPAR(1) = MIN (HPAR(1), SCF)
        ENDIF
      ENDIF
      IF (IPR(425) .EQ. 3) THEN
        IF (MAX(IBGL, IBGR) .GT. 3.0 * MIN (IBGL, IBGR)) THEN
          DO 240 II = 1, IP9
            IF (THETA .LT. BAK(II, 1)) GOTO 250
  240     CONTINUE
  250     SCFX = FSCF / FLOAT(IABS(NPI))
          BACK = BAK(II, 5) / (SCF * SCFX)
          XI = (ISC - BACK)     * 100.0 * SCFX
          SI = SQRT(FLOAT(ISC)) * 100.0 * SCFX
        ENDIF
      ENDIF
      XI = XI * SCF
      SI = SI * SCF
      PSI = PSI / HPAR(24)
      XXX = IH * ORM(1, 1, IORM) + IK * ORM(1, 2, IORM)
     1                           + IL * ORM(1, 3, IORM)
      YYY = IH * ORM(2, 1, IORM) + IK * ORM(2, 2, IORM)
     1                           + IL * ORM(2, 3, IORM)
      ZZZ = IH * ORM(3, 1, IORM) + IK * ORM(3, 2, IORM)
     1                           + IL * ORM(3, 3, IORM)
      HXY  = XXX**2   + YYY**2
      RRR  = SQRT(HXY + ZZZ**2)
      HXY  = SQRT(HXY)
      STH  = 0.5 * WL11 * RRR
      TH   = ASIN(STH)
      TTH  = 2 * TH
      IF (HXY .LT. 1.0E-7) THEN
        CHI = 90.0 / HPAR(24)
        PHI = 0.0
      ELSE
        PHI = ATAN2(-XXX, YYY)
        CHI = ATAN2( ZZZ, HXY)
      ENDIF
      OM   = TH
      CPHI = COS(PHI)
      SPHI = SIN(PHI)
      CCHI = COS(CHI)
      SCHI = SIN(CHI)
      CTT  = COS(TTH)
      STT  = SIN(TTH)
      SCTT = CTT**2
      COM  = COS(OM)
      SOM  = SIN(OM)
      IF (IPR(424) .EQ. 0) THEN
        XLP =  (1 + SCTT) / 2.0
      ELSE IF (IPR(424) .EQ. 1) THEN
        XLP = PERF * (CKWTTM + SCTT) / (1.0 + CKWTTM)
     1      + (1.0 - PERF) * (CTTM + SCTT) / (1.0 + CTTM)
      ELSE IF (IPR(424) .EQ. 2) THEN
        XLP = PERF * (1 + CKWTTM * SCTT) / (1 + CKWTTM)
     1      + (1.0 - PERF) * (1.0 + CTTM * SCTT) / (1.0 + CTTM)
      ENDIF
      RLP = STT / XLP
      DTHMAX = MAX (DTHMAX, ABS(THETA))
      DTHMIN = MIN (DTHMIN, ABS(THETA))
      RLPMX  = MAX (RLPMX, RLP)
      RLPMN  = MIN (RLPMN, RLP)
      SQSCHI = SCHI**2
      SQCHI  = SQRT(SQSCHI)
      IF (SQCHI .GT. 0.0) THEN
        SSS = SCHI / SQCHI
      ELSE
        SSS = 1
      ENDIF
      IF (ABS(PSI) .GT. 0.0) THEN
        CPSI   = COS(PSI)
        SPSI   = SIN(PSI)
        ACCHI  = CPSI * CCHI
        SQACHI = ACCHI**2
        ASCHI  = SSS * SQRT(ABS(1 - SQACHI))
        ACHI   = ATAN2(ASCHI, ACCHI)
        SETA   = CCHI * SPSI / ASCHI
        CETA   = SCHI / ASCHI
        ETA    = ATAN2(SETA, CETA)
        AOM    = ETA + TH
        SDD    = -SPSI / ASCHI
        CDD    = CPSI * SCHI / ASCHI
        DD     = ATAN2(SDD, CDD)
        APHI   = DD + PHI
        ACPHI  = COS(APHI)
        ASPHI  = SIN(APHI)
        ACOM   = COS(AOM)
        ASOM   = SIN(AOM)
      ELSE
        ACCHI = CCHI
        ASCHI = SCHI
        ACPHI = CPHI
        ASPHI = SPHI
        ACOM  = COM
        ASOM  = SOM
        ACHI  = CHI
        APHI  = PHI
        AOM   = OM
      ENDIF
      DO 260 I = 1, 3
        DEN = SQRT(ORM(1, I, IORM)**2 + ORM(2, I, IORM)**2
     1                                + ORM(3, I, IORM)**2)
        X1    = ORM(1, I, IORM) / DEN
        Y1    = ORM(2, I, IORM) / DEN
        Z1    = ORM(3, I, IORM) / DEN
        X2    =   X1 * ACPHI + Y1 * ASPHI
        Y2    = - X1 * ASPHI + Y1 * ACPHI
        Y3    =   Y2 * ACCHI + Z1 * ASCHI
        TX(I) =   X2 * ACOM  + Y3 * ASOM
        Y4    = - X2 * ASOM  + Y3 * ACOM
        DX(I) = - TX(I) * CTT + Y4 * STT
  260 CONTINUE
      ACHI = ACHI * HPAR(24)
      APHI = APHI * HPAR(24)
      AOM  = AOM  * HPAR(24)
      PSI  = PSI  * HPAR(24)
      TH   = TH   * HPAR(24)
      XRLP = RLP
      HPAR(3) = HPAR(3) + SI
      HPAR(4) = HPAR(4) + XI
      IRI     = MAX (IRIMIN, NINT(XI * XRLP * SCFOVFL))
      IRISIG = MAX (1, NINT(SI * XRLP * SCFOVFL))
      ILT    = 1
      IF (IRI .LT. CILT * IRISIG) ILT = 2
      C1 = CODE(1:1)
      C2 = CODE(2:2)
      IC = 0
      IF (C1 .EQ. 'N') IC = 2
      IF (C1 .EQ. 'I') IC = 1
      IF (LX .NE. LU10 .AND. IC .NE. 1) THEN
        IF (IPNR .EQ. 0) GOTO 270
        IF (IH .EQ. IHKLP(1, IPNR) .AND. IK .EQ. IHKLP(2, IPNR) .AND.
     1      IL .EQ. IHKLP(3, IPNR)) GOTO 280
  270   IF (IPNR .LT. IP4) THEN
          IPNR = IPNR + 1
        ELSE
          GOTO 290
        ENDIF
        IHKLP(1, IPNR) = IH
        IHKLP(2, IPNR) = IK
        IHKLP(3, IPNR) = IL
  280   IPSI0 = NINT(PSI)
        IF (IPSI0 .LT. 0) IPSI0 = IPSI0 + 360
        IPSI1 = IPSI0 / 10 + 1
        PSIS(IPSI1, IPNR) = IRI
        IPSI0 = MOD(NINT(PSI + 180.0), 360)
        IF (IPSI0 .LT. 0) IPSI0 = IPSI0 + 360
        IPSI2 = IPSI0 / 10 + 1
        IRI0 = NINT(PSIS(IPSI2, IPNR))
        IF (IRI0 .GT. 0) GOTO 290
        PSIS(IPSI2, IPNR) = - IRI
      ENDIF
  290 IF (LX .NE. LU11) THEN
        STHL = SIN(THETA * 0.01745329) / WL21
        CALL PLA169 (1, IRI, IRISIG, STHL, LU6)
      ENDIF
      IF (IAND(IPRT, 8189) .NE. 0) THEN
        XIOSI = FLOAT(IRI) / FLOAT(IRISIG)
        IORM0 = IORM - 1
        IIBGL = MIN (99999,  IBGL)
        IISC  = MIN (9999999, ISC)
        IIBGR = MIN (99999,  IBGR)
        IF (IBTST .LT. 0) ILT = 0
        IFRIDL = IABS(IFRIDL)
        IF (IPR(320) .GT. 0) THEN
          ILN = ILN + 1
          IF (ILN .GT. IGBL(102)) THEN
            CALL PLA269 (0)
            ILN = 6
            WRITE (LU7, 99993)
          ENDIF
          WRITE (LU7, 99992) IH, IK, IL, CODE, IFRIDL, ILT, ISGR,
     1   IORM0, SCF, 1.0  , RLP, NPI, IIBGL, IISC, IIBGR, THETA, PHIK,
     2      RKAPPA, OMK, WIDTH, IXRYT, IRI, IRISIG, XIOSI, PSI, NREFL
        ENDIF
      ENDIF
      IF (C1 .EQ. 'I' .OR. C2 .EQ. 'X' .OR. C2 .EQ. 'C'
     1        .OR. IBTST .LT. 0) GOTO 100
      IIRISIG = MIN (99999, IRISIG)
      IF (LX .EQ. LU11) THEN
        WRITE (LU4, 99994) IH, IK, IL, IRI, IIRISIG, NN,
     1       (TX(I), DX(I), I = 1, 3)
      ELSE
        WRITE (LU17, 99994) IH, IK, IL, IRI, IIRISIG, NN,
     1       (TX(I), DX(I), I = 1, 3)
        IF (IPR(426) .EQ. 1)
     1   WRITE (LU30, 99998) IH, IK, IL, IRI, IIRISIG, PSICRY
      ENDIF
      GOTO 100
  300 WRITE (LU17, 99991)
      IF (IPR(426) .EQ. 1) WRITE (LU30, 99991)
      CALL GEN108 (LU4, 1)
  310 READ (LU4, 99997, END = 320) LINE
      WRITE (LU17, 99997) LINE
      GOTO 310
  320 WRITE (LU17, 99991)
      RETURN
99999 FORMAT (25('*'), ' REFLECTION H=0,K=0,L=0 DELETED ', 25('*'))
99998 FORMAT (3I4, 2I8, F9.3)
99997 FORMAT (A)
99994 FORMAT (3I4, 2I8, I4, 6F8.5)
99993 FORMAT ('  H  K  L  CODE FL S O  SCF  1/T 1/LP NPI  BL    ISC',
     1 3X, 'BR THETA   PHIK  KAPPA    OMK WIDTH XRAYT  I(NET) SIG(I) '
     2 , 'I/S(I)    PSI NREFL'/)
99992 FORMAT (3I3, 1X, A, 2I1, 2I2, 3F5.2, I3, I5, I7, I5, F6.2,
     1 3F7.2, F5.2, I7, I9, I6, F7.1, F7.2, I6)
99991 FORMAT (1X)
      END
      SUBROUTINE PLA248
      PARAMETER (IP1=500, IP2=50, IP3=16, IP4=100, IP5=6, IP6=99,
     1 IP7=25, IP8=25, IP9 = 100)
      PARAMETER (NP4=9,NP10=16,NP12=600,NP13=500,NP17=99,NPVD=40000000,
     1 NP22=256,NP23=18000,NP38=125,NP39=30,
     1 NP99=NPVD+NP23*2-6*IP1-IP2-2*IP3-39*IP4-9*IP6-IP7-IP8-5*IP9
     2 -(7*IP5+11)*(IP2*IP3)-149)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON // X(IP1), F(IP1), W(IP1), IONR(IP1), WAV(IP1), FAV(IP1),
     1 A(IP5, IP3, IP2), B(IP5, IP3, IP2), C(IP5, IP3, IP2),
     2 D(IP5, IP3, IP2), P(IP5, IP3, IP2), G(IP5, IP3, IP2),
     3 V(IP5, IP3, IP2), FMN(9, IP3, IP2), PC(IP3, IP2), IRFZ(IP3, IP2),
     4 IRFY(IP3), XRF(IP3), XRAYT(IP2), PSIS(36, IP4), IHKLP(3, IP4),
     5 BAK(IP9, 5), ORM(3, 3, IP6), IHPR(IP7), HPAR(IP8), IORREF(25, 4),
     6 ISW(3), NMBR(20), ROR(3, 3), DC(6), R(3, 3), ANPI, ISG, XR(NP99)
      COMMON /PROT/ IRADIUS, SLIT, APMIN, APMAX, ISCANT, NPIPRE,
     1 NFRIDL, ICHKT, SIGMI, FADING, NORCHK, DANG, CON1, CON2, DTHMIN,
     2 DTHMAX, DOMA, DOMB, APTA, APTB, SIGPRE, SIGMA, ITMAX,NBALF,NEQFL,
     3 NRPSI, PSIST, DELPSI, DVECT(3), NFMS, IZZH, IHMIN, IHMAX, IZZK,
     4 KMIN, KMAX, IZZL, LMIN, LMAX, FLAM1, FLAM2, BETA,
     5 IORF, WL21,WL11,CILT, PERF, RLPMN,
     6 RLPMX, XIMX, SIMX, SCFOVFL, CELL(12)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /XCHAR/ COMPID, TEXT, XNPSIFL, DATC, XSEQ, RDMP, ICAD,
     1 HTAOIS
      CHARACTER TEXT*36, COMPID*6, XNPSIFL*6, DATC*6, XSEQ*6,
     1 NFMS*4, RDMP(26)*62, ICAD*4, HTAOIS(25)*6
      CHARACTER FORMC*11, CARD*77, CODE*6, C1*1, C2*1, C4*1
      IPR(370) = 1
      IHPR(9)  = 0
      IDCDOC   = 0
      ISG      = 0
      IXRYT0   = 0
      XIMAX    = 1.0
      XIMIN    = 1.0
      NREFL    = 0
      ICNT     = 0
      IRF      = 0
      IRFX     = 0
      LX       = 0
      IRFD     = 0
      CALL GEN108 (LU16, 0)
   10 READ  (LU16, 99985, END = 130, ERR = 10) ICDTYP
      IF (ICDTYP .EQ. 0) THEN
        GOTO 10
      ELSE IF (ICDTYP .EQ. 21) THEN
        FORMC = '(1X, I2, A)'
      ELSE
        FORMC = '(2X, I2, A)'
      ENDIF
      CALL GEN108 (LU16, 0)
      NCARD = 0
   20 READ (LU16, FORMC, END = 130, ERR = 20) KEY, CARD
      NCARD = NCARD + 1
C * TYPE 0 RECORD:LISTNR,RH,RK,RL,HTAOIS,RTHETA,RPHIK,ROMK,RKAPPA,
C * IRNPI,RSCANG,RSCINT
      IF (KEY .EQ. 0) THEN
        IF (IRFD .EQ. 0) GOTO 20
        READ (CARD, 99998, ERR = 140) LNR
        IF (LNR .GT. 0 .AND. LNR .LE. 25) THEN
          RDMP(LNR) = CARD(1:59)
          READ (CARD, 99997, ERR = 140) (IORREF(LNR, I), I = 1, 3),
     1          HTAOIS(LNR)
          IORR4  = IORREF(LNR, 1) * 40000 + IORREF(LNR, 2) * 200 +
     1             IORREF(LNR, 3)
          IORR40 = IORREF(LNR, 4)
          IF (IORR40 .NE. 0) THEN
            IF (IORR40 .EQ. IORR4) GOTO 20
            CALL PLA245 (5)
          ENDIF
          IORREF(LNR, 4) = IORR4
          IORF = IORF + 1
          IF (HTAOIS(LNR)(5:5) .EQ. 'I') THEN
            IHPR(9) = IHPR(9) + 1
            IF (IHPR(9) .GT. IHPR(1)) CALL PLA245 (2)
            IRFY(IHPR(9)) = LNR
          ENDIF
        ENDIF
C * TYPE 1 RECORD:NREFL, H, K, L, CODE, PSI, NPI, BGL, INT, BGR
      ELSE IF (KEY .EQ. 1) THEN
        READ (CARD, 99988, ERR = 140) NREFLN, IH, IK, IL, CODE, PSI,
     1        NPI, IBGL, ISC, IBGR
        IF (NREFLN .NE. NREFL + 1) THEN
          WRITE (LU7, 99983) NREFLN
          WRITE (LU6, 99983) NREFLN
        ENDIF
C * TYPE 2 RECORD:NREFL,THETA,PHIK,OMK,KAPPA,WIDTH,XRAYT,FRIDL
      ELSE IF (KEY .EQ. 2) THEN
        READ (CARD, 99996, ERR = 140) NREFLC, THETA, PHIK, OMK,
     1                     RKAPPA, WIDTH, IXRYT, IFRIDL
        IF (NREFLC .NE. NREFLN) THEN
          WRITE (LU7, 99984) NREFLC
          WRITE (LU6, 99984) NREFLC
        ELSE
          NREFL = NREFLN
          IF (ISW(3) .GE. 0) THEN
            IXRYTB = IXRYT
            IF (MOD(NMBR(3), IHPR(1)) .NE. 0) CALL PLA245 (6)
            IF (ISW(3) .NE. 2) THEN
              IF (NREFL .EQ. 1) IXRYTB = 0
            ELSE
              IXRYTB = IXRYT
            ENDIF
            IXRYT0 = - IXRYTB
            IF (ISG .GT. 1) IXRYT0 = IXRYT0 + NINT(XRAYT(ISG - 1)
     1                             * 3600.0)
            ISW(3) = - IABS(ISW(3))
          ENDIF
          IXRAYT     = IXRYT + IXRYT0
          XRT        = IXRAYT / 3600.0
          XRAYT(ISG) = XRT
          C1         = CODE(1:1)
          C2         = CODE(2:2)
          C4         = CODE(4:4)
          IHPR(11)   = NREFL
          CALL PLA243 (1, NMBR, IPRT)
          IF (C1 .EQ. 'N') CALL PLA243 (2, NMBR, IPRT)
          IF (C1 .EQ. '?') CALL PLA243 (2, NMBR, IPRT)
          IF (C1 .EQ. '!') CALL PLA243 (2, NMBR, IPRT)
          IF (C1 .EQ. 'I') CALL PLA243 (3, NMBR, IPRT)
          IF (C4 .EQ. 'W') CALL PLA243 (4, NMBR, IPRT)
          IF (C4 .EQ. 'S') CALL PLA243 (5, NMBR, IPRT)
          IF (C4 .EQ. 'T') CALL PLA243 (6, NMBR, IPRT)
          IF (C2 .EQ. 'X' .OR. C2 .EQ. 'C') CALL PLA243 (9, NMBR, IPRT)
          IF (LX .EQ. LU11) IPRT = IPRT + 512
          IF (C1 .EQ. '?')  IPRT = IPRT + 1024
          IF (C1 .EQ. '!')  IPRT = IPRT + 2048
          ILT  = 1
          FSCF = 1.0
          IF (NPI .LT. 0) THEN
            FSCF = BETA
            CALL PLA243 (8, NMBR, IPRT)
          ENDIF
          IF (THETA .LT. 5) IPRT = IPRT + 256
          XI = 0
          SI = 0
          IF (NPI .NE. 0) THEN
            RAT   = 2.0
            SCF   = FSCF * 100.0
            MINB  = MIN (IBGL, IBGR)
            MAXB  = MAX (IBGL, IBGR)
            IBTST = 0
            IF (MAXB .GT. 3.0 * MINB .OR. MAXB .GT. ISC) IBTST = 1
            IF (IBTST .EQ. 1) IPRT = IPRT + 4096
            IF (IPR(425) .EQ. 0) THEN
              GOTO 40
            ELSE IF (IPR(425) .GT. 0) THEN
              GOTO 30
            ENDIF
            IBTST = - IBTST
   30       IF (IBTST .NE. 0) THEN
              BACK = MINB
              IF (IPR(425) .EQ. 1) THEN
                RAT = 4.0
              ELSE
                RAT = 5.0
                ISC = ISC + MAXB
              ENDIF
              GOTO 50
            ENDIF
   40       BACK = IBGL + IBGR
   50       XI = (ISC - RAT * BACK) * SCF / FLOAT(IABS(NPI))
            SI = (SQRT(FLOAT(ISC) + (RAT**2) * BACK)) * SCF /
     1            FLOAT(IABS(NPI))
          ENDIF
          IF (IPR(425) .LT. 0) IHPR(12) = IHPR(12) + IABS(IBTST)
          IF (XI + 2.5 * SI .LT. 0) IPRT = IPRT + 128
          IF (XI .GT. XIMX) XIMX = XI
          IF (SI .GT. SIMX) SIMX = SI
          IF (C2 .EQ. 'D' .AND. XI .GT. 5.0 * SI)
     1        CALL PLA243 (7, NMBR, IPRT)
          IF (IABS(NPI) .GT. NPIPRE .AND. WIDTH .LT. 0.0)
     1      CALL PLA243 (10, NMBR, IPRT)
          WRITE (LX) NREFL, IH, IK, IL, CODE, PSI, NPI, IBGL, ISC,
     1      IBGR, THETA, PHIK, OMK,RKAPPA, WIDTH, IXRAYT, IFRIDL,
     2      ILT, ISG, XI, SI, IPRT, IHPR(8), IBTST, FSCF
          IF (C1 .EQ. 'I') THEN
            IHKL = IH * 40000 + IK * 200 + IL
            IRFX = IHPR(9)
            DO 60 I = 1, IRFX
              IRF = MOD(IRF, IRFX) + I
              IX  = IRFY(IRF)
              IF (IX .LE. 0) GOTO 20
              IF (IORREF(IX, 4) .EQ. IHKL) GOTO 70
   60       CONTINUE
            GOTO 20
   70       ICNT = MOD(ICNT, IRFX) + 1
            IF (ICNT .NE. IRF) THEN
              WRITE (LU9) ICNT, XRF(IRF), 0.0, XRT, ISG, IHPR(8)
              WRITE (LU6, 99980) NREFL, ICNT
              GOTO 70
            ELSE
              WRITE (LU9) IRF, XI, SI, XRT, ISG, IHPR(8)
   80         XRFIRF = XRF(IRF)
              IF (XRFIRF .LE. 0.0) THEN
                XRF(IRF) = XI
                GOTO 80
              ENDIF
              XIS   = XI / XRFIRF
              XIMAX = MAX (XIS, XIMAX)
              XIMIN = MIN (XIS, XIMIN)
            ENDIF
          ENDIF
        ENDIF
C * TYPE 21 RECORD: NREFL,TEXT,IRADIUS,SLIT,APMIN,APMAX
      ELSE IF (KEY .EQ. 21) THEN
        IF (ISG .GT. 0) THEN
          IF (NMBR(2) .EQ. 0) WRITE (LU6, 99982) ISG
        ENDIF
   90   IF (IRFX .GT. 0) THEN
          ICNT = MOD(ICNT, IRFX) + 1
          IF (ICNT .NE. 1) THEN
            WRITE (LU9) ICNT, XRF(ICNT), 0.0, XRT, ISG, IHPR(8)
            WRITE (LU6, 99980) NREFL, ICNT
            GOTO 90
          ENDIF
          IRF  = 0
          ICNT = 0
        ENDIF
        IF (IDCDOC .NE. 0) THEN
          CALL PLA244 (IDCDOC)
          IDCDOC = 1
        ENDIF
        READ (CARD, 99986, ERR = 140) COMPID
        JID = COMPID
        IF (IDCDOC .EQ. 0) CALL PLA244 (IDCDOC)
        IDCDOC = 1
        READ (CARD, 99995, ERR = 140) NR, TEXT, IRADIUS, SLIT,
     1    APMIN, APMAX
        ISG = ISG + 1
        IF (ISG .GT. IHPR(3)) CALL PLA245 (1)
        IF (NR .LE. 1) THEN
          ISW(3) = 1
          DATC   = 'DATCOL'
        ELSE
          ISW(3) = 2
          DATC   = 'DATCON'
        ENDIF
        CALL GEN097 (NMBR, 1, 10, 0)
        IF (TEXT(27:29) .EQ. 'ZR ') IPR(424) = 0
C * TYPE 22 RECORD: DTHMIN,DTHMAX,DOMA,DOMB,APTA,APTB,ISCANT,SIGPRE,
C *                 SIGMA,NPIPRE,ITMAX,IDUMPF,NBALF,NFRIDL
      ELSE IF (KEY .EQ. 22) THEN
        READ (CARD, 99994, ERR = 140) DTHMIN, DTHMAX, DOMA, DOMB,
     1    APTA, APTB, ISCANT, SIGPRE, SIGMA, NPIPRE, ITMAX, NBALF,
     2    NBALF, NFRIDL
C * TYPE 23 RECORD: NPSIFL,NRPSI,PSIST,DELPSI,DVECT(1),DVECT(2),DVECT(3)
      ELSE IF (KEY .EQ. 23) THEN
        READ (CARD, 99993, ERR = 140) NEQFL, XNPSIFL, NRPSI, PSIST,
     1        DELPSI, (DVECT(I), I = 1, 3)
        IF (XNPSIFL .EQ. 'AZIMUT' .AND. NRPSI .GE. 36) THEN
          LX = LU11
        ELSE
          LX = LU10
        ENDIF
C * TYPE 24 RECORD: XSEQ,NFMS,ZZH,HMIN,HMAX,ZZK,KMIN,KMAX,ZZL,LMIN,LMAX
      ELSE IF (KEY .EQ. 24) THEN
        READ (CARD, 99992, ERR = 140) XSEQ, NFMS, IZZH, IHMIN,
     1        IHMAX, IZZK, KMIN, KMAX, IZZL, LMIN, LMAX
        IHPR(16) = MAX (IHPR(16), IHMAX, - IHMIN)
        IHPR(17) = MAX (IHPR(17), KMAX,  - KMIN)
        IHPR(18) = MAX (IHPR(18), LMAX,  - LMIN)
C * TYPE 26 RECORD: ICHKT,SIGMI,FADING,NORCHK,DANG,CON1,CON2,XRAYT
      ELSE IF (KEY .EQ. 26) THEN
        IRFD = 1
        READ (CARD, 99990, ERR = 140) ICHKT, SIGMI, FADING, NORCHK,
     1                                 DANG, CON1, CON2, IXRAYT
C * TYPE 31 RECORD: R(1,1),R(1,2),R(1,3),R(2,1)...............R(2,3)
      ELSE IF (KEY .EQ. 31) THEN
        IRFD = 0
        READ (CARD, 99989, ERR = 140) R(1, 1), R(1, 2), R(1, 3),
     1                                 R(2, 1), R(2, 2), R(2, 3)
C * TYPE 32 RECORD:   R(3,1),R(3,2),R(3,3),FLAM1,FLAM2,BETA/FF
      ELSE IF (KEY .EQ. 32) THEN
        READ (CARD, 99989, ERR = 140) R(3, 1), R(3, 2), R(3, 3),
     1                                 FLAM1, FLAM2, BETA
        DIF  = 0.0
        IPRM = IHPR(8)
        IF (IPRM .LT. IP6) THEN
          IPR8 = IPRM + 1
          DO 110 I = 1, 3
            DO 100 J = 1, 3
              ORM(I, J, IPR8) = R(I, J)
              IF (IPR8 .GT. 1) THEN
                DIF = DIF + ABS(ABS(ORM(I, J, IPRM)) - ABS(R(I, J)))
              ENDIF
  100       CONTINUE
  110     CONTINUE
          IF (IPR8 .NE. 1) THEN
            IF (DIF .LT. 0.000005) GOTO 120
          ENDIF
          IHPR(8) = IPR8
          CONTINUE
        ELSE
          WRITE (LU7, 99981)
          WRITE (LU6, 99981)
        ENDIF
  120   WL21 = (2.0 * FLAM1 + FLAM2) / 3.0
        WL11 = (FLAM1 + FLAM2) / 2.0
        IF (BETA .LT. 0.1) BETA = 16.00
C * TYPE 33 RECORD: A, B, C, SIG(A), SIG(B), SIG(C)
      ELSE IF (KEY .EQ. 33) THEN
        READ (CARD, 99989, ERR = 140) (CELL(I), I = 1, 3),
     1                                 (CELL(I), I = 7, 9)
C * TYPE 34 RECORD: ALFA, BETA, GAMMA, SIG(ALFA), SIG(BETA), SIG(GAMMA)
      ELSE IF (KEY .EQ. 34) THEN
        READ (CARD, 99989, ERR = 140) (CELL(I), I = 4, 6),
     1                                 (CELL(I), I = 10, 12)
      ENDIF
      GOTO 20
  130 IF (IRFX .GT. 0) THEN
        ICNT = MOD(ICNT, IRFX) + 1
        IF (ICNT .NE. 1) THEN
          WRITE (LU9) ICNT, XRF(ICNT), 0.0, XRT, ISG, IHPR(8)
          WRITE (LU6, 99980) NREFL, ICNT
          GOTO 130
        ENDIF
      ENDIF
      IHPR(6) = NINT(MAX(XIMAX - 1.0, 1.0 - XIMIN) * 100) * 2 + 10
      IF (NMBR(2)  .EQ. 0) WRITE (LU6, 99982) ISG
      IF (NMBR(12) .EQ. 0) CALL PLA245 (3)
      IF (IHPR(9)  .EQ. 0) IPR(428) = 1
      CALL PLA244 (IDCDOC)
      CALL GEN097 (IPR(IHPR(9) + 371), 1, 9 - IHPR(9), 0)
      RETURN
  140 WRITE (LU6, 99999) NCARD
      WRITE (LU6, FORMC) KEY, CARD
      STOP
99999 FORMAT (/, 'Fatal Error in CAD4-data : Offending Line =', I6, /)
99998 FORMAT (I2)
99997 FORMAT (2X, 3I3, A)
99996 FORMAT (I6, F8.3, 3F9.3, F7.3, I7, I3)
99995 FORMAT (I6, A, I4, F4.1, F4.1, F4.1)
99994 FORMAT (2F6.2, 4F5.2, I2, 2F6.3, I2, I4, 3I2)
99993 FORMAT (I2, 1X, A, I5, F7.2, F7.2, 3(F10.6))
99992 FORMAT (1X, A, 2X, A, I5, 9I5)
99990 FORMAT (I7, F7.3, F6.3, I5, F6.3, F10.7, F10.7, I7)
99989 FORMAT (2(2X, 3F9.6))
99988 FORMAT (I6, 3I5, 1X, A, F7.0, I4, I6, I7, I6)
99986 FORMAT (6X, A)
99985 FORMAT (I3)
99984 FORMAT (':: DATA FOR REFLECTION ',I5,' INCOMPLETE AND SKIPPED'/)
99983 FORMAT (':: WARNING: DISCONTINUITY AT REFLECTION NR:',I6,/)
99982 FORMAT (':: DATA SET NR.', I3, ' DOES NOT CONTAIN NORMAL',
     1  ' REFLECTIONS'/)
99981 FORMAT (19X, 'REORIENTATION MATRIX SKIPPED')
99980 FORMAT ('Reference reflection missing at reflection',
     1         I6,/,'Zero weight reflection substituted for r.r.',I3)
      END
      SUBROUTINE PLA249 (IRF, ISGR)
      PARAMETER (IP1=500, IP2=50, IP3=16, IP4=100, IP5=6, IP6=99,
     1 IP7=25, IP8=25, IP9 = 100)
      PARAMETER (NP12=600,NP13=500,NP17=99,NPVD=40000000,NP23=18000,
     1 NP99=NPVD+NP23*2-6*IP1-IP2-2*IP3-39*IP4-9*IP6-IP7-IP8-5*IP9
     2 -(7*IP5+11)*(IP2*IP3)-149,NP38=125,NP39=30)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON // X(IP1), F(IP1), W(IP1), IONR(IP1), WAV(IP1), FAV(IP1),
     1 A(IP5, IP3, IP2), B(IP5, IP3, IP2), C(IP5, IP3, IP2),
     2 D(IP5, IP3, IP2), P(IP5, IP3, IP2), G(IP5, IP3, IP2),
     3 V(IP5, IP3, IP2), FMN(9, IP3, IP2), PC(IP3, IP2), IRFZ(IP3, IP2),
     4 IRFY(IP3), XRF(IP3), XRAYT(IP2), PSIS(36, IP4), IHKLP(3, IP4),
     5 BAK(IP9, 5), ORM(3, 3, IP6), IHPR(IP7), HPAR(IP8), IORREF(25, 4),
     6 ISW(3), NMBR(20), ROR(3, 3), DC(6), R(3, 3), ANPI, ISG, XR(NP99)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /SAVPL/ XPL, YPL, SCFX, IXRT, VS
      COMMON /XCHAR/ COMPID, TEXT, XNPSIFL, DATC, XSEQ, RDMP, ICAD,
     1 HTAOIS
      CHARACTER TEXT*36, COMPID*6, XNPSIFL*6, DATC*6, XSEQ*6,
     1 RDMP(26)*62, ICAD*4, HTAOIS(25)*6
      CHARACTER NQ*7, PLTXT1*46, PLTXT2*36, PLTXT3*7, PLTXT4*20
      COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0
      COMMON /TODAY/ DATIJD
      CHARACTER DATIJD*25
      COMMON /CGGT/ IGGT
      CHARACTER IGGT*80
      COMMON /CGG11/ BCD, SBCD
      CHARACTER BCD*132, SBCD*132
      NSGR = 0
      HORS = 33.3333
      VERT = 25.0
      CALL GEN040 (ISG, NQ, IPX)
   10 PLTXT1 = 'HELENA....'//TEXT
      PLTXT2 = DATIJD(5:24)//' ,SET NR :'//NQ(1:6)
      PLTXT3 = 'PERCENT'
      PLTXT4 = 'HOURS XRAY EXP. TIME'
      IF (IRF .LT. ISW(2)) THEN
        CALL GGIP (0.0, 0.0, 0.0, -1)
        CALL PLA013 (4, 1)
        IF (LRET .EQ. 2 .OR. IGGT(1:4) .EQ. 'PLOT') THEN
          GOTO 10
        ELSE IF (IGGT(1:1) .EQ. '!') THEN
          CALL PLA280 ('NEXT')
        ENDIF
        CALL GEN038 (IGGT, 1, 80)
        GOTO 100
      ELSE IF (IRF .GT. ISW(2)) THEN
        GOTO 60
      ENDIF
      IF (ISGR .LE. 1) THEN
        SCFX = HORS / XRAYT(ISG)
        IXRT = IFIX(XRAYT(ISG))
        IF (LU15 .EQ. 1) THEN
          CALL GGIP (-999.0, 0.0, 0.0, -2)
        ELSE
          CALL GGIP (-999.0, 0.0, 0.0, 3)
        ENDIF
        CALL GGIP (HORS, VERT, 0.0, 1)
        CALL GGIP (0.0, 0.0, 0.0, 3)
        CALL GGIP (0.0, 1.0, 0.0, 0)
        II = 0
        XX = 0.0
   20   II = II + 1
        IF (II .GT. IXRT) GOTO 30
        XX = XX + SCFX
        YY = 0.5
        IF (MOD(II, 10) .EQ. 0) YY = 1.0
        CALL GGIP (XX, 0.0, 0.0, 2)
        CALL GGIP (XX,  YY, 0.0, 2)
        CALL GGIP (XX, 0.0, 0.0, 2)
        GOTO 20
   30   CALL GGIP (HORS, 0.0, 0.0, 2)
        YY = 0.0
        IV = IHPR(6)
        VS = VERT / IV
        DO 40 I = 1, IV
          XX = HORS - 0.2
          IF (MOD(I - IV / 2, 10) .EQ. 0) XX = HORS - 0.6
          YY = YY + VS
          CALL GGIP (HORS, YY, 0.0, 2)
          CALL GGIP (XX,   YY, 0.0, 2)
          CALL GGIP (HORS, YY, 0.0, 2)
   40   CONTINUE
        CALL GGIP (0.0, VERT, 0.0, 2)
        YY = VERT
        DO 50 I = 1, IV
          XX = 0.3
          IF (MOD(I - IV / 2, 10) .EQ. 0) XX = 0.60
          YY = YY - VS
          CALL GGIP (0.0, YY, 0.0, 2)
          CALL GGIP (XX,  YY, 0.0, 2)
          CALL GGIP (0.0, YY, 0.0, 2)
   50   CONTINUE
        CALL GGIP (0.0, 0.0, 0.0, 2)
        XX = 1.0
        YY = VERT - 1.0
        CALL GGIP20 (0.0, PLTXT1, 46, 0.5, -1, 2, XX, YY)
        XX = 1.0
        YY = 1.3
        CALL GGIP20 (0.0, PLTXT2, 36, 0.5, -1, 2, XX, YY)
        XX = 1.4
        YY = VERT - 5.0
        CALL GGIP20 (90.0, PLTXT3, 7, 0.5, -1, 2, XX, YY)
        XX = HORS - 11.0
        YY = 1.3
        CALL GGIP20 (0.0, PLTXT4, 20, 0.5, -1, 2, XX, YY)
        WRITE (BCD, '(''Scale Degree ='', I3)') IPR(446)
        CALL GGIP20 (0.0, BCD, 17, 0.5, 1, 2, 7.5, VERT - 3.0)
      ENDIF
      CALL GGIP (0.0, 0.0, 0.0, 3)
   60 CALL GGIP (0.0, FLOAT(IRF), 0.0, 0)
      IF (ISGR .LE. 1) THEN
        XPL = 2.3
        YPL = VERT - 1.5 - IRF * 0.7
        CALL GGIP20 (0.0, CHAR(ICHAR('A') - 1 + IRF), 2, 0.3,
     1              -1, 0, XPL, YPL)
        IRFX = IRFY(IRF)
        DO 70 I = 1, 3
          XPL  = 2.3 + 1.0 * I
          IPX  = 0
          NUMB = 0
          IF (IRFX .GT. 0) NUMB = IORREF(IRFX, I)
          CALL GEN040 (NUMB, NQ, IPX)
          CALL GGIP20 (0.0, NQ, 3, 0.3, -1, 2, XPL, YPL)
   70   CONTINUE
      ENDIF
      IF (IRF .EQ. ISW(2)) NSGR = MOD(ISGR, 10)
      NST = IRFZ(IRF, ISGR)
      DO 80 I = 1, NST
        XX = X(I) * SCFX
        YY = (F(I) / P(1, IRF, 1) - 1.0) * VS * 100.0 + VERT / 2.0
        CALL GGIP20 (0.0, CHAR(ICHAR('A') - 1 + IRF), 1, 0.3,
     1              -1, 0, XX, YY)
        IF (IRF .EQ. ISW(2)) THEN
          CALL GGIP20 (0.0, CHAR(ICHAR('0') + NSGR), 1, 0.3, -1, 0, XX,
     1                2.8)
          NOGR = MOD(IONR(I) - 1, 10)
          CALL GGIP20 (0.0, CHAR(ICHAR('0') + NOGR), 1, 0.3, -1, 0, XX,
     1                2.3)
        ENDIF
   80 CONTINUE
      DO 90 I = 1, NST
        IPN = 2
        IF (I .EQ. 1) IPN = 3
        XRT = X(I)
        CALL PLA246 (SCF, IRF, ISGR, XRT)
        XX = X(I) * SCFX
        YY = (1.0 / SCF - 1.0) * VS * 100.0 + VERT / 2.0
        CALL GGIP (XX, YY, 0.0, IPN)
   90 CONTINUE
      CALL GGIP (0.0, 0.0, 0.0, 3)
  100 RETURN
      END
      SUBROUTINE PLA250
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16,
     1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NPVD=40000000,
     2 NP22=256,NP23=18000,NP25=99,NP29=63,NP38=125,NP39=30,NP41=200,
     3 NP45=2048,NP47=9)
      PARAMETER (NCT0 = 5000, NCT1 = 500000, NTC4 = 200, NCT5 = 2000,
     1 NCT6 = 100, NCT7 = NCT6 + 1, NCT8 = 2500, NCT3 =  NPVD + 2 * NP23
     2 -7 - 8 * NCT8 -2 * NCT5 - 6 * NCT0 - NCT1 - 3 * NTC4 * NTC4
     3 - NCT6 * (NCT6 + 13))
      COMMON // ATOM(4, NCT0), IFLG(NCT0), JFLG(NCT0),
     1 COEFF(NCT1), XMPC(NCT8, 6), IMPC(NCT8),  JMPC(NCT8), Q8(2, NCT5),
     2 FMP(NTC4, NTC4), IEXX(2, NTC4, NTC4), SMA(NCT6, NCT7),
     3 P8(12, NCT6), SK(NCT3), DXF(3), DYF(3), NAT
      COMMON /ISCR/ FC(3, 5), XFO(3), ULC(3)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0
      COMMON /Q/ ICL, IFL(NP17)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /CTR/ NA, ICENT, IKM, ILM, IHM
      COMMON /APLOT/ X, Y, SCALE, PXS, PYS, STEP, VLAK(4)
      COMMON /AINPUT/ NS, NE, MX, MY, NXP, NXM, NYP, NYM, PHI,
     1  XN(3, 4), FMAT(3, 3), CMAT(3, 3), XMCT(4, 500)
      DIMENSION IOFF(4), MH(24), MK(24), ML(24)
      COMMON /NAMES/ NAME(8), EXTENS, PROGNM, FNLU1, FNLU16, RDTYPE
      CHARACTER NAME*80, EXTENS*9, PROGNM*28, FNLU1*80, FNLU16*80,
     1          RDTYPE*7
      COMMON /FNAME/ KNM(8), KXT, KNM16
      CHARACTER PLPATH*255
      INTEGER FINDEXE
      EXTERNAL SYSTEM
      COMMON /CGG11/ BCD, SBCD
      CHARACTER BCD*132, SBCD*132
      COMMON /CGGT/ IGGT
      CHARACTER IGGT*80
      DIMENSION V0(3)
      COMMON /TEXT/ TXT
      CHARACTER TXT(8)*62
      DATA 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 /
      PLPATH    = ' '
      NRSECT    = 0
      NSECTIONS = 0
      I0        = 0
      LRT1      = 1
      CALL PLA252 (1, LRT1)
      IF (IPR(30) .EQ. 0) THEN
        IF (IPR(37) .EQ. 0) THEN
          IPR(2) = 42
          GOTO 600
        ENDIF
        IGBL(52) = MAX (IGBL(52), IPR(23))
        CALL PLA287 (0, 1, 0)
      ENDIF
      IPR(210) = - 4
      IF (IPR(498) .GT. 0) THEN
        IPR(2) = 45
        GOTO 600
      ENDIF
C * CONTOUR
      IGBL(23) = 22
      CALL PLA269 (0)
   10 IF (IPR(415) .GE. 0) THEN
        IF (IPR(416) .NE. 4) THEN
          IPR(211) = 1
          IPR(415) = 1
          IPR(346) = 1
          IF (IPR(414) .NE. 5) THEN
            CALL PLA106
          ELSE
            CALL GGIP (HORS, VERT, 0.0, 1)
          ENDIF
        ENDIF
      ENDIF
      CALL GEN021 (FMAT, 0)
      CALL GEN003 (OR, ROR, DET, 0)
      CALL GEN074 (VLAK, 0.0, 1, 4)
      IF (IPR(420) .GT. 0) THEN
        IB = 4
      ELSE
        IB = 1
      ENDIF
      IF (IPR(420) .LE. 1) THEN
        FMAT(1, 1) = 1.0
        FMAT(2, 3) = 1.0
        VLAK(3)    = 1.0
      ELSE IF (IPR(420) .EQ. 2) THEN
        FMAT(1, 1) = 1.0
        FMAT(3, 3) = 1.0
        VLAK(2)    = 1.0
      ELSE
        FMAT(2, 1) = 1.0
        FMAT(3, 3) = 1.0
        VLAK(1)    = 1.0
      ENDIF
      IPR416 = IPR(416)
      IPR414 = IPR(414)
   20 DO 50 I = IB, 4
   30   IF (IPR(416) .EQ. 0) THEN
          IF (I .LT. 4) THEN
            I0   = I
            NTXT = I
          ELSE
            GOTO 50
          ENDIF
        ELSE IF (IPR(416) .EQ. 1) THEN
          IF (I .EQ. 1) THEN
            NTXT = 7
          ELSE IF (I .EQ. 2) THEN
            I0   = 1
            NTXT = 1
          ELSE IF (I .EQ. 3) THEN
            I0   = 2
            NTXT = 2
          ELSE
            GOTO 50
          ENDIF
        ELSE IF (IPR(416) .EQ. 2) THEN
          IF (I .EQ. 1) THEN
            I0   = 1
            NTXT = 1
          ELSE IF (I .EQ. 2) THEN
            I0   = 2
            NTXT = 4
          ELSE IF (I .EQ. 3) THEN
            I0   = 3
            NTXT = 5
          ELSE
            GOTO 50
          ENDIF
        ELSE IF (IPR(416) .EQ. 3) THEN
          IF (I .EQ. 1) THEN
            I0   = 1
            NTXT = 1
          ELSE IF (I .EQ. 2) THEN
            I0   = 2
            NTXT = 6
          ELSE IF (I .EQ. 3) THEN
            I0   = 3
            NTXT = 3
          ELSE
            GOTO 50
          ENDIF
        ELSE IF (IPR(416) .EQ. 4) THEN
          GOTO 50
        ELSE
          GOTO 20
        ENDIF
        IF (IPR(182) .EQ. 0) THEN
          IF (IGBL(25) * IGBL(32) .EQ. 1) THEN
            SBCD = TXT(8)//CHAR(0)
            CALL GGIP (-999.0, 3.0, 79.0, 112)
            SBCD = TXT(NTXT)//CHAR(0)
          ELSE
            WRITE (LU6, '(A, $)') TXT(NTXT)
          ENDIF
        ENDIF
        IPR(439) = 0
        CALL PLA013 (0, 1)
        IF (LRET .EQ. 3) GOTO 10
        IF (IGGT(1:4) .EQ. '****') GOTO 30
        IF (IGGT(1:4) .EQ. 'PLOT') GOTO 10
        IF (IGGT(1:4) .EQ. 'EPS ') GOTO 10
        IF (IGGT(1:1) .EQ. 'Q')    GOTO 600
        IF (IGGT(1:3) .EQ. 'END')  GOTO 600
        IF (IGGT(1:4) .EQ. 'EXIT') GOTO 600
        IF (IPR(414) .NE. IPR414) GOTO 10
        IF (IPR(416) .NE. IPR416) GOTO 10
        CALL PLA006 (0, IS)
        IF (IFL(1)(2:4) .EQ. 'ROT') THEN
          IF (IFL(1)(1:1) .EQ. 'X') THEN
            N = -1
          ELSE IF (IFL(1)(1:1) .EQ. 'Y') THEN
            N = -2
          ELSE
            N = -3
          ENDIF
          IF (IPR(221) .GT. 0) THEN
            ANGL = - FN(1) / GL(5)
          ELSE
            ANGL = - 10.0  / GL(5)
          ENDIF
          CALL GEN021 (RMAT, IGBL(87))
          DO 40 L = 1, 3
            CALL GEN051 (0, RMAT, - GL(27 + L) / GL(5), L)
   40     CONTINUE
          CALL PLA226 (N, ANGL)
          GOTO 10
        ENDIF
        IF (IPR(220) .GT. 0) THEN
          NAMS(1, I0) = IFL(1)
          FMAT(1, I0) = -10000.0
        ELSE IF (IPR(221) .EQ. 3) THEN
          FMAT(1, I0) = FN(1)
          FMAT(2, I0) = FN(2)
          FMAT(3, I0) = FN(3)
        ELSE IF (IPR(221) .EQ. 4) THEN
          XPV(1)  = FN(1)
          XPV(2)  = FN(2)
          XPV(3)  = FN(3)
          VLAK(4) = FN(4)
          CALL GEN002 (-1, ROR, XPV(1), VLAK, XLNG)
        ENDIF
   50 CONTINUE
      NASUP = IPR(39) + IPR(64)
      CALL PLA034 (-1, NASUP)
      DO 70 I = 1, IPR(39)
        DO 60 J = 1, 3
          XMCT(J, I) = XXO(I, J)
   60   CONTINUE
        CALL GEN048 (-4, IFG(I), 15, IVAL)
        XMCT(4, I) = IVAL
   70 CONTINUE
      DO 90 I = 1, 3
        IF (FMAT(1, I) .LT. -9999.0) THEN
          NQ1 = NAMS(1, I)(1:7)
          CALL GEN020 (1, NQ1, 1, 7)
          CALL PLA046 (3, NQ1, IENM, LBB, LBC, LBD, XNQNR, YDUM, II)
          IF (II .GT. 0) THEN
            DO 80 J = 1, 3
              FMAT(J, I) = XXO(II, J)
   80       CONTINUE
          ELSE
            GOTO 610
          ENDIF
        ENDIF
   90 CONTINUE
      CALL GEN004 (OR, FMAT, CMAT)
      IF (IPR(416) .EQ. 0) THEN
        CALL GEN016 (CMAT(1, 1), CMAT(1, 2), V3)
        CALL GEN016 (CMAT(1, 3), CMAT(1, 2), V2)
        IF (GEN017 (V3) .EQ. 0.0 .OR. GEN017 (V2) .EQ. 0.0) THEN
          GOTO 610
        ELSE
          CALL GEN008 (V3, V2, VLAK, 0)
          IF (GEN017 (VLAK) .EQ. 0.0) THEN
            GOTO 610
          ELSE
            VLAK(4) = GEN009 (VLAK, CMAT(1, 1))
          ENDIF
        ENDIF
      ELSE IF (IPR(416) .EQ. 1) THEN
      ELSE IF (IPR(416) .EQ. 2) THEN
        CALL GEN016 (CMAT(1, 3), CMAT(1, 2), V2)
        D2 = 1.0 / SQRT(V2(1)**2 + V2(2)**2 + V2(3)**2)
        DO 100 J = 1, 3
          VLAK(J) = D2 * V2(J)
  100   CONTINUE
        CALL GEN015 (CMAT(1, 2), CMAT(1, 3), V2)
        VLAK(4) = GEN009 (V2, VLAK) / 2.0
        CMAT(1, 3) = 0.0
        CMAT(2, 3) = 0.0
        CMAT(3, 3) = 0.0
      ELSE IF (IPR(416) .EQ. 3) THEN
        DO 110 J = 1, 3
          V1(J) = (CMAT(J, 1) + CMAT(J, 2)) / 2
  110   CONTINUE
        DO 120 J = 1, 3
          CMAT(J, 2) = V1(J)
  120   CONTINUE
        CALL GEN016 (CMAT(1, 1), CMAT(1, 2), V1)
        CALL GEN016 (CMAT(1, 3), CMAT(1, 2), V2)
        IF (GEN017 (V1) .EQ. 0.0 .OR. GEN017 (V2) .LT. 0.0) THEN
          GOTO 610
        ELSE
          CALL GEN008 (V1, V2, V3, 0)
          IF (GEN017 (V3) .EQ. 0.0) THEN
            GOTO 610
          ELSE
            CALL GEN008 (V3, V1, VLAK, 0)
            IF (GEN017 (VLAK) .EQ. 0.0) THEN
              GOTO 610
            ELSE
              VLAK(4) = GEN009 (VLAK, CMAT(1, 1))
            ENDIF
          ENDIF
        ENDIF
      ENDIF
  130 CALL PLA179
      IPR(415) = -1
      IPR(418) = 0
      PAR(278) = PAR(271)
      IPR(417) = 1
      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     = NCT3 / 8
      IOD4     = IOD8 * 2
      LIMIT = 4 * (3 - ICENT) * IHKM * ILM
      IF (LIMIT .GT. NCT1) THEN
        WRITE (LU6, 99999) LIMIT
        STOP
      ENDIF
      IOFF(1) = 0
      IOFF(2) = IOD4
      IOFF(3) = IOFF(2) + IOD4
      IOFF(4) = IOFF(3) + IOD4
      N48     = 8 / ICENT
      LAYPP = ICENT * IOD8 / IHKM
      NPASS = ILM / LAYPP
      IF (ILM .GT. NPASS * LAYPP) NPASS = NPASS + 1
      ILS = 0
      ILE = LAYPP - 1
      DO 290 I = 1, NPASS
        IF (I .EQ. NPASS) ILE = ILM - 1
        NN = 4 * IOD4
        CALL GEN074 (SK, 0.0, 1, NN)
        CALL GEN108 (LU9, 0)
  150   READ (LU9, END = 260) JH, JK, JL, ATERM, BTERM, RSIGI, STHL
        IF (STHL .GT. PAR(412)) GOTO 150
        IF (IPR(515) .GT. 0) THEN
          IF (RSIGI .LT. IPR(515)) GOTO 150
        ENDIF
        XJX(1) = JH
        XJX(2) = JK
        XJX(3) = JL
        XJX(4) = 0.0
        DO 250 K = 1, NEQV
          CALL SGSM (ICL, K, XJX, LU6, 5, IERR)
          IH   = NINT(XJX(7))
          IK   = NINT(XJX(8))
          IL   = NINT(XJX(9))
          MHKL = IABS(IL)
          IF (MHKL .LT. ILS .OR. MHKL .GT. ILE) GOTO 250
          MH(K) = IH
          MK(K) = IK
          ML(K) = IL
          KCHK  = K - 1
          IF (KCHK .GT. 0) THEN
            DO 160 KK = 1, KCHK
              IF (IH .EQ.  MH(KK) .AND. IK .EQ.  MK(KK) .AND.
     1            IL .EQ.  ML(KK)) GOTO 250
              IF (IH .EQ. -MH(KK) .AND. IK .EQ. -MK(KK) .AND.
     1            IL .EQ. -ML(KK)) GOTO 250
  160       CONTINUE
          ENDIF
          NUL  = 1
          NFOR = 1
          NFR  = 1
          FSC  = 1.0
          IF (IH .LT. 0) THEN
            NFR = -1
          ELSE IF (IH .EQ. 0) THEN
            NUL = NUL + 1
            FSC = FSC * 0.5
          ENDIF
          IH  = NFR * IH
          IK  = NFR * IK
          IL  = NFR * IL
          IF (IK .LT. 0) THEN
            NFOR = NFOR + 1
            IK   = - IK
          ELSE IF (IK .EQ. 0) THEN
            NUL = NUL + 2
            FSC = FSC * 0.5
          ENDIF
          IF (IL .LT. 0) THEN
            NFOR = NFOR + 2
            IL = - IL
          ELSE IF (IL .EQ. 0) THEN
            NUL = NUL + 4
            FSC = FSC * 0.5
          ENDIF
          IND  = IK + 1 + IH * IKM + IHKM * (IL - ILS)
          INDA = IND + IOFF(NFOR)
          INDB = INDA + IOD8
          IF (IPR(414) .LT. 5) THEN
            FASE = XJX(10) / GL(5)
            AB  = ( ATERM * COS(FASE) + BTERM * SIN(FASE)) * FSC
            BBT = (-ATERM * SIN(FASE) + BTERM * COS(FASE)) * FSC * NFR
          ELSE
            FASE = 0.0
            AB   = ATERM * FSC
            BBT  = BTERM * FSC * NFR
          ENDIF
          NC  = 1
          IF (NUL .EQ. 1) THEN
            SK(INDA) = AB
            IF (ICENT .EQ. 1) SK(INDB) = BBT
          ELSE IF (NUL .EQ. 2) THEN
            DO 170 MM = 1, 2
              INDA = IND + IOFF(NFOR)
              SK(INDA) = AB
              IF (ICENT .EQ. 1) THEN
                INDB = INDA + IOD8
                SK(INDB) = BBT * NC
              ENDIF
              NFOR = 5 - NFOR
              NC   = -1
  170       CONTINUE
          ELSE IF (NUL .EQ. 3) THEN
            DO 180 MM = 1, 2
              INDA = IND + IOFF(NFOR)
              SK(INDA) = AB
              IF (ICENT .EQ. 1) THEN
                INDB = INDA + IOD8
                SK(INDB) = BBT
              ENDIF
              NFOR = NFOR + 1
  180       CONTINUE
          ELSE IF (NUL .EQ. 5) THEN
            DO 190 MM = 1, 2
              INDA = IND + IOFF(NFOR)
              SK(INDA) = AB
              IF (ICENT .EQ. 1) THEN
                INDB = INDA + IOD8
                SK(INDB) = BBT
              ENDIF
              NFOR = NFOR + 2
  190       CONTINUE
          ELSE IF (NUL .EQ. 4) THEN
            DO 210 MA = 1, 2
              DO 200 MM = 1, 2
                INDA = IND + IOFF(NFOR)
                SK(INDA) = AB
                IF (ICENT .EQ. 1) THEN
                  INDB = INDA + IOD8
                  SK(INDB) = BBT * NC
                ENDIF
                NFOR = NFOR + 1
  200         CONTINUE
              NFOR = 6 - NFOR
              NC   = -1
  210       CONTINUE
          ELSE IF (NUL .EQ. 6) THEN
            DO 230 MA = 1, 2
              DO 220 MM = 1, 2
                INDA = IND + IOFF(NFOR)
                SK(INDA) = AB
                IF (ICENT .EQ. 1) THEN
                  INDB = INDA + IOD8
                  SK(INDB) = BBT * NC
                ENDIF
                NFOR = NFOR + 2
  220         CONTINUE
              NFOR = 7 - NFOR
              NC   = -1
  230       CONTINUE
          ELSE IF (NUL .EQ. 7) THEN
            DO 240 MA = 1, 4
              INDA = IND + IOFF(MA)
              SK(INDA) = AB
              IF (ICENT .EQ. 1) THEN
                INDB = INDA + IOD8
                SK(INDB) = BBT
              ENDIF
  240       CONTINUE
          ENDIF
  250   CONTINUE
        GOTO 150
  260   DO 280 III = ILS, ILE
          JS = (III - ILS) * IHKM
          JC = III * IHKM * N48 + 1
          DO 270 J = JS + 1, JS + IHKM
            J1 = J
            J2 = J1 + IOD4
            J3 = J2 + IOD4
            J4 = J3 + IOD4
            COEFF(JC)     =   SK(J1) + SK(J2) + SK(J3) + SK(J4)
            COEFF(JC + 1) = - SK(J1) + SK(J2) - SK(J3) + SK(J4)
            COEFF(JC + 2) = - SK(J1) - SK(J2) + SK(J3) + SK(J4)
            COEFF(JC + 3) = - SK(J1) + SK(J2) + SK(J3) - SK(J4)
            IF (ICENT .EQ. 1) THEN
              J1 = J1 + IOD8
              J2 = J2 + IOD8
              J3 = J3 + IOD8
              J4 = J4 + IOD8
              COEFF(JC + 4) =   SK(J1) + SK(J2) - SK(J3) - SK(J4)
              COEFF(JC + 5) = - SK(J1) + SK(J2) + SK(J3) - SK(J4)
              COEFF(JC + 6) =   SK(J1) + SK(J2) + SK(J3) + SK(J4)
              COEFF(JC + 7) =   SK(J1) - SK(J2) + SK(J3) - SK(J4)
            ENDIF
            JC = JC + N48
  270     CONTINUE
  280   CONTINUE
        ILS = ILS + LAYPP
        ILE = ILE + LAYPP
        IF (ILE .GT. ILM - 1) ILE = ILM - 1
  290 CONTINUE
      NA = 0
      DO 350 JJJ = 1, IPR(39)
        DO 300 J = 1, 3
          XJX(J)     = XXO(JJJ, J)
          XJX(J + 3) = 0.0
  300   CONTINUE
        MM = NA + 1
        IF (MM .GT. NCT0) GOTO 620
        DO 340 J = 1, NST
          CALL SGSM (ICL, J, XJX, LU6, 3, IERR)
          DO 310 K = 1, 3
            CXY = MOD(XJX(6 + K), 1.0)
            IF (CXY .LT. 0.0) CXY = CXY + 1.0
            ATOM(K, NA + 1) = CXY
  310     CONTINUE
          IF (J .NE. 1) THEN
            DO 330 II = MM, NA
              DO 320 K = 1, 3
                IF (ABS(ATOM(K, NA + 1) - ATOM(K, II)) .GT. 1.0E-6)
     1              GOTO 330
  320         CONTINUE
              GOTO 340
  330       CONTINUE
          ENDIF
          NA          = NA + 1
          ATOM(4, NA) = XLAB(JJJ)
          IFLG(NA)    = IFG(JJJ)
          JFLG(NA)    = JFG(JJJ)
  340   CONTINUE
  350 CONTINUE
  360 PHI = PAR(276) / GL(5)
      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
      DO 390 I = 1, 3
        DIST1 = GEN009 (VLAK, CMAT(1, I)) - VLAK(4)
        DO 370 J = 1, 3
          V1(J) = DIST1 * VLAK(J)
  370   CONTINUE
        CALL GEN016 (CMAT(1, I), V1, V2)
        DO 380 J = 1, 3
          CMAT(J, I) = V2(J)
  380   CONTINUE
  390 CONTINUE
      CALL GEN016 (CMAT(1, 1), CMAT(1, 2), V1)
      DIST1 = SQRT(GEN009(V1, V1))
      DO 400 I = 1, 3
        XN(I, 1) = V1(I) / DIST1
  400 CONTINUE
      CALL GEN008 (VLAK, XN(1, 1), XN(1, 2), 0)
      DO 410 I = 1, 3
        XN(I, 4) = PAR(274) * XN(I, 1) + PAR(275) * XN(I, 2)
     1           + CMAT(I, 2)
  410 CONTINUE
      CALL GEN002 (1, ROR, XN(1, 4), XFO, XLNG)
      SINPHI = SIN(PHI)
      COSPHI = COS(PHI)
      DO 420 I = 1, 3
        V1(I) =  COSPHI * XN(I, 1) + SINPHI * XN(I, 2)
        V2(I) = -SINPHI * XN(I, 1) + COSPHI * XN(I, 2)
  420 CONTINUE
      DO 430 I = 1, 3
        XN(I, 1) = PAR(271) * V1(I)
        XN(I, 2) = PAR(271) * V2(I)
  430 CONTINUE
      CALL GEN002 (1, ROR, XN(1, 1), DXF, XLNG)
      CALL GEN002 (1, ROR, XN(1, 2), DYF, XLNG)
      CALL GEN002 (1, ROR, XN(1,4), FC(1,5), XLNG)
      DO 440 I = 1, 3
        V0(I) = NYM * DYF(I)
        V1(I) = NYP * DYF(I)
        V2(I) = NXM * DXF(I)
        V3(I) = NXP * DXF(I)
  440 CONTINUE
      CALL GEN015 (V2, V1, FC(1, 1))
      CALL GEN015 (V3, V1, FC(1, 2))
      CALL GEN015 (V3, V0, FC(1, 3))
      CALL GEN015 (V2, V0, FC(1, 4))
      DO 460 I = 1, 4
        CALL GEN015 (FC(1, I), FC(1, 5), V1)
        DO 450 J = 1, 3
          FC(J, I) = V1(J)
  450   CONTINUE
  460 CONTINUE
      WRITE (LU7, 99996)
      WRITE (LU7, 99995) (XFO(I), I = 1, 3)
      WRITE (LU7, 99994) (FC(I, 1), I = 1, 3), NXM, NYP
      WRITE (LU7, 99993) (FC(I, 2), I = 1, 3), NXP, NYP
      WRITE (LU7, 99992) (FC(I, 3), I = 1, 3), NXP, NYM
      WRITE (LU7, 99991) (FC(I, 4), I = 1, 3), NXM, NYM
      DO 470 I = 1, 3
        ULC(I) = FC(I, 1)
  470 CONTINUE
C * DO THE FOURIER SUMMATION
      IF (IPR(414) .EQ. 3) THEN
        F000 = 0.0
      ELSE
        IF (PAR(277) .NE. 0.0) THEN
          F000 = PAR(277)
        ELSE
          F000 = PAR(157)
        ENDIF
      ENDIF
      DO 520 IY = 1, MY
        UPL1 = ULC(1) - DXF(1) - (IY - 1) * DYF(1)
        UPL2 = ULC(2) - DXF(2) - (IY - 1) * DYF(2)
        UPL3 = ULC(3) - DXF(3) - (IY - 1) * DYF(3)
        DO 510 IX = 1, MX
          X   = (UPL1 + IX * DXF(1)) * GL(6)
          Y   = (UPL2 + IX * DXF(2)) * GL(6)
          Z   = (UPL3 + IX * DXF(3)) * GL(6)
          SX1 = SIN(X)
          CX1 = COS(X)
          SY1 = SIN(Y)
          CY1 = COS(Y)
          SZ1 = SIN(Z)
          CZ1 = COS(Z)
          CZ  = CZ1
          SZ  = -SZ1
          ICO = 0
          R   = F000 / 2.0
          DO 500 IL = 1, ILM
            CZT = CZ * CZ1 - SZ * SZ1
            SZ  = SZ * CZ1 + CZ * SZ1
            CZ  = CZT
            CX  = CX1
            SX  = -SX1
            DO 490 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 480 IK = 1, IKM
                CYT = CY * CY1 - SY * SY1
                SY  = SY * CY1 + CY * SY1
                CY  = CYT
                ICO = ICO + 4
                R   = R + COEFF(ICO - 3) * CXCZ * CY
     1              +     COEFF(ICO - 2) * SXCZ * SY
     2              +     COEFF(ICO - 1) * SXSZ * CY
     3              +     COEFF(ICO)     * CXSZ * SY
                IF (ICENT .EQ. 1) THEN
                  ICO = ICO + 4
                  R   = R + COEFF(ICO - 3) * CXSZ * CY
     1                +     COEFF(ICO - 2) * SXSZ * SY
     2                +     COEFF(ICO - 1) * SXCZ * CY
     3                +     COEFF(ICO)     * CXCZ * SY
                ENDIF
  480         CONTINUE
  490       CONTINUE
  500     CONTINUE
          FMP(IX, MY - IY + 1) = R * 200 / PAR(98)
  510   CONTINUE
  520 CONTINUE
      IF (IPR(580) .EQ. 1) THEN
        WRITE (LU65, 99998) MX * MY
        WRITE (LU65, 99997)
     1        ((FMP(I, J) * 0.01, J = 1, MY), I = 1, MX)
        NRSECT = NRSECT + 1
        IF (NRSECT .GT. NSECTIONS) THEN
          LRT1     = 2
          VLAK(4)  = VLAK(4) - IPR(578) * PAR(278)
          CALL GEN008 (XN(1, 1), XN(1, 2), XN(1, 3), 1)
          DO 530 I = 1, 3
            RORO(3, I) = XN(I, 3)
  530     CONTINUE
          DO 550 I = 1, 2
            DO 540 J = 1, 3
              RORO(I, J) = XN(J, I) / PAR(271)
  540       CONTINUE
  550     CONTINUE
          WRITE (LU65, 99986) IPR(39), 14
          DO 570 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) .EQ. ' ') N = 1
            DO 560 J = 1, 3
              V1(J) = XMCT(J, I)  - FMAT(J, 2)
  560       CONTINUE
            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, 99985) NQ1(1+N:4+N), CHAR(0), FLOAT(I), 1.0,
     1        0.0, (V3(J), J = 1, 3), 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0
  570     CONTINUE
          CLOSE (LU65)
C * F3D
          NE = FINDEXE ('F3DEXE', PLPATH, 'f3d')
          IF (NE .GT. 0) THEN
            PLPATH(NE + 1:) = ' '//NAME(1)(1:KNM(1))//'.fou &'
            CALL SYSTEM (PLPATH)
          ENDIF
          IPR(580) = -1
        ELSE
          VLAK(4) = VLAK(4) + PAR(278)
        ENDIF
        GOTO 360
      ENDIF
C * DO THE PLOTTING
  580 CALL PLA251
      IF (IGBL(25) .NE. 1)
     1    CALL PLA285 (1, LU6, 'Next section (Up/Down/Quit/+,-dist)')
  590 IPR(439) = 1
      CALL PLA252 (2, LRT1)
      IF (LRT1 .EQ. 1) THEN
        GOTO 600
      ELSE IF (LRT1 .EQ. 2) THEN
        VLAK(4) = VLAK(4) + PAR(278) * IPR(417)
        GOTO 360
      ELSE IF (LRT1 .EQ. 3) THEN
        GOTO 130
      ELSE IF (LRT1 .EQ. 4) THEN
        GOTO 10
      ELSE IF (LRT1 .EQ. 5) THEN
        GOTO 590
      ELSE IF (LRT1 .EQ. 6) THEN
        GOTO 580
      ELSE IF (LRT1 .EQ. 7) THEN
        VLAK(4) = VLAK(4) - PAR(278) * IPR(577)
        NSECTIONS = IPR(577) + IPR(578) + 1
        NRSECT    = 1
        OPEN (UNIT = LU65, FILE = NAME(1)(1:KNM(1))//'.fou',
     1                          STATUS = 'UNKNOWN')
        WRITE (LU65, 99990)
        WRITE (LU65, 99997) 1.0, 0.0, 0.0, 0.0, 1.0, 0.0, 0.0, 0.0, 1.0,
     1                      0.0, 0.0, 0.0
        WRITE (LU65, 99989) (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, 99988)
     1    -XMX,  PAR(271), XMX,  1.0,
     2    -XMY,  PAR(271), XMY,  1.0,
     3    -XMZM, PAR(278), XMZP, 1.0
        WRITE (LU65, 99987) MX, MY, NSECTIONS
        GOTO 360
      ENDIF
  600 IGBL(23) = 10
      RETURN
  610 CALL PLA015 (0, 42)
      GOTO 20
  620 CALL PLA015 (0, 56)
      GOTO 600
99999 FORMAT ('Job too large for COEFF array. ',I6,' needed ')
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 ('INFO  DOWN, ACROSS AND SECTION', /, 'TRAN')
99989 FORMAT ('CELL', 6(/, F15.8))
99988 FORMAT ('L14', 12(/, F15.8))
99987 FORMAT ('SIZE', 3(/, I8))
99986 FORMAT ('LIST5', 2(/, I8))
99985 FORMAT (A, A, 13(/, F15.8))
      END
      SUBROUTINE PLA251
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118,
     1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NPVD=40000000,
     2 NP22=256,NP23=18000,NP25=99,NP29=63,NP38=125,NP39=30,NP41=200,
     3 NP45=2048,NP47=9,NCT0 = 5000,NCT1=500000,NTC4=200,NCT5=2000,
     4 NCT6 = 100, NCT7 = NCT6 + 1, NCT8 = 2500, NCT3 =  NPVD + 2
     5 * NP23 - 7  - 8 * NCT8 -2 *
     6 NCT5 - 6 * NCT0 - NCT1 - 3 * NTC4 * NTC4 - NCT6 * (NCT6 + 13))
      COMMON // ATOM(4, NCT0), IFLG(NCT0), JFLG(NCT0),
     1 COEFF(NCT1), XMPC(NCT8, 6), IMPC(NCT8), JMPC(NCT8), Q8(2, NCT5),
     2 FMP(NTC4, NTC4), IEXX(2, NTC4, NTC4), SMA(NCT6, NCT7),
     3 P8(12, NCT6), SK(NCT3), DXF(3), DYF(3), NAT
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /Q/ ICL, IFL(NP17)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0
      COMMON /APLOT/ X, Y, SCALE, PXS, PYS, STEP, VLAK(4)
      COMMON /ASESCH/ NT, IN, IXY, IX, IY, IV
      COMMON /AINPUT/ NS, NE, MX, MY, NXP, NXM, NYP, NYM, PHI,
     1  XN(3, 4), FMAT(3, 3), CMAT(3, 3), XMCT(4, 500)
      COMMON /ASETUP/ ID(6, 6, 2), IRANGE(12)
      COMMON /CTR/ NA, ICENT, IKM, ILM, IHM
      COMMON /AREA/ L7, T9(NCT6), N7, NS7, NE7, IC, MM, XX, YY, JV, NN
      COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9),
     1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10),
     2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10),
     3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /CGGT/ IGGT
      CHARACTER IGGT*80
      DIMENSION XT(3)
      IN7  = 0
      IXY7 = 0
      IX7  = 0
      IY7  = 0
      X7   = 0.0
      Y7   = 0.0
      RESX1 = PAR(279) / PAR(271)
      XLOW  = NXM - RESX1
      XHIGH = NXP + RESX1
      YLOW  = NYM - RESX1
      YHIGH = NYP + RESX1
      NAT   = 0
      DO 70 IA = 1, NA
        DO 60 IX = 1, 3
          XT(1) = ATOM(1, IA) + IX - 2
          DO 50 IY = 1, 3
            XT(2) = ATOM(2, IA) + IY - 2
            DO 40 IZ = 1, 3
              XT(3) = ATOM(3, IA) + IZ - 2
              CALL GEN002 (1, OR, XT, V3, XLNG)
              DO 10 I = 1, 3
                XMPC(NAT + 1, I + 3) = V3(I)
   10         CONTINUE
              DIST1 = GEN009 (VLAK, V3)
              DIS = DIST1 - VLAK(4)
              DO 20 J = 1, 3
                V1(J) = DIS * VLAK(J)
   20         CONTINUE
              CALL GEN016 (V3, V1, V2)
              CALL GEN016 (V2, XN(1, 4), V1)
              DO 30 I = 1, 2
                V3(I) = GEN009 (V1, XN(1, I))
   30         CONTINUE
              V3(1) = V3(1) / PAR(271)**2
              V3(2) = V3(2) / PAR(271)**2
              IF (V3(1) .GT. XLOW .AND. V3(1) .LT. XHIGH .AND.
     1            V3(2) .GT. YLOW .AND. V3(2) .LT. YHIGH .AND.
     2            ABS(DIS) .LT. PAR(279)) THEN
                IF (NAT .GE. NCT8) GOTO 80
                NAT = NAT + 1
                CALL PLA047 (ATOM(4, IA), NQ1, IDUM1, IDUM2, 0,
     1                       IGBL(55), 0, 0)
                XMPC(NAT, 1) = V3(1)
                XMPC(NAT, 2) = V3(2)
                IF (ABS(DIS) .LT. PAR(271)) THEN
                  XMPC(NAT, 3) = - ATOM(4, IA)
                ELSE
                  XMPC(NAT, 3) = ATOM(4, IA)
                ENDIF
                IMPC(NAT)      = IFLG(IA)
                JMPC(NAT)      = JFLG(IA)
              ENDIF
   40       CONTINUE
   50     CONTINUE
   60   CONTINUE
   70 CONTINUE
   80 TMIN = 100000
      TMAX =    100
      DO 100 J = 1, MY
        DO 90 I = 1, MX
          T = FMP(I, J)
          TMIN = MIN (TMIN, T)
          TMAX = MAX (TMAX, T)
   90   CONTINUE
  100 CONTINUE
      ITMAX = NINT(TMAX)
      ITMIN = NINT(TMIN) - 1
      IF (IPR(418) .EQ. 0) THEN
        IDT   = ITMAX - ITMIN
        DO 110 I = 1, 12
          IF (IRANGE(I) .GE. IDT) THEN
            IPR(419) = IRANGE(I) / 20
            GOTO 120
          ENDIF
  110   CONTINUE
        IPR(419) = 100
      ENDIF
  120 NE = ((ITMAX / IPR(419)) + 1) * IPR(419)
      NS = ((ITMIN / IPR(419)) - 1) * IPR(419)
      IF (IPR(418) .EQ. 0 .AND. IGBL(25) .NE. 1) THEN
        WRITE (LU6, 99998) 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) .EQ. 1) THEN
          IPR(419) = MAX (5, NINT(FN(1) * 100.0))
        ENDIF
      ENDIF
      I  = (NE - NS) / IPR(419)
      J  =  NE - NS  - IPR(419) * I
      NE = NS + IPR(419) * I
      IF (J .NE. 0) NE = NE + IPR(419)
      DO 140 J = 1, MY
        DO 130 I = 1, MX
          T  = FMP(I, J)
          CH = T / IPR(419) - INT(T / IPR(419))
          IF (CH .EQ. 0.0) FMP(I, J) = T + SIGN(0.01, T)
  130   CONTINUE
  140 CONTINUE
      XS = HORS * 0.88
      SL = XS / 100.0
      IF (IPR(418) .EQ. 0) THEN
        SCALE = XS / (MX - 1)
        PYS = (VERT - SCALE * (MY - 1)) / 2.0
        PXS = (HORS - XS) / 2
        YS = VERT * 0.88
        IF ((MY - 1) * SCALE .GT. YS) THEN
          SCALE = YS / (MY - 1)
          PXS = (HORS - SCALE * (MX - 1)) / 2.0
          PYS = (VERT - YS) / 2
        ENDIF
        STEP = SCALE / PAR(271)
        IPR(418) = 1
      ENDIF
      CALL GGIP (HORS, VERT, 0.0, 1)
      IF (IGBL(103) .EQ. 1) THEN
        CALL GEN002 (-1, OR, VLAK, XPV(5), XLNG)
        XPV(8) = VLAK(4)
        WRITE (ICL, 99999) (XPV(I), I = 5, 8),
     1        (NS + IPR(419)) / 100.0, (NE - IPR(419)) / 100.0,
     2        IPR(419) / 100.0
        CALL GGIP20 (0.0, ICL, 80, 0.3, 1, 2, 1.5, VERT - 0.5)
        IF (IPR(414) .EQ. 5) THEN
          NQ1 = 'PAT-Map'
        ELSE IF (IPR(414) .EQ. 1) THEN
          NQ1 = ' Fo-Map'
        ELSE IF (IPR(414) .EQ. 2) THEN
          NQ1 = ' 2Fo-Fc'
        ELSE IF (IPR(414) .EQ. 3) THEN
          NQ1 = 'Dif-Map'
        ELSE IF (IPR(414) .EQ. 4) THEN
          NQ1 = 'SQZ-Map'
        ENDIF
        CALL GGIP20 (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)) * GL(5))
        WRITE (ICL, 99997) PAR(279), PAR(278) * IPR(417),
     1                     RESOL, IPR(515)
        CALL GGIP20 (0.0, ICL, 80, 0.3, 1, 2, 2.0, VERT - 0.95)
        CALL PLA117 (HORS, VERT, -1)
      ENDIF
      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)
      XST = PXS - STEP
  150 XST = XST + STEP
      IF (XST .LT. XPOS) THEN
        CALL GGIP (XST, PYS,      0.0, 3)
        CALL GGIP (XST, PYS - SL, 0.0, 2)
        GOTO 150
      ENDIF
      YST = PYS - STEP
  160 YST = YST + STEP
      IF (YST .LT. YPOS) THEN
        CALL GGIP (PXS,      YST, 0.0, 3)
        CALL GGIP (PXS - SL, YST, 0.0, 2)
        GOTO 160
      ENDIF
      CALL GGIP20 (0.0, 'Ang', 3, 0.3, 1, 2, XPOS + OFF, PYS - OFF)
      MX2 = (MX - 1) / 2
      MY2 = (MY - 1) / 2
      IF (IPR(414) .LT. 5 .AND. NAT .GT. 0) THEN
        DO 170 I = 1, NAT
          XXA = PXS + SCALE * (XMPC(I, 1) + MX2)
          YYA = PYS + SCALE * (XMPC(I, 2) + MY2)
          IF (XXA .GT. PXS .AND. XXA .LT. XPOS) THEN
            IF (YYA .GT. PYS .AND. YYA .LT. YPOS) THEN
              IF (XMPC(I, 3) .LT. 0.0) THEN
                CALL GGIP (0.0, 1.0, 0.0, 0)
              ELSE
                CALL GGIP (0.0, 4.0, 0.0, 0)
              ENDIF
              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)
              IF (IGBL(75) .EQ. 1) THEN
                CALL GEN048 (-4, IMPC(I), 15, NO1)
                NO1 = IEN(NO1 + 1)
                IF (NO1 .NE. 1 .OR. (NO1 .EQ. 1 .AND. IPR(232) .EQ. 1))
     1           THEN
                  XGGIP = XXA + OFF
                  YGGIP = YYA + OFF
                  IF (YGGIP + 0.3 .GT. YPOS) YGGIP = YGGIP - 2.0 * OFF
                  IF (XGGIP + 1.2 .GT. XPOS)
     1                XGGIP = XGGIP - 2.0 * OFF - 1.2
                  CALL PLA047 (ABS(XMPC(I, 3)), NQ1, IDUM1, IDUM2, 0,
     1                         IGBL(55), 0, 0)
                  CALL GEN048 (-1, IMPC(I), 30, IVAL)
                  CALL GGIP20 (0.0, NQ1, 5, 0.3, 1 + IVAL * 4, 2,
     1                         XGGIP, YGGIP)
                ENDIF
              ENDIF
            ENDIF
          ENDIF
  170   CONTINUE
      ENDIF
      IF (IPR(458) .EQ. 1 .AND. IPR(414) .LT. 5) THEN
        DO 200 I = 1, NAT - 1
          CALL GEN048 (-4, IMPC(I), 15, NO1)
          CALL PLA047 (ABS(XMPC(I, 3)), NQ1, IDUM1, IDUM2, 0, IGBL(55),
     1                 0, 0)
          DISTI = REL(IEN(NO1 + 1)) + 0.4
          DO 190 J = I + 1, NAT
            CALL GEN048 (-4, IMPC(J), 15, NO2)
            CALL PLA047 (ABS(XMPC(J, 3)), NQ2, IDUM1, IDUM2, 0,
     1                   IGBL(55), 0, 0)
            DISTMX = DISTI + REL(IEN(NO2 + 1))
            DIST = 0
            DO 180 K = 4, 6
              DIST = DIST + (XMPC(I, K) - XMPC(J, K))**2
  180       CONTINUE
            IF (SQRT (DIST) .LT. DISTMX) THEN
              XXA = PXS + SCALE * (XMPC(I, 1) + MX2)
              YYA = PYS + SCALE * (XMPC(I, 2) + MY2)
              IF (XXA .GT. PXS .AND. XXA .LT. XPOS) THEN
                IF (YYA .GT. PYS .AND. YYA .LT. YPOS) THEN
                  XXB = PXS + SCALE * (XMPC(J, 1) + MX2)
                  YYB = PYS + SCALE * (XMPC(J, 2) + MY2)
                  IF (XXB .GT. PXS .AND. XXB .LT. XPOS) THEN
                    IF (YYB .GT. PYS .AND. YYB .LT. YPOS) THEN
                      CALL GGIP (XXA, YYA, 0.0, 3)
                      CALL GGIP (XXB, YYB, 0.0, 2)
                    ENDIF
                  ENDIF
                ENDIF
              ENDIF
            ENDIF
  190     CONTINUE
  200   CONTINUE
      ENDIF
C *********************************************************************
C *********************************************************************
      DO 460 JV0 = NS, NE, IPR(419)
        IV = NE - JV0 + NS
        DO 230 K = 1, 2
          DO 220 J = 1, MX
            DO 210 I = 1, MY
              IEXX(K, J, I) = 0
  210       CONTINUE
  220     CONTINUE
  230   CONTINUE
        DO 450 KX = 1, MX - 1
          JX = MX - KX
          DO 440 KY = 2, MY - 1
            JY = MY - KY + 1
            RA = (FMP(JX, JY) - IV) * (FMP(JX + 1, JY) - IV)
            IF (RA .GT. 0.0) GOTO 440
            IF (IEXX(1, JX, JY) .NE. 0) GOTO 440
            IUC = 0
            JUC = 0
            JC  = 0
            LC  = 0
            NT  = 0
            Q8(1, 1) = 0.0
            Q8(2, 1) = 0.0
  240       IXY = 1
            IN  = 6
            IX  = JX
            IY  = JY
            CALL PLA254
            XXX = X
            YYY = Y
            IEXX(1, JX, JY) = 2
            N5 = 6
            GOTO 260
  250       N5 = 5
  260       II = 1
  270       IF (IUC .EQ. 0) THEN
              I = IN + II
              IF (I .GT. 6) I = I - 6
            ELSE
              I = IN - II
              IF (I .LT. 1) I = I + 6
            ENDIF
            IX1 = ID(1, I, IXY) + IX
            IF (IX1 .NE. 0) THEN
              IY1 = ID(2, I, IXY) + IY
              IF (IY1 .NE. 0) THEN
                IX2 = ID(3, I, IXY) + IX
                IY2 = ID(4, I, IXY) + IY
                RA = (FMP(IX1, IY1) - IV) * (FMP(IX2, IY2) - IV)
                IF (RA .LT. 0.0) GOTO 300
              ENDIF
            ENDIF
  280       II = II + 1
            IF (II .LE. N5) GOTO 270
  290       IF (JUC .EQ. 1) GOTO 330
            JUC = 1
            JC  = NT
            IUC = MOD(IUC + 1, 2)
            GOTO 240
  300       ICH = ID(5, I, IXY)
            IF (IEXX(ICH, IX1, IY1) .EQ. 1) GOTO 280
            IN6  = ID(6, I, IXY)
            IXY6 = ICH
            IX6  = IX1
            IY6  = IY1
            MC   = 0
            II   = II + 1
            IF (LC .NE. 2) THEN
              IF (II .NE. 6) THEN
                DO 310 III = II, 5
                  IF (IUC .EQ. 1) THEN
                    I9 = IN - III
                    IF (I9 .LT. 1) I9 = I9 + 6
                  ELSE
                    I9 = IN + III
                    IF (I9 .GT. 6) I9 = I9 - 6
                  ENDIF
                  IX9 = ID(1, I9, IXY) + IX
                  IF (IX9 .NE. 0) THEN
                    IY9 = ID(2, I9, IXY) + IY
                    IF (IY9 .NE. 0) THEN
                      IX8 = ID(3, I9, IXY) + IX
                      IY8 = ID(4, I9, IXY) + IY
                      RA9 = (FMP(IX9, IY9) - IV) * (FMP(IX8, IY8) - IV)
                      IF (RA9 .LT. 0.0) THEN
                        ICH9 = ID(5, I9, IXY)
                        IF (IEXX(ICH9, IX9, IY9) .NE. 1) THEN
                          IF ((ICH9 .EQ. 2 .AND. IY9 .NE. MY) .OR.
     1                        (ICH9 .NE. 2 .AND. IX9 .NE. MX)) THEN
                            IN7  = ID(6, I9, IXY)
                            IXY7 = ICH9
                            IX7  = IX9
                            IY7  = IY9
                            MC   = 1
                          ENDIF
                        ENDIF
                      ENDIF
                    ENDIF
                  ENDIF
  310           CONTINUE
                IXY = IXY7
                IX  = IX7
                IY  = IY7
                CALL PLA254
                NT = NT - 1
                X7 = X
                Y7 = Y
              ENDIF
            ENDIF
            IXY = IXY6
            IX  = IX6
            IY  = IY6
            CALL PLA254
            IF (MC .NE. 0) THEN
              DX = X - XXX
              DY = Y - YYY
              R6 = SQRT(DX**2 + DY**2)
              DX = X7 - XXX
              DY = Y7 - YYY
              R7 = SQRT(DX**2 + DY**2)
              IF ((R6 / R7) .GE. 2.5) THEN
                IN  = IN7
                IXY = IXY7
                IX  = IX7
                IY  = IY7
                IEXX(IXY, IX, IY) = 1
                Q8(1, NT) = X7
                Q8(2, NT) = Y7
                X  = X7
                Y  = Y7
                LC = 1
                IUC = MOD(IUC + 1, 2)
                GOTO 320
              ENDIF
            ENDIF
            IEXX(IXY, IX, IY) = 1
            IN  = IN6
            LC  = 0
  320       XXX = X
            YYY = Y
            LC  = LC + 1
            IF (LC .EQ. 4) THEN
              IUC = MOD(IUC + 1, 2)
              LC  = 1
            ENDIF
            IF (Q8(1, 1) .NE. X .OR. Q8(2, 1) .NE. Y) THEN
              IF (IXY .EQ. 1) THEN
                IF (IY .EQ. 1 .OR. IY .EQ. MY) GOTO 290
              ELSE
                IF (IX .EQ. 1 .OR. IX .EQ. MX) GOTO 290
              ENDIF
              GOTO 250
            ENDIF
  330       IF (JC .GT. 0) THEN
              JCH = JC / 2
              DO 340 I0 = 1, JCH
                J0 = JC - I0 + 1
                CALL GEN018 (Q8(1, I0), Q8(1, J0))
                CALL GEN018 (Q8(2, I0), Q8(2, J0))
  340         CONTINUE
              NS0 = JC + 2
              IF (NS0 .LE. NT) THEN
                DO 350 I0 = NS0, NT
                  Q8(1, I0 - 1) = Q8(1, I0)
                  Q8(2, I0 - 1) = Q8(2, I0)
  350           CONTINUE
              ENDIF
              NT = NT - 1
            ENDIF
            IF (NT .NE. 1) THEN
              MM = IV
              IF (MM .EQ. 0) THEN
                NN = 8
              ELSE
                NN = 4
              ENDIF
              JV = 0
              IF (Q8(1, 1) .EQ. Q8(1, NT) .AND. Q8(2, 1) .EQ. Q8(2, NT))
     1         THEN
                IC = 3
                JCYCLE = 1
              ELSE
                IC = 2
                JCYCLE = 0
              ENDIF
              IF (NT .LE. 30) THEN
                DO 360 J = 1, NT
                  P8(1, J) = Q8(1, J)
                  P8(2, J) = Q8(2, J)
  360           CONTINUE
                NS7 = 1
                NE7 = NT
                N7  = NT
                CALL PLA253
                GOTO 440
              ENDIF
              N2 = NINT(NT / 20.0)
              IC = 2
              N3 = INT(NT / N2)
              N4 = NT - N2 * N3 + N3
              DO 370 J = 1, N3 + 2
                P8(1, J) = Q8(1, J)
                P8(2, J) = Q8(2, J)
  370         CONTINUE
              N7  = N3 + 2
              NS7 = 1
              NE7 = N7 - 2
              IF (JCYCLE .NE. 0) THEN
                DO 380 J = 1, N3 + 2
                  P8(1, J + 2) = Q8(1, J)
                  P8(2, J + 2) = Q8(2, J)
  380           CONTINUE
                DO 390 I = 1, 2
                  P8(I, 1) = Q8(I, NT - 2)
                  P8(I, 2) = Q8(I, NT - 1)
  390           CONTINUE
                N7  = N7 + 2
                NS7 = 3
                NE7 = NE7 + 2
              ENDIF
              CALL PLA253
              IF (N2 .NE. 2) THEN
                DO 410 II = 1, N2 - 2
                  N5 = II * N3 - 3
                  DO 400 J = 1, N3 + 5
                    P8(1, J) = Q8(1, N5 + J)
                    P8(2, J) = Q8(2, N5 + J)
  400             CONTINUE
                  N7  = N3 + 5
                  NS7 = 3
                  NE7 = N7 - 2
                  CALL PLA253
  410           CONTINUE
              ENDIF
              N6 = N3 * (N2 - 1) - 3
              IF (N6 + N4 + 3 .LE. NCT5) THEN
                DO 420 J = 1, N4 + 3
                  P8(1, J) = Q8(1, N6 + J)
                  P8(2, J) = Q8(2, N6 + J)
  420           CONTINUE
              ELSE
                WRITE (LU6, '(''PROBLEM WITH Q8'')')
                GOTO 460
              ENDIF
              N7  = N4 + 3
              NS7 = 3
              NE7 = N7
              IF (JCYCLE .NE. 0) THEN
                DO 430 I = 1, 2
                  P8(I, N4 + 4) = Q8(I, 2)
                  P8(I, N4 + 5) = Q8(I, 3)
  430           CONTINUE
                N7 = N7 + 2
              ENDIF
              CALL PLA253
            ENDIF
  440     CONTINUE
  450   CONTINUE
  460 CONTINUE
      CALL GGIP (0.0, 0.0, 0.0,  3)
      CALL GGIP (0.0, 0.0, 0.0, -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)
      END
      SUBROUTINE PLA252 (MODE, LRT1)
      PARAMETER (NP12=600,NP13=500,NP17=99,NP38=125,NP39=30,NP45=2048)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /Q/ ICL, IFL(NP17)
      CHARACTER ICL*(NP45), IFL*7
      COMMON /APLOT/ X, Y, SCALE, PXS, PYS, STEP, VLAK(4)
      COMMON /AINPUT/ NS, NE, MX, MY, NXP, NXM, NYP, NYM, PHI,
     1  XN(3, 4), FMAT(3, 3), CMAT(3, 3), XMCT(4, 500)
      COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0
      COMMON /GGT/ MEDIUM
      CHARACTER KEY*3, SKEY*3
      IF (MODE .EQ. 1) THEN
        IPR(414) = 1
        IF (IPR(220) .GT. 0) THEN
          DO 10 I = 2, IPR(220)
            IF (IFL(I)(1:2) .EQ. 'FO') THEN
              IPR(414) = 1
            ELSE IF (IFL(I)(1:2) .EQ. 'FS') THEN
              IPR(414) = 2
            ELSE IF (IFL(I)(1:2) .EQ. 'DI') THEN
              IPR(414) = 3
            ELSE IF (IFL(I)(1:2) .EQ. 'SQ') THEN
              IF (IGBL(29) .LT. 0) THEN
                IPR(414) = 4
              ELSE
                IPR(414) = 3
              ENDIF
             ELSE IF (IFL(I)(1:2) .EQ. 'PT') THEN
              IPR(414) = 5
            ELSE IF (IFL(I)(1:2) .EQ. 'TN') THEN
              IPR(416) = 0
            ELSE IF (IFL(I)(1:2) .EQ. 'AB') THEN
              IPR(416) = 1
            ELSE IF (IFL(I)(1:2) .EQ. 'BI') THEN
              IPR(416) = 2
            ELSE IF (IFL(I)(1:2) .EQ. 'PE') THEN
              IPR(416) = 3
            ENDIF
   10     CONTINUE
        ENDIF
        IF (FN(1) .GT. 0.0) THEN
          PAR(273) = FN(1)
          PAR(272) = FN(1) * 4.0 / 3.0
        ENDIF
        IF (FN(2) .NE. 0.0) PAR(274) = FN(2)
        IF (FN(3) .NE. 0.0) PAR(275) = FN(3)
        IF (FN(4) .NE. 0.0) PAR(276) = FN(4)
        IF (FN(5) .GT. 0.0) PAR(277) = FN(5)
      ELSE IF (MODE .EQ. 2) THEN
        CALL PLA013 (0, 1)
        IF (LRET .EQ. 2) THEN
          LRT1 = 6
          GOTO 20
        ENDIF
        CALL PLA006 (0, IS)
        KEY  = IFL(1)(1:3)
        SKEY = IFL(2)(1:3)
        IF (IPR(220) .GT. 0) THEN
C * LIST IPR/PAR/IGBL
          IF (KEY .EQ. 'LIS') THEN
            IF (SKEY .EQ. 'PAR' .OR. SKEY .EQ. 'IPR' .OR.
     1          SKEY .EQ. 'IGB' .OR. SKEY .EQ. 'GL ')
     2          CALL PLA206 (-1, SKEY)
            LRT1 = 5
            GOTO 20
          ELSE IF (KEY(1:2) .EQ. 'DI') THEN
            LRT1 = 3
            GOTO 20
          ELSE IF (KEY .EQ. 'CPS') THEN
            XX = (FN(1) - PXS) / SCALE - FLOAT((MX - 1) / 2)
            YY = (FN(2) - PYS) / SCALE - FLOAT((MY - 1) / 2)
            WRITE (6, '(''CPS'', 2F10.3)') XX, YY
            LRT1 = 5
            GOTO 20
C * SET META TYPE
          ELSE IF (KEY .EQ. 'SET') THEN
            IF (IFL(2)(1:3) .EQ. 'MET' .AND. IPR(220) .GT. 2) THEN
              MEDIUM = 2
              CALL GGIP (-999.0, 0.0, 0.0, 6)
              LRT1 = 5
              GOTO 20
C * SET IPR/PAR/IGBL
            ELSE IF (IPR(221) .EQ. 2 .AND. IPR(220) .EQ. 2) THEN
              IF (SKEY .EQ. 'PAR' .OR. SKEY .EQ. 'IPR' .OR.
     1            SKEY .EQ. 'IGB' .OR. SKEY .EQ. 'GL ')
     2            CALL PLA206 (1, SKEY)
              LRT1 = 5
              GOTO 20
            ENDIF
          ELSE IF (KEY(1:2) .EQ. 'XR') THEN
            LRT1 = 5
            GOTO 20
          ELSE IF (KEY(1:2) .EQ. 'YR') THEN
            LRT1 = 5
            GOTO 20
          ELSE IF (KEY(1:2) .EQ. 'ZR') THEN
            PAR(276) = PAR(276) + FN(1)
            IPR(417) = 0
            IPR(221) = 0
          ELSE IF (KEY .EQ. 'END') THEN
            LRT1 = 1
            GOTO 20
          ELSE IF (KEY .EQ. 'EXI') THEN
            LRT1 = 1
            GOTO 20
          ELSE IF (KEY(1:2) .EQ. 'PT') THEN
            LRT1 = 3
            GOTO 20
          ELSE IF (KEY(1:2) .EQ. 'FO') THEN
            LRT1 = 3
            GOTO 20
          ELSE IF (KEY(1:2) .EQ. 'FS') THEN
            LRT1 = 3
            GOTO 20
          ELSE IF (KEY(1:2) .EQ. 'SQ') THEN
            LRT1 = 3
            GOTO 20
          ELSE IF (KEY .EQ. 'OMI') THEN
            LRT1 = 3
            GOTO 20
          ELSE IF (KEY .EQ. 'QUI') THEN
            LRT1 = 1
            GOTO 20
          ELSE IF (KEY(1:1) .EQ. 'U') THEN
            IPR(417) = 1
          ELSE IF (KEY(1:1) .EQ. 'D') THEN
            IPR(417) = -1
          ELSE IF (KEY .EQ. 'CON') THEN
            IPR(417) = 0
          ELSE IF (KEY .EQ. 'PLO') THEN
            IPR(417) = 0
          ELSE IF (KEY .EQ. 'SCA') THEN
            IPR(417) = 0
            IPR(418) = 0
          ELSE IF (KEY .EQ. 'F3D') THEN
            IPR(580) = 1
            LRT1     = 7
            GOTO 20
          ELSE IF (KEY .EQ. 'PLA') THEN
            LRT1 = 4
            GOTO 20
          ELSE IF (KEY(1:2) .EQ. 'CL') THEN
            IF (IPR(221) .EQ. 1) THEN
              IPR(419) = MAX (5, NINT(FN(1) * 100))
              IPR(221) = 0
              LRT1     = 6
              GOTO 20
            ENDIF
          ENDIF
        ENDIF
        IPR(416) = 1
        IF (IPR(221) .GT. 0) THEN
          PAR(278) = ABS(FN(1))
          IPR(417) = NINT(SIGN(1.0, FN(1)))
        ENDIF
        LRT1 = 2
      ENDIF
   20 RETURN
      END
      SUBROUTINE PLA253
      PARAMETER (NPVD=40000000, NP23=18000, NCT0 = 5000, NCT1 = 500000,
     1 NTC4 = 200, NCT5 = 2000, NCT6 = 100, NCT7 = NCT6 + 1,
     2 NCT8 = 2500, NCT3 =  NPVD + 2 * NP23 - 7  - 8 * NCT8 -2 *
     3 NCT5 - 6 * NCT0 - NCT1 - 3 * NTC4 * NTC4 - NCT6 * (NCT6 + 13))
      COMMON // ATOM(4, NCT0), IFLG(NCT0), JFLG(NCT0),
     1 COEFF(NCT1), XMPC(NCT8, 6), IMPC(NCT8), JMPC(NCT8), Q8(2, NCT5),
     2 FMP(NTC4, NTC4), IEXX(2, NTC4, NTC4), SMA(NCT6, NCT7),
     3 P8(12, NCT6), SK(NCT3), DXF(3), DYF(3), NAT
      COMMON /AREA/ L, T9(NCT6), N, NS, NE, ICB, JV, XX, YY, JC, NN
      COMMON /APLOT/ X, Y, SCALE, PXS, PYS, STEP, VLAK(4)
      DO 10 I = 2, N
        P1    = P8(1, I) - P8(1, I - 1)
        P2    = P8(2, I) - P8(2, I - 1)
        T9(I - 1) = SQRT(P1**2 + P2**2)
   10 CONTINUE
      DO 150 K = 1, 2
        DO 30 I = 1, N
          DO 20 J = 1, N
            SMA(I, J) = 0.0
   20     CONTINUE
   30   CONTINUE
        IF (ICB .EQ. 1) THEN
          SMA(1, 1) = 1.0
          SMA(N, N) = 1.0
          DO 40 I = 1, 2
            P8(I + 2, 1) = 1.0
            P8(I + 2, N) = 1.0
   40     CONTINUE
        ELSE IF (ICB .EQ. 2) THEN
          SMA(1, 1)     = 1.0
          SMA(N, N - 1) = 2.0
          SMA(1, 2)     = 0.5
          SMA(N, N)     = 4.0
          DO 50 I = 1, 2
            P8(I + 2, 1) = 3.0 * (P8(I, 2) - P8(I, 1)) / (2.0 * T9(1))
            P8(I + 2, N) = 6.0 * (P8(I, N) - P8(I, N - 1)) / T9(N - 1)
   50     CONTINUE
        ELSE
          PN            =  1.0
          IF (ICB .EQ. 4) PN = -1.0
          T             = T9(N - 1) / T9(1)
          SMA(1, 1)     = 2.0 + 2.0 * T
          SMA(1, 2)     = T
          SMA(1, N - 1) = PN
          TEMP          = 3.0 / T9(1)
          DO 60 I = 1, 2
            P8(I + 2, 1) = TEMP * (T * (P8(I, 2) - P8(I, 1))
     1                   + PN * (P8(I, N) - P8(I, N - 1)) / T)
   60     CONTINUE
        ENDIF
        DO 80 I = 3, N
          T3 = T9(I - 1)
          T2 = T9(I - 2)
          SMA(I - 1, I - 2) = T3
          SMA(I - 1, I - 1) = 2.0 * (T3 + T2)
          SMA(I - 1, I    ) = T2
          DO 70 J = 1, 2
            P1 = P8(J, I - 2)
            P2 = P8(J, I - 1)
            P3 = P8(J, I)
            IF (T2 .NE. 0.0 .AND. T3 .NE. 0) THEN
              VALUE = 3.0 * (T2 * (P3 - P2) / T3 + T3 * (P2 - P1) / T2)
            ELSE
              VALUE = 0.0
            ENDIF
            P8(J + 2, I - 1) = VALUE
   70     CONTINUE
   80   CONTINUE
        L = N
        IF (ICB .GE. 3) L = N - 1
        LL = L + 1
        DO 90 I = 1, L
          SMA(I, LL) = P8(K + 2, I)
   90   CONTINUE
        NN0 = L + 1
        DO 130 I0 = 1, L
          C0 = SMA(I0, I0)
          IF (C0 .NE. 1) THEN
            DO 100 J0 = I0, NN0
              SMA(I0, J0) = SMA(I0, J0) / C0
  100       CONTINUE
          ENDIF
          DO 120 J0 = 1, L
            IF (I0 .NE. J0) THEN
              C0 = SMA(J0, I0)
              IF (C0 .NE. 0.0) THEN
                DO 110 K0 = I0, NN0
                  D0 = SMA(I0, K0)
                  SMA(J0, K0) = SMA(J0, K0) - C0 * D0
  110           CONTINUE
              ENDIF
            ENDIF
  120     CONTINUE
  130   CONTINUE
        IF (ICB .GE. 3) SMA(LL, LL) = SMA(1, LL)
        DO 140 I = 2, N
          P1 = P8(K, I - 1)
          P2 = P8(K, I)
          T  = T9(I - 1)
          U1 = SMA(I - 1, LL)
          U2 = SMA(I, LL)
          P8(K + 10, I - 1) = P1
          P8(K +  8, I - 1) = U1
          P8(K +  6, I - 1) = (3.0 * (P2 - P1) / T - 2.0 * U1 - U2) / T
          P8(K +  4, I - 1) = (2.0 * (P1 - P2) / T + U1 + U2) / (T * T)
  140   CONTINUE
  150 CONTINUE
      DO 180 I = NS, NE - 1
        TT = T9(I)
        NM  = INT(TT * ABS(SCALE * 50)) + 1
        STP = TT / NM
        T   = 0.0
  160   IF (I .EQ. NS .AND. T .EQ. 0.0) THEN
          XX = P8(11, I)
          YY = P8(12, I)
          IPEN = 3
        ELSE
          IF (T .EQ. 0.0) GOTO 170
          T2 = T  * T
          T3 = T2 * T
          XX = P8(5,  I) * T3 + P8(7,  I) * T2
     1       + P8(9,  I) * T  + P8(11, I)
          YY = P8(6,  I) * T3 + P8(8,  I) * T2
     1       + P8(10, I) * T  + P8(12, I)
          IPEN = 2
        ENDIF
        SSX = (XX - 1) * SCALE + PXS
        SSY = (YY - 1) * SCALE + PYS
        IF (JV .GT. 0) THEN
          CALL GGIP (0.0, 3.0, 0.0, 0)
          CALL GGIP (SSX, SSY, 0.0, IPEN)
        ELSE
          IF (IPEN .EQ. 3) THEN
            IF (NN .EQ. 4) THEN
              CALL GGIP (0.0, 2.0, 0.0, 0)
            ELSE
              CALL GGIP (0.0, 4.0, 0.0, 0)
            ENDIF
            CALL GGIP (SSX, SSY, 0.0, 3)
          ELSE
            JC = JC + 1
            IF (JC .LT. NN) THEN
              CALL GGIP (SSX, SSY, 0.0, 2)
            ELSE
              IF (JC .EQ. (NN + NN)) JC = 0
              CALL GGIP (SSX, SSY, 0.0, 3)
            ENDIF
          ENDIF
        ENDIF
  170   T = T + STP
        IF (T .LE. TT) GOTO 160
  180 CONTINUE
      RETURN
      END
      SUBROUTINE PLA254
      PARAMETER (NPVD=40000000, NP23=18000, NCT0 = 5000, NCT1 = 500000,
     1 NTC4 = 200, NCT5 = 2000, NCT6 = 100, NCT7 = NCT6 + 1,
     2 NCT8 = 2500, NCT3 =  NPVD + 2 * NP23 - 7  - 8 * NCT8 -2 *
     2 NCT5 - 6 * NCT0 - NCT1 - 3 * NTC4 * NTC4 - NCT6 * (NCT6 + 13))
      COMMON // ATOM(4, NCT0), IFLG(NCT0), JFLG(NCT0), COEFF(NCT1),
     1 XMPC(NCT8, 6), IMPC(NCT8), JMPC(NCT8), Q8(2, NCT5),
     2 FMP(NTC4, NTC4), IEXX(2, NTC4, NTC4), SMA(NCT6, NCT7),
     3 P8(12, NCT6), SK(NCT3), DXF(3), DYF(3), NAT
      COMMON /APLOT/ X, Y, SCALE, PXS, PYS, STEP, VLAK(4)
      COMMON /AINPUT/ NS, NE, MX, MY, NXP, NXM, NYP, NYM, PHI,
     1  XN(3, 4), FMAT(3, 3), CMAT(3, 3), XMCT(4, 500)
      COMMON /ASESCH/ NT, IN, IXY, IX, IY, IV
      COMMON /AFIND/  Y9(4), C8(4, 5), R, N
      KK = 0
      NT = NT + 1
      IF (NT .GT. NCT5) STOP 'NT Out-of-Range-PROBLEM'
      IF (IXY .NE. 2) THEN
        IF (IX .EQ. 1) KK = 1
        DO 10 I = 1, 4
          J = IX + I - 2 + KK
          IF (J .EQ. MX + 1) KK = 2
          IF (KK .NE. 2) THEN
            IF (J .GT. 0 .AND. IY .GT. 0) THEN
              Y9(I) = FMP(J, IY)
            ELSE
              Y9(I) = 0.0
            ENDIF
          ENDIF
   10   CONTINUE
      ELSE
        IF (IY .EQ. 1) KK = 1
        DO 20 I = 1, 4
          J = IY + I - 2 + KK
          IF (J .EQ. MY + 1) KK = 2
          IF (KK .NE. 2) THEN
            IF (J .GT. 0 .AND. IY .GT. 0) THEN
              Y9(I) = FMP(IX, J)
            ELSE
              Y9(I) = 0.0
            ENDIF
          ENDIF
   20   CONTINUE
      ENDIF
      IF (KK .NE. 0) THEN
        N = 3
        DO 30 I = 1, 3
          X        = I
          C8(I, 1) = X * X
          C8(I, 2) = X
          C8(I, 3) = 1.0
          C8(I, 4) = Y9(I)
   30   CONTINUE
      ELSE
        N = 4
        DO 40 I = 1, 4
          X        = I
          C8(I, 1) = X * X * X
          C8(I, 2) = X * X
          C8(I, 3) = X
          C8(I, 4) = 1.0
          C8(I, 5) = Y9(I)
   40   CONTINUE
      ENDIF
      NN = N + 1
      DO 80 I = 1, N
        C = C8(I, I)
        DO 50 J = I, NN
          C8(I, J) = C8(I, J) / C
   50   CONTINUE
        DO 70 J = 1, N
          IF (I .NE. J) THEN
            C = C8(J, I)
            DO 60 K = I, NN
              D        = C8(I, K)
              C8(J, K) = C8(J, K) - C * D
   60       CONTINUE
          ENDIF
   70   CONTINUE
   80 CONTINUE
      IF (KK .NE. 0) THEN
        RR = KK
        A  = C8(1, 4)
        B  = C8(2, 4)
        C  = C8(3, 4) - IV
        IF (ABS(A) .LT. 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 .GE. KK .AND. R1 .LE. KK + 1) R = R1 - RR
        ENDIF
        IF (R2 .GE. KK .AND. R2 .LE. KK + 1) R = R2 - RR
      ELSE
        PI  = 3.141592
        PT  = 1.0 / 3.0
        PF  = 0.5
        EE  = 1.E-20
        AA  = C8(1, 5)
        BB  = C8(2, 5)
        ISW = 1
        IF (ABS(AA) .LE. 1.E-5) THEN
          AA  = 1.0
          ISW = 2
          IF (ABS(BB) .LE. 1.E-20) ISW = 3
        ENDIF
        A = BB / AA / 3
        B = C8(3, 5) / AA
        C = (C8(4, 5) - IV) / AA
        IF (ISW .EQ. 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) .GE. EE) THEN
            IF (PQ .LE. 0.0) THEN
              R  = 2.0 * SQRT(-P)
              XX = Q / P / R
              IF ((1.0 - XX**2) .EQ. 0) THEN
                TH = 0
              ELSE
                TH = - ATAN(XX / SQRT(- XX * XX + 1.0)) + 1.5708
                TH = TH / 3.0
              ENDIF
              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 .GE. 2.0 .AND. R1 .LE. 3.0) R = R1 - 2.0
              IF (R2 .GE. 2.0 .AND. R2 .LE. 3.0) R = R2 - 2.0
              IF (R3 .GE. 2.0 .AND. R3 .LE. 3.0) R = R3 - 2.0
              GOTO 110
            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
              GOTO 110
            ENDIF
          ELSE
            IF (EE .GE. ABS(P)) THEN
              R = - A - 2.0
              GOTO 110
            ELSE
              R  = - 1.0 * ABS(PF * Q) ** PT * SIGN(1.0, Q)
              R1 = 2.0 * R - A
              R2 = - R - A
            ENDIF
          ENDIF
          GOTO 90
        ELSE IF (ISW .EQ. 2) THEN
          A  = A * 3.0
          SB = B * B - 4 * A * C
          IF (SB .LT. 0.0) SB = 0.0
          SB = SQRT(SB)
          R1 = (- B + SB) / (2.0 * A)
          R2 = (- B - SB) / (2.0 * A)
          GOTO 90
        ELSE
          IF (B .NE. 0.0) THEN
            R2 = - C / B
          ELSE
            R2 = 0.0
          ENDIF
          GOTO 100
        ENDIF
   90   IF (R1 .GE. 2.0 .AND. R1 .LE. 3.0) R = R1 - 2.0
  100   IF (R2 .GE. 2.0 .AND. R2 .LE. 3.0) R = R2 - 2.0
  110   IF (R .LT. 0.0 .OR. R .GT. 1.0)
     1      R = (IV - Y9(2)) / (Y9(3) - Y9(2))
      ENDIF
      IF (IXY .NE. 2) THEN
        X = IX + R
        Y = IY
      ELSE
        X = IX
        Y = IY + R
      ENDIF
      Q8(1, NT) = X
      Q8(2, NT) = Y
      RETURN
      END
      FUNCTION PLA260 (NELI, NELJ)
      PLA260 = 0.0
      IF ((NELI .EQ.  10 .AND. NELJ .EQ.  10) .OR.
     1    (NELI .EQ.  11 .AND. NELJ .EQ.  11) .OR.
     2    (NELI .EQ.  30 .AND. NELJ .EQ.  30) .OR.
     3    (NELI .EQ.  59 .AND. NELJ .EQ.  59) .OR.
     4    (NELI .EQ.  94 .AND. NELJ .EQ.  85) .OR.
     5    (NELI .EQ.  85 .AND. NELJ .EQ.  94) .OR.
     6    (NELI .EQ. 103 .AND. NELJ .EQ. 103) .OR.
     7    (NELI .EQ.  10 .AND. NELJ .EQ.  11) .OR.
     8    (NELI .EQ.  11 .AND. NELJ .EQ.  10)) PLA260 = -1.0
      RETURN
      END
      SUBROUTINE PLA261 (LINE)
      COMMON /FNAME/ KNM(8), KXT, KNM16
      COMMON /NAMES/ NAME(8), EXTENS, PROGNM, FNLU1, FNLU16, RDTYPE
      CHARACTER NAME*80, EXTENS*9, PROGNM*28, FNLU1*80, FNLU16*80,
     1          RDTYPE*7
      CHARACTER LINE*80
      IB   = 1
      IE   = 80
      KNMM = 70
      KXTM = 9
      KXT = 3
      KB  = IB
      KE  = IE
      CALL GEN039 (0, LINE, IB, IE, KB, KE)
      IF (KE .GE. KB) THEN
        KD = INDEX (LINE(KB : KE), '.')
        IF (KD .NE. 0) THEN
          IF (KB + KD - 1 .EQ. KE) THEN
            KE  = KE - 1
          ELSE
            EXTENS = LINE(KB + KD : KE)
            KXT    = KE - KB - KD + 1
            KE     = KB + KD - 2
          ENDIF
        ELSE
          STOP 'No File Extension Found on Filename'
        ENDIF
      ENDIF
      IF (KB .LE. KE) THEN
        KNM(1) = KE - KB + 1
        IF (KNM(1) .GT. KNMM) STOP 'Filename too long'
        IF (KXT .GT. KXTM) STOP 'File-extention too long'
        IF (EXTENS(1:3) .EQ. 'eld') STOP 'name.eld not allowed'
        DO 10 I = 1, 8
          NAME(I) = LINE(KB : KE)
          KNM(I)  = KNM(1)
   10   CONTINUE
      ENDIF
      RETURN
      END
      SUBROUTINE PLA268 (NQ)
      PARAMETER (NP12=600,NP13=500,NP17=99,NP36=1000,NP38=125,NP39=30)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /ALIASES/ ALAB(NP36), BLAB(NP36)
      CHARACTER ALAB*7, BLAB*7, NQ*7
      DO 10 I = 1, IGBL(71)
        IF (BLAB(I) .EQ. NQ) THEN
          NQ = ALAB(I)
          GOTO 20
        ENDIF
   10 CONTINUE
   20 RETURN
      END
      SUBROUTINE PLA269 (N)
      PARAMETER (NP4=9,NP10=16,NP12=600,NP13=500,NP17=99,NP22=256,
     1 NP38=125,NP39=30)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /PAGEIN/ INDEXP(25), INDP
      COMMON /PAGENM/ PAGET, PAGEIND(25)
      CHARACTER PAGET*8, PAGEIND*8
      IF (N .EQ. -999) THEN
        IF (IGBL(63) .GT. 2) THEN
          WRITE (LU7, 99998)
          DO 10 I = 1, INDP
            WRITE (LU7, 99997) INDEXP(I), PAGEIND(I)
   10     CONTINUE
          WRITE (LU7, 99996)
          IPR(83) = INDP + 4
        ENDIF
        GOTO 20
      ENDIF
      IF (N .GT. 0) THEN
        IPR(83) = IPR(83) + N
        IF (IPR(83) .LE. IGBL(102)) GOTO 20
      ENDIF
      IPR(83) = IABS(N) + 3
      IF (IGBL(63) .GT. 2) THEN
        IGBL(49) = IGBL(49) + 1
        WRITE (LU7, 99999) CHAR(12), JID(1:10), PAGET, IGBL(49)
        IF (INDP .EQ. 0) THEN
          INDP = 1
          PAGEIND(1) = PAGET
          INDEXP(1)  = IGBL(49)
        ELSE
          IF (PAGET .NE. PAGEIND(INDP)) THEN
            INDP = INDP + 1
            PAGEIND(INDP) = PAGET
            INDEXP(INDP)  = IGBL(49)
          ENDIF
        ENDIF
      ENDIF
   20 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 PLA278 (NP, XP, LU)
      DIMENSION XP(3, 12), VXYZ(6), D(3), DM(20), IH(3)
      CHARACTER POLY*11
      DO 10 I = 1, NP
        DM(I) = SQRT(XP(1, I)**2 + XP(2, I)**2 + XP(3, I)**2)
   10 CONTINUE
      VOL    = 0.0
      NP1    = NP - 1
      NP2    = NP - 2
      SUMTH  = 0.0
      SUMTH2 = 0.0
      NA     = 0
      DO 110 I = 1, NP2
        IH(1) = I
        DO 100 J = I + 1, NP1
          IH(2) = J
          DO 20 K = 1, 3
            VXYZ(K) = XP(K, J) - XP(K, I)
   20     CONTINUE
          DO 90 K = J + 1, NP
            IH(3) = K
            DO 30 N = 1, 3
              VXYZ(N + 3) = XP(N, K) - XP(N, I)
   30       CONTINUE
            CALL GEN008 (VXYZ(1), VXYZ(4), D, 0)
            AREA = 0.5 * SQRT(GEN009 (D, D))
            Z0   = 0.5 * (XP(1, I) * D(1) + XP(2, I) * D(2)
     1           + XP(3, I) * D(3)) / AREA
            IF (ABS(Z0) .LT. 1.0E-5) GOTO 90
            FACTOR = 3.0
            DO 40 L = 1, NP
              IF (L .NE. I .AND. L .NE. J .AND. L .NE. K) THEN
                Z = 0.5 * ((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
                IF (Z * Z0 .LT. -0.001) GOTO 90
                IF (ABS(Z * Z0) .LT. 0.001) THEN
                  FACTOR = 6.0
                ENDIF
              ENDIF
   40       CONTINUE
            DO 50 L = 1, 3
              D(L) = D(L) / (AREA * 2.0)
   50       CONTINUE
            VOL = VOL + AREA * ABS(Z0) / FACTOR
            DO 80 L = 1, 2
              NM = IH(L)
              DO 70 M = L + 1, 3
                MN   = IH(M)
                TEMP = 0.0
                DO 60 N = 1, 3
                  TEMP = TEMP + XP(N, NM) * XP(N, MN)
   60           CONTINUE
                TEMP   = TEMP / (DM(NM) * DM(MN))
                TEMP   = 57.2958 * ATAN2(SQRT(ABS(1.0 - TEMP * TEMP)),
     1                   TEMP)
                SUMTH  = SUMTH  + TEMP
                SUMTH2 = SUMTH2 + TEMP**2
   70         CONTINUE
   80       CONTINUE
            NA = NA + 3
   90     CONTINUE
  100   CONTINUE
  110 CONTINUE
      SUM = 0.0
      DO 120 I = 1, NP
        SUM = SUM + DM(I)**2
  120 CONTINUE
      IF (NP .EQ. 6) THEN
        CONS  = 0.75
        CONS2 = 90.0
        POLY  = 'Octahedral '
      ELSE IF (NP .EQ. 4) THEN
        CONS  = 9.0 * SQRT(3.0) / 8.0
        CONS2 = 109.45
        POLY  = 'Tetrahedral'
      ELSE
        CALL PLA269 (2)
        WRITE (LU, 99998) VOL
        GOTO 130
      ENDIF
      IF (VOL .GT. 1.0) THEN
        VLO    = EXP (2.0 * ALOG (CONS * VOL) / 3.0)
        QE     = SUM / (NP * VLO)
        NA     = (NA + 1) / 2
        SUMTH2 = SUMTH2 / 2
        SUMTH  = SUMTH / 2
        SIGA   = (SUMTH2 - 2.0 * CONS2 * SUMTH + NA * CONS2**2)
     1         / (NA - 1)
        CALL PLA269 (2)
        WRITE (LU, 99999) POLY, VOL, QE, SIGA
      ENDIF
  130 RETURN
99999 FORMAT(/, A, ' Volume', F7.3,
     1          ' Ang**3, Quadratic Elongation', F7.3,
     2          ', Angle Variance', F7.2, ' Deg**2',
     3          ' [K.Robinson +, Science 1971,172,567-570]')
99998 FORMAT (/, 'Polyhedral Volume', F7.3, ' Ang**3')
      END
      SUBROUTINE PLA279 (LU)
      PARAMETER (NP4=9,NP10=16,NP12=600,NP13=500,NP17=99,NP22=256,
     1 NP38=125,NP39=30)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /NAMES/ NAME(8), EXTENS, PROGNM, FNLU1, FNLU16, RDTYPE
      CHARACTER NAME*80, EXTENS*9, PROGNM*28, FNLU1*80, FNLU16*80,
     1          RDTYPE*7
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      CALL GEN108 (LU, 0)
      IF (IGBL(15) .GE. 0) THEN
        IGBL(29) = 0
        DO 10 I = 1, 40
          READ (LU, 99999, ERR = 20, END = 20) PRBUF
          IF (PRBUF(1:5) .EQ. 'data_') DID = PRBUF(6:14)
          IF (PRBUF(1:11) .EQ. '# h,k,l, Fo') THEN
            IGBL(29) = 3
            RDTYPE   = 'NRCVAX'
          ELSE IF (PRBUF(1:13) .EQ. '# h,k,l, 10*F') THEN
            IGBL(29) = 4
            RDTYPE   = 'MOLEN'
          ELSE IF (INDEX (PRBUF, 'CRYSTALS') .NE. 0) THEN
            IGBL(29) = 5
            RDTYPE   = 'CRYSTAL'
          ELSE IF (INDEX (PRBUF, '_refln_intensity_meas') .NE. 0) THEN
            IGBL(29) = 9
            RDTYPE   = 'JANA'
          ELSE IF (INDEX (PRBUF, '_refln_F_squared') .NE. 0) THEN
            IF (IGBL(29) .EQ. 5) IGBL(29) = 8
          ELSE IF (INDEX (PRBUF, '_shelx_refln_list_code') .NE. 0) THEN
            IF (INDEX (PRBUF, '3') .NE. 0) THEN
              IGBL(29) = 21
              RDTYPE   = 'LIST3'
            ELSE IF (INDEX (PRBUF, '4') .NE. 0) THEN
              IGBL(29) =  1
              RDTYPE = 'SHELXL'
            ELSE IF (INDEX (PRBUF, '6') .NE. 0) THEN
              IGBL(29) = 22
              RDTYPE   = 'LIST5'
            ENDIF
          ENDIF
   10   CONTINUE
   20   IF (IGBL(29) .EQ. 0) THEN
          CALL GEN108 (LU, 0)
   30     READ (LU, 99999, ERR = 70, END = 70) PRBUF
          IF (PRBUF(1:5) .EQ. 'data_') THEN
            DID = PRBUF(6:14)
            GOTO 30
          ENDIF
          IF (PRBUF(1:5) .EQ. '     ') GOTO 30
          IF (PRBUF(1:5) .EQ. 'loop_') THEN
            DO 40 I = 1, 10
              READ (LU, 99999, ERR = 70, END = 70) PRBUF
              IF (PRBUF(23:23) .EQ. '.') THEN
                IGBL(29) = 6
                RDTYPE   = 'TEXSAN1'
                GOTO 60
              ELSE IF (PRBUF(22:22) .EQ. '.') THEN
                IGBL(29) = 10
                RDTYPE   = 'TEXSAN2'
                GOTO 60
              ELSE IF (PRBUF(18:18) .EQ. '.') THEN
                IGBL(29) = 7
                RDTYPE   = 'MolEN1'
                GOTO 60
              ENDIF
   40       CONTINUE
            IGBL(29) = 2
            RDTYPE   = 'XTAL-F'
          ELSE
            IF (PRBUF(88:88) .NE. ' ') THEN
              IGBL(29) = -1
              RDTYPE = 'HKL-EXT'
            ENDIF
            IGBL(37) = 0
            DO 50 K = 1, 48
              IF (PRBUF(81 - K:81 - K) .NE. ' ' .AND.
     1            PRBUF(81 - K:81 - K) .NE. CHAR(13)) THEN
                IF (K .LT. 10) THEN
                  IGBL(37) = 1
                  GOTO 60
                ELSE
                  IGBL(37) = 2
                  GOTO 60
                ENDIF
              ENDIF
   50       CONTINUE
          ENDIF
        ENDIF
   60   CALL GEN108 (LU, 0)
      ENDIF
   70 RETURN
99999 FORMAT (A)
      END
      SUBROUTINE PLA280 (STR)
      COMMON /CGGT/ IGGT
      CHARACTER IGGT*80
      CHARACTER STR*(*)
      LENM = MIN (80, LEN(STR))
      IGGT = STR(1:LENM)
      RETURN
      END
      SUBROUTINE PLA281 (MODE)
      PARAMETER (NP12=600,NP13=500,NP17=99,NP38=125,NP39=30)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
C * RESET INPUT
      IF (IABS(IGBL(8)) .EQ. 3 .OR. IABS(IGBL(8)) .EQ. 4) THEN
        IPR(220) = 0
        IPR(221) = 1
        FN(1) = IGBL(54)
        CALL PLA011
        IF (IABS(IGBL(8)) .NE. 4) IGBL(24) = 0
        CALL PLA280 ('END')
        IF (MODE .NE. 0) IGBL(1) = 1
      ELSE
        IGBL(54) = 0
        CALL PLA280 ('RESTART')
        IF (MODE .NE. 0) IGBL(1) = 2
      ENDIF
      IF (MODE .EQ. 0) THEN
        CALL GEN108 (LU20, 0)
        IGBL(31) = 0
      ENDIF
      RETURN
      END
      SUBROUTINE PLA282 (MODE, Y, W, N, LU)
C * MODE = 1: SUBROUTINE GENERATES A HALFNORMAL PROBABILITY PLOT.
C * MODE = 2: SUBROUTINE GENERATES A NORMAL (GAUSSIAN) PROBABILITY PLOT
      DIMENSION Y(*), W(*)
      CALL GEN035 (Y, 1, N)
      CALL GEN117 (N, W)
      DO 10 I = 1, N
        Q = W(I)
        IF (MODE .EQ. 1) Q = (Q + 1.0) / 2.0
        CALL GEN116 (Q, W(I))
   10 CONTINUE
      CALL GEN118 (MODE, Y, W, N, LU)
      WRITE (LU, 99999)
      RETURN
99999 FORMAT (/, 'Normal-Probability-Plot Analysis. See: S.C.Abrahams',
     1      ' & E.T.Keve (1971). Acta Cryst. A27, 157-165.', //,
     2      'Vertical: Experimental Data, Horizontal: Theoretical Data')
      END
      SUBROUTINE PLA283 (MODE, MZ, N, CDUM)
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118,
     1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP22=256,
     2 NP25=99,NP29=63,NP38=125,NP39=30,NP41=200,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9),
     1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10),
     2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10),
     3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      DIMENSION IENSS(NP10)
      CHARACTER JDM*80, CDUM*(*)
      XKZ = 0
      KZ  = 0
      N = 81
      IF (MODE .NE. 0) THEN
        KB = MODE
        KE = MODE
      ELSE IF (MODE .EQ. 0) THEN
        KB = 4
        KE = IPR(488)
      ENDIF
      DO 50 K0 = KB, KE
        K1 = KB + KE - K0
        IMODE = 0
        DO 10 I = 1, IAN
          IF (IEN(I) .EQ. 2) THEN
            IF (CONT(I, K1) .GT. 0.001) THEN
              IMODE = 1
              GOTO 20
            ENDIF
          ENDIF
   10   CONTINUE
   20   CALL GEN123 (IMODE, IEN, IENSS, IEL, IAN)
        N0 = 81
        DO 30 I = 1, IAN
          K = IENSS(IAN + 1 - I)
          IF (LMT(K, 1) .NE. 'Cg') THEN
            CKK1 = CONT(K, K1)
            IF (CKK1 .GT. 0.001) THEN
              M = NINT(CKK1 / MZ)
              IF (ABS (M * MZ - CKK1) .LT. 0.005) THEN
                IP = 0
                IF (M .GT. 1) THEN
                  CALL GEN040 (M, NQ1, IP)
                  N0 = N0 - IP
                  JDM(N0:N0 + IP - 1) = NQ1(1:IP)
                ENDIF
              ELSE
                CKK1 = CKK1 / MZ
                WRITE (NQ1, '(F7.2)') CKK1
                IF (CKK1 .LT. 10.0) THEN
                  IP = 4
                ELSE IF (CKK1 .LT. 100.0) THEN
                  IP = 5
                ELSE
                  IP = 6
                ENDIF
                N0 = N0 - IP
                JDM(N0:N0 + IP - 1) = NQ1 (8 - IP:7)
              ENDIF
              N0 = N0 - 1
              JDM(N0:N0) = LMT(K, 1)(2:2)
              IF (LMT(K, 1)(1:1) .NE. CHAR(32)) THEN
                N0 = N0 - 1
                JDM(N0:N0) = LMT(K, 1)(1:1)
              ENDIF
              N0         = N0 - 1
              JDM(N0:N0) = CHAR(32)
            ENDIF
          ENDIF
   30   CONTINUE
        IF (N0 .LT. 81) THEN
          IF (JDM(N0:N0) .EQ. CHAR(32)) N0 = N0 + 1
        ENDIF
        IF (MODE .EQ. 0) THEN
          XKZ = CONT(NP10 + 1, K1) * 2 / IPR(260)
          KZ  = NINT(CONT(NP10 + 1, K1) * 2) / IPR(260)
          IF (ABS(XKZ - KZ) .GT. 0.001) KZ = 0
          IF (KZ .NE. 2) THEN
            IF (N .EQ. 1) GOTO 60
            N = N - 1
            CDUM(N:N) = ')'
          ENDIF
        ENDIF
        DO 40 N1 = N0, 80
          N2 = 80 + N0 - N1
          IF (N .EQ. 1) GOTO 60
          N  = N  - 1
          CDUM(N:N) = JDM(N2:N2)
   40   CONTINUE
        IF (MODE .EQ. 0) THEN
          IF (KZ .NE. 2) THEN
            IF (KZ .EQ. 0) THEN
              IP = 5
              WRITE (NQ1(1:IP), 99999) XKZ / 2.0
              IF (NQ1(4:5) .EQ. '00') THEN
                IP = 3
              ELSE IF (NQ1(5:5) .EQ. '0') THEN
                IP = 4
              ENDIF
            ELSE IF (KZ .EQ. 1) THEN
              IP        = 3
              NQ1(1:IP) = '0.5'
            ELSE IF (KZ .EQ. 3) THEN
              IP        = 3
              NQ1(1:IP) = '1.5'
            ELSE IF (KZ .EQ. 5) THEN
              IP        = 3
              NQ1(1:IP) = '2.5'
            ELSE
              KZZ = KZ / 2
              CALL GEN040 (KZZ, NQ1, IP)
            ENDIF
            IF (N .LT. IP + 2) GOTO 60
            N = N - 1
            CDUM(N:N) = '('
            CDUM(N - IP:N - 1) = NQ1(1:IP)
            N = N - IP
          ENDIF
          IF (K0 .NE. KE) THEN
            IF (N .LE. 2) GOTO 60
            N = N - 1
            CDUM(N:N) = CHAR(32)
            N = N - 1
            CDUM(N:N) = ','
          ENDIF
        ENDIF
   50 CONTINUE
      IF (N .GT. 1) CALL GEN038 (CDUM, 1, N - 1)
   60 RETURN
99999 FORMAT (F5.3)
      END
      SUBROUTINE PLA285 (MODE, LO, STR)
      CHARACTER STR*(*)
      IF (MODE .EQ. 0) THEN
        WRITE (LO, 99999) STR
      ELSE
        WRITE (LO, 99998) STR
      ENDIF
      RETURN
99999 FORMAT (A, $)
99998 FORMAT (/, A, $)
      END
      SUBROUTINE PLA286
      PARAMETER (NP12=600,NP13=500,NP17=99, NP38=125,NP39=30)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /FNAME/ KNM(8), KXT, KNM16
      COMMON /NAMES/ NAME(8), EXTENS, PROGNM, FNLU1, FNLU16, RDTYPE
      CHARACTER NAME*80, EXTENS*9, PROGNM*28, FNLU1*80, FNLU16*80,
     1          RDTYPE*7
      LOGICAL EXST16
      IF (EXTENS(1:3) .EQ. 'cif' .OR. EXTENS(1:3) .EQ. 'CIF' .OR.
     1    EXTENS(1:3) .EQ. 'fcf' .OR. EXTENS(1:3) .EQ. 'FCF') THEN
        KNM16    = KNM(7) + 4
        FNLU16   = NAME(7)(1:KNM(7)) //'.fcf'
        RDTYPE   = 'FCF'
        IGBL(15) = 1
        INQUIRE (FILE = FNLU16, EXIST = EXST16)
        IF (.NOT. EXST16) THEN
          FNLU16   = NAME(7)(1:KNM(7)) //'.FCF'
          INQUIRE (FILE = FNLU16, EXIST = EXST16)
          IF (.NOT. EXST16) THEN
            RDTYPE = 'HKL'
            FNLU16 = NAME(4)(1:KNM(4)) //'.hkl'
            INQUIRE (FILE = FNLU16, EXIST = EXST16)
            IF (.NOT. EXST16) THEN
              FNLU16 = NAME(4)(1:KNM(4)) //'.HKL'
              INQUIRE (FILE = FNLU16, EXIST = EXST16)
              IF (.NOT. EXST16) IGBL(15) = -1
            ENDIF
          ENDIF
        ENDIF
      ELSE
        FNLU16 = NAME(4)(1:KNM(4)) //'.hkl'
        RDTYPE = 'HKL'
        KNM16  = KNM(4) + 4
        INQUIRE (FILE = FNLU16, EXIST = EXST16)
        IF (.NOT. EXST16) THEN
          FNLU16 = NAME(4)(1:KNM(4)) //'.HKL'
          INQUIRE (FILE = FNLU16, EXIST = EXST16)
          IF (.NOT. EXST16) THEN
            KNM16  = KNM(7) + 4
            FNLU16 = NAME(7)(1:KNM(7)) //'.fcf'
            RDTYPE = 'FCF'
            INQUIRE (FILE = FNLU16, EXIST = EXST16)
            IF (.NOT. EXST16) THEN
              FNLU16 = NAME(7)(1:KNM(7)) //'.FCF'
              INQUIRE (FILE = FNLU16, EXIST = EXST16)
              IF (.NOT. EXST16) IGBL(15) = -1
            ENDIF
          ENDIF
        ENDIF
      ENDIF
C * OPEN & DETERMINE REFLECTION FILE TYPE
      OPEN (UNIT = LU16, FILE = FNLU16, STATUS = 'OLD', ERR = 70)
      CALL PLA279 (LU16)
   70 RETURN
      END
      SUBROUTINE PLA287 (MODE1, MODE2, MODE3)
      COMMON /SFCLC/ NATO, NNG(3), NGRID
      CALL PLA069
      IF (MODE2 .NE. 0) CALL PLA073 (1)
      CALL PLA029
      IF (MODE1 .NE. 0) CALL PLA130 (NATO, MODE3)
      RETURN
      END
      SUBROUTINE PLA288 (MODE)
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,
     1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NPVD=40000000,
     2 NP22=256,NP23=18000,NP25=99,NP29=63,NP38=125,NP39=30,NP41=200,
     3 NP45=2048,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /Q/ ICL, IFL(NP17)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON // JNSC(2, NP23), VOID(NPVD)
      DASH = 1.0
      NFN  = 0
      NCG  = 0
      DO 20 I = 2, IPR(220)
        IF (IFL(I) .EQ. 'DASH') THEN
          DASH = -1.0
        ELSE IF (IFL(I) .EQ. 'NODASH') THEN
          DASH = 2.0
        ELSE IF (IFL(I) .EQ. 'LDASH') THEN
          DASH = -2.0
        ELSE IF (IFL(I) .EQ. 'TO') THEN
          NCG  = 1
          IPR(64) = IPR(64) + 1
          ICGA = IPR(39) + IPR(64)
          DO 10 J = 1, 6
            XXO(ICGA, J) = 0.0
            XSD(ICGA, J) = 0.0
   10     CONTINUE
        ELSE
          CALL PLA046 (4, IFL(I), IENM, LBB, LBC, LBD,
     1                 XNQNR, YNQNR, NIEN)
          IF (NIEN .LT. 0) THEN
            CALL PLA015 (0, 28)
            GOTO 1000
          ENDIF
          NFN       = NFN + 1
          IATC(NFN) = NIEN
        ENDIF
   20 CONTINUE
      DO 40 J = 2, NFN
        CALL PLA100 (IATC(1), IATC(J), MODE, DASH)
        IF (NCG .EQ. 1) THEN
          DO 30 K = 1, 6
            XXO(ICGA, K) =  XXO(ICGA, K) + XXO(IATC(J), K)
            XSD(ICGA, K) =  XSD(ICGA, K) + XSD(IATC(J), K)
   30     CONTINUE
        ENDIF
   40 CONTINUE
      IF (NCG .EQ. 1) THEN
        IFG(ICGA) = IFG(IATC(2))
        JFG(ICGA) = JFG(IATC(2))
        CALL GEN040 (IPR(64), NQ2, IP)
        NQ1(1:7)      = 'CG     '
        NQ1(3:2 + IP) = NQ2(1:IP)
        CALL PLA046 (1, NQ1, IENM, LBB, LBC, LBD,
     1               XNQNR, YNQNR, NIEN)
        XLAB(ICGA) = XNQNR
        DO 50 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) * (NP4 + 15) + K) =
     1              XXO(ICGA, K)
          VOID((IPR(39) + IPR(64) - 1) * (NP4 + 15) + K + 6) =
     1              XSD(ICGA, K)
   50   CONTINUE
        WRITE (LU6, 99999) NQ1, (XXO(ICGA, K), K = 1, 6),
     1                    (SQRT(XSD(ICGA, K)), K = 1, 6)
        CALL PLA100 (IATC(1), ICGA, 2, -1.0)
      ENDIF
 1000 RETURN
99999 FORMAT (/, ':: ', A, 6F10.4, /, 10X, 6F10.4)
      END
      SUBROUTINE PLA289 (X, Y, R, N)
      PARAMETER (NP12=600,NP13=500,NP17=99,NP38=125,NP39=30)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      RT0 = GL(6) / N
      CALL GGIP (X + R, Y, 0.0, 3)
      DO 10 I = 1, N
        XGGIP = X + R * COS(I * RT0)
        YGGIP = Y + R * SIN(I * RT0)
        CALL GGIP (XGGIP, YGGIP, 0.0, 2)
   10 CONTINUE
      CALL GGIP (0.0, 0.0, 0.0, 3)
      RETURN
      END
      SUBROUTINE PLA290 (MODE)
      PARAMETER (NP12=600,NP13=500,NP17=99,NP38=125,NP39=30)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /PL290/ TPMTDM, TOMTCM
      IF (MODE .EQ. 0) THEN
        TPMTDM = 0.0
        TOMTCM = 0.0
      ELSE
        WRITE (LU6, 99999) TPMTDM, PAR(77), TOMTCM, PAR(78)
        WRITE (LU7, 99999) TPMTDM, PAR(77), TOMTCM, PAR(78)
      ENDIF
      RETURN
99999 FORMAT (/, ':: Max(TPRIM - TDIFF) and Default:', 2F10.3,
     1        /, ':: Max(THobs - THcal) and Default:', 2F10.3, /)
      END
      SUBROUTINE PLA291 (TPRIM, TDIFF, THETA, THHKL, ITEST)
      PARAMETER (NP12=600,NP13=500,NP17=99,NP38=125,NP39=30)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      CHARACTER PRBUF*132
      COMMON /PL290/ TPMTDM, TOMTCM
      ITEST  = 0
      TPMTD  = ABS (TPRIM - TDIFF)
      TOMTC  = ABS (THETA - THHKL)
      TPMTDM = MAX (TPMTDM, TPMTD)
      TOMTCM = MAX (TOMTCM, TOMTC)
      IF (TPMTD .GT. PAR(77) .OR. TOMTC .GT. PAR(78)) THEN
        IF (IPR(363) .EQ. 1) THEN
          BACKSPACE LU16
          READ (LU16, 99998) PRBUF
          WRITE (LU6, 99999) TPRIM, TDIFF, THETA, THHKL, PRBUF(1:80)
          WRITE (LU7, 99999) TPRIM, TDIFF, THETA, THHKL, PRBUF(1:80)
          ITEST = 1
        ENDIF
      ENDIF
      RETURN
99999 FORMAT (/, ':: Bad Direction Cosines:', 4F9.4, ' for:', /, A, //,
     1 ':: Check Cell Dimensions/Transformation and Wavelength !!', //,
     2 ':: The First  number [i.e. dot product H.P (reversed)] and', /,
     3 ':: The Second number [i.e. dot product H.S] should be equal',/,
     4 ':: The Third  number [i.e. Theta(Calc)from Dir.Cos.] and', /,
     5 ':: The Fourth number [i.e. Theta(obs) from Cell Dimensions]',/,
     6 '::                    should be equal within error',//,
     7 ':: Check may be overruled with NOCHECK option (DANGEROUS)', //)
99998 FORMAT (A)
      END
      SUBROUTINE PLA292 (LUN0, LUN1, LUN2, IDTYP, NREF)
      CHARACTER LINE*80
      COMMON /MOLEN/ FMOL
      CHARACTER FMOL*19
      IF (IDTYP .NE. 0) THEN
        FMOL = '(I4,2I3,2F7.0,F6.0)'
        IF (IDTYP .EQ. 7) FMOL = '(3I4,3F8.0)'
C * IDTYP = 1 - FCF
C * IDTYP = 4 - MOLEN
C * IDTYP = 5 - CRYSTALS(F)
C * IDTYP = 6 - TEXSAN
C * IDTYP = 7 - MOLEN1 VARIANT
C * IDTYP = 8 - CRYSTALS(I)
C * IDTYP = 9 - JANA
C * IDTYP = 21 - SHELXL - LIST 3
        IFTYPE = 0
        SCF    = 0.0
        FKMX   = 0.0
        NREF   = 0
        DO 50 I = 1, 2
          N = 0
          IF (I .EQ. 2) THEN
            IF (FKMX .LT. 999999.0) THEN
              SCF = 100.0
            ELSE
              SCF = FLOAT(99999990) / FKMX
            ENDIF
          ENDIF
          REWIND LUN1
          REWIND LUN2
   10     READ (LUN1, 99996, END = 50) LINE
          IF (IDTYP .EQ. 1) THEN
            IF (INDEX(LINE, 'loop_') .EQ. 0) GOTO 10
            IFTYPE = 0
   20       READ (LUN1, 99996, END = 50) LINE
            IF (INDEX(LINE,  '_refln_F_squared_calc') .NE. 0) THEN
              IFTYPE = IFTYPE * 10 + 2
            ELSE IF (INDEX(LINE, '_refln_F_squared_meas') .NE. 0)
     1        THEN
              IFTYPE = IFTYPE * 10 + 1
            ENDIF
            IF (INDEX(LINE, '_refln_observed_status') .NE. 0) THEN
              READ (LUN1, 99996, END = 50) LINE
              IF (INDEX(LINE, '_refln_sint/lambda') .EQ. 0)
     1           BACKSPACE (LUN1)
              GOTO 40
            ENDIF
            GOTO 20
C * MOLEN
          ELSE IF (IDTYP .EQ. 4) THEN
            IF (INDEX (LINE, '_refln_10*F_sigm') .EQ. 0 .OR.
     1          INDEX (LINE, '_refln_F_10*sigm') .EQ. 0) GOTO 10
            GOTO 40
C * TEXSAN
          ELSE IF (IDTYP .EQ. 6) THEN
            IF (INDEX (LINE, '_refln_observed_status') .EQ. 0) GOTO 10
            GOTO 40
C * MOLEN1
          ELSE IF (IDTYP .EQ. 7) THEN
            IF (INDEX (LINE, '_refln_observed_status') .EQ. 0) GOTO 10
            GOTO 40
C * CRYSTALS(F)
          ELSE IF (IDTYP .EQ. 5) THEN
            IF (INDEX (LINE, '_refln_F_sigma') .EQ. 0) THEN
              GOTO 10
            ELSE
              READ (LUN1, 99996, END = 50) LINE
              IF (INDEX (LINE, '_refln_observed_status') .EQ. 0) THEN
                GOTO 30
              ELSE
                GOTO 40
              ENDIF
            ENDIF
C * CRYSTALS(I)
          ELSE IF (IDTYP .EQ. 8) THEN
            IF (INDEX (LINE, '_refln_F_squared_sigma') .EQ. 0) THEN
              GOTO 10
            ELSE
              READ (LUN1, 99996, END = 50) LINE
              IF (INDEX (LINE, '_refln_observed_status') .EQ. 0) THEN
                GOTO 30
              ELSE
                GOTO 40
              ENDIF
            ENDIF
C * JANA
          ELSE IF (IDTYP .EQ. 9) THEN
            IF (INDEX (LINE, '_refln_observed_status') .EQ. 0) GOTO 10
            GOTO 40
C * SHELXL LIST 3
          ELSE IF (IDTYP . EQ. 21) THEN
            IF (INDEX (LINE, '_refln_B_calc') .EQ. 0) GOTO 10
            GOTO 40
          ELSE
            GOTO 50
          ENDIF
   30     BACKSPACE LUN1
   40     IF (IDTYP .EQ. 1) THEN
            IF (IFTYPE .EQ. 12) THEN
              READ (LUN1, *, END = 50, ERR = 60)
     1              IH, IK, IL, FOK, FCK, SFOK
            ELSE IF (IFTYPE .EQ. 21) THEN
              READ (LUN1, *, END = 50, ERR = 60)
     1              IH, IK, IL, FCK, FOK, SFOK
            ENDIF
C * MOLEN
          ELSE IF (IDTYP .EQ. 4 .OR. IDTYP .EQ. 7) THEN
            READ (LUN1, FMOL, END = 50) IH, IK, IL,
     1            XFOBS, XFCAL, XSIGI
            FOK  = SIGN (XFOBS**2, XFOBS) / 100.0
            SFOK = 2.0 * ABS(XFOBS) * XSIGI / 100.0
C * CRYSTALS(F)
          ELSE IF (IDTYP .EQ. 5) THEN
            READ (LUN1, 99998, END = 50) IH, IK, IL, XFOBS, XFCAL, XSIGI
            FOK  = SIGN (XFOBS**2, XFOBS)
            SFOK = 2.0 * ABS(XFOBS) * XSIGI
C * CRYSTALS(I)
          ELSE IF (IDTYP .EQ. 8) THEN
            READ (LUN1, 99998, END = 50) IH, IK, IL, FOK, FCK, SFOK
C * JANA
          ELSE IF (IDTYP .EQ. 9) THEN
            READ (LUN1, *, END = 50) IH, IK, IL, FOK, FCK, SFOK
C * TEXSAN FCF
          ELSE IF (IDTYP .EQ. 6) THEN
            READ (LUN1, 99993, END = 50) IH, IK, IL, XFOBS, XSIGI,
     1                                     XFCAL
            FOK  = SIGN(XFOBS**2, XFOBS)
            IF (XFOBS .GT. XSIGI / 2.0) THEN
              SFOK = 2.0 * ABS(XFOBS) * XSIGI
            ELSE
              SFOK = 2.0 * ABS(XFCAL) * XSIGI
            ENDIF
C * SHELXL - LIST 3
          ELSE IF (IDTYP .EQ. 21) THEN
            READ (LUN1, 99991, END = 50) IH, IK, IL, XFOBS, XSIGI,
     1        ACAL, BCAL
            IF (XFOBS .GT. 0.0 .AND. XSIGI .GT. 0) THEN
              FOK  = XFOBS**2
              SFOK = 2.0 * SQRT(FOK) * XSIGI
            ELSE
              GOTO 40
            ENDIF
          ENDIF
          IF (IH .EQ. 0 .AND. IK .EQ. 0 .AND. IL .EQ. 0) GOTO 50
          IF (I .EQ. 1) THEN
            IF (FOK  .GT. FKMX) FKMX = FOK
            IF (SFOK .GT. FKMX) FKMX = SFOK
          ELSE
              NREF = NREF + 1
              WRITE (LUN2, 99999) IH, IK, IL, NINT(FOK * SCF),
     1               NINT(SFOK * SCF)
          ENDIF
          GOTO 40
   50   CONTINUE
      ENDIF
      IF (NREF .EQ. 0) THEN
        WRITE (LUN0, 99994)
      ELSE
        WRITE (LUN2, 99992)
      ENDIF
      RETURN
   60 WRITE (LUN0, 99995) NREF
      STOP
99999 FORMAT (3I4, 2I8)
99998 FORMAT (3I4, 3F12.2)
99996 FORMAT (A)
99995 FORMAT (':: STOP: Free Read Problem in FCF-file NREF =', I6)
99994 FORMAT (/, ':: No Suitable Reflections found in FCF-file', /)
99993 FORMAT (I4, 2I5, 3F11.2)
99992 FORMAT (//)
99991 FORMAT (3I4, 4F12.0)
      END
      SUBROUTINE PLA293 (WAVEL, LU)
      PARAMETER (NP4=9,NP10=16,NP12=600,NP13=500,NP17=99,NP22=256,
     1 NP38=125,NP39=30)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      WL = WAVEL
      IF (WL .LE. 0.0) THEN
        IF (LU .GT. 0 .AND. IGBL(8) .EQ. 3)
     1      WRITE (LU, '(A, 2F10.0)') '_091', 1.0, 1.0
        WL = 0.71073
      ENDIF
      IF (IPR(493) .EQ. 5) THEN
        KRAD = 'neut'
      ELSE
        IF (ABS(WL - 0.56086) .LT. PAR(63)) THEN
          IPR(493) = 1
          KRAD     = 'AgKa'
        ELSE IF (ABS(WL - 0.71073) .LT. PAR(63)) THEN
          IPR(493) = 2
          KRAD     = 'MoKa'
        ELSE IF (ABS(WL - 1.54178) .LT. PAR(63)) THEN
          IPR(493) = 3
          KRAD     = 'CuKa'
        ELSE
          IPR(493) = 4
          KRAD     = 'X'
        ENDIF
      ENDIF
      PAR(17) = WL
      RETURN
      END
      SUBROUTINE PLA294 (MODE)
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16,
     1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP22=256,NP25=99,
     2 NP29=63,NP38=125,NP39=30,NP41=200,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /FNAME/ KNM(8), KXT, KNM16
      COMMON /NAMES/ NAME(8), EXTENS, PROGNM, FNLU1, FNLU16, RDTYPE
      CHARACTER NAME*80, EXTENS*9, PROGNM*28, FNLU1*80, FNLU16*80,
     1          RDTYPE*7
      COMMON /PATHS/ PLAPATH, BROWSER, CGETENV
      CHARACTER PLAPATH*255, BROWSER*255, CGETENV*255
      INTEGER FINDEXE
      COMMON /CGG11/ BCD, SBCD
      CHARACTER BCD*132, SBCD*132
      LOGICAL EXST
      EXTERNAL SYSTEM
      IGBL(70) = 0
      IF (MODE .EQ. 1) THEN
        IF (SPGRNM(1)(13:13) .NE. ' ') THEN
          CLOSE (LU2, ERR = 10)
   10     IGBL(31) = 4
          CALL PLA021
          IF (INDEX (KRSYST, 'Tri') .NE. 0) THEN
            LINE = 'Hexagonal'
          ELSE
            LINE = KRSYST
          ENDIF
          CALL GEN020 (1, LINE, 1, 12)
          WRITE (LU2, 99998) SPGRNM(1)(13:13), LINE(1:12),
     1          (PAR(100 + I), I = 1, 6), PAR(28)
          WRITE (LU2, 99999)
        ELSE
          BCD = 'No SPGR info Given ...'//CHAR(0)
          CALL GGIP (-999.0, 2.0, 30.0, 111)
          GOTO 60
        ENDIF
      ELSE
        WRITE (LU2, 99997)
        NRES = IPR(75)
        IF (NRES .GT. 1) THEN
          DO 50 I = 2, NRES
            IF (RCONT(NRES) .GE. IPR(487)) THEN
              WRITE (LU2, 99996) I
            ENDIF
   50     CONTINUE
        ENDIF
        WRITE (LU2, '(1X)')
      ENDIF
      CLOSE (LU2, ERR = 20)
C * FIND CONQUEST (cq)
   20 CALL GEN038 (CGETENV, 1, 80)
      NE = FINDEXE ('QUESTEXE', CGETENV, 'cqbatch')
      IF (NE .GT. 0) THEN
        CGETENV(NE + 1:) =
     1' -j cqbatch -rerun '//NAME(6)(1:KNM(6))//'.que'//' -export cif'
        CALL SYSTEM (CGETENV)
        CALL SYSTEM ('mv cqbatch.cif '//NAME(6)(1:KNM(6))//'.cq')
        NENT = 0
        OPEN (LU61, FILE = NAME(6)(1:KNM(6))//'.cq',
     1              STATUS = 'UNKNOWN')
   30   READ (LU61, 99995, END = 40) LINE
        IF (LINE(1:12) .EQ. 'data_CSD_CIF') NENT = NENT + 1
        GOTO 30
   40   CLOSE (LU61)
        BCD = 'Number of Hits =      '//CHAR(0)
        WRITE (BCD(17:21), '(I5)') NENT
        CALL GGIP (-999.0, 2.0, 30.0, 111)
        IF (IGBL(80) * NENT .GT. 0) CALL SYSTEM
     1        (PLAPATH(1:IGBL(80))//' -a '//NAME(6)(1:KNM(6))//'.cq')
      ELSE
        CALL PLA015 (0, 9)
      ENDIF
   60 RETURN
99999 FORMAT ('QUESTION T1')
99998 FORMAT ('SAVE 3', /, 'T1 *', A, 'CELL ', A, 3F9.3, 3F7.2, F6.3)
99997 FORMAT ('QUESTION T1', $)
99996 FORMAT (' .OR. T', I1, $)
99995 FORMAT (A)
      END
      SUBROUTINE PLA295
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP10=16,
     1 NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP25=99,NP29=63,
     2 NP38=125,NP39=30,NP41=200,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      KN   = IPR(221)
      NMOL = IPR(53)
      IF (KN .GT. 0) THEN
        DO 30 I = 1, KN
          NS = INT(ABS(FN(I)) / 1000.0)
          IF (NS .LE. IPR(48)) THEN
            MLS = NINT(FN(I) * PAR(42))
            IF (NINT(FN(I)) * NINT(PAR(42)) .EQ. MLS) THEN
              IF (MLS .GT. 0) THEN
                MLS = MLS + 1
              ELSE
                MLS = MLS - 1
              ENDIF
            ENDIF
            IF (NMOL .GT. 0) THEN
              DO 20 J = 1, NMOL
                IF (IABS(MLS) .EQ. MOLS(J)) THEN
                  IF (MLS .GT. 0) THEN
                    GOTO 30
                  ELSE
                    IF (J . LT. NMOL) THEN
                      DO 10 K = J + 1, NMOL
                        MOLS(K - 1) = MOLS(K)
   10                 CONTINUE
                    ENDIF
                    NMOL = NMOL - 1
                    GOTO 30
                  ENDIF
                ENDIF
   20         CONTINUE
            ENDIF
            NMOL       = NMOL + 1
            MOLS(NMOL) = MLS
          ENDIF
   30   CONTINUE
      ENDIF
      IPR(53) = NMOL
      DO 40 I = 1, IPR(53)
        MOL(I) = MOLS(I)
   40 CONTINUE
      IPR(13) = IPR(53)
      IF (IPR(17) .NE. 0) THEN
        IPR(17) = 0
        CALL PLA089
      ENDIF
      IPR(39) = IPR(37)
      CALL PLA094 (-1)
      CALL PLA029
      CALL PLA043 (0, -2, LU6, 0)
      IPR(201) = 0
      IPR(64)  = 0
      RETURN
      END
      SUBROUTINE PLA296
      PARAMETER (NP1=7000,NP2=99,NP4=9,NP6=100,NP7=50,NP8=50,NP9=118,
     1 NP10=16,NP11=128,NP12=600,NP13=500,NP17=99,NP19=31,NP22=256,
     2 NP25=99,NP29=63,NP38=125,NP39=30,NP41=200,NP45=2048,NP47=9)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLATO/ XLAB(NP1), XXO(NP1, 6), XSD(NP1, 6), CON(NP1, NP4),
     1 IATP(NP1), IFG(NP1), JFG(NP1), IATC(NP1), NTRNS(NP1), JATC(NP1),
     2 DATC(NP1), IFNT(NP1), JCA(NP1), JR(NP1), IBON(NP6, 2), IDIR(NP7),
     3 XDIR(NP7, 3, 4), KBO(NP8, 5), BOK(NP8, 6), MP(NP11), MOL(NP11),
     4 CONT(NP10 + 1, 99), RCG(4, NP29), NCN(NP19), JLN(NP19), NALV(44),
     5 BASF(15), NEWLAT(NP47), XLS(10, NP2), YMOL(2, 100), MOLS(NP11),
     6 ORG(3), VIEWV(3), DUMA(6), DUMV(3, 3), IXPV(8), XPV(8), XSPV(8),
     7 PAT(3, 3), AA(3, 3), BB(3, 3), DBUF(10), IDBUF(10), ORRES(3, 3),
     8 QQ(3, 3), UIJC(3, 3), OR(3, 3), XJS(12), ITR(3), VECN(8), DEV(6),
     9 UIJ(3, 3), MLTI(64), SDV(6), ISDV(6), DP(2, 132), XJX(12), V1(4),
     * V2(3), V3(3), V4(3), V5(3), V6(3), V8(3), TRNS(3, 3), ROR(3, 3),
     1 RCONT(63), RMAT(3, 3), IXSD(6), RP(NP25), RAA(3, 3), RBB(3, 3),
     2 IPPR(129, 3), SCIR(3, 155), ADIR(3, 3), AINV(3, 3), TRNSM1(3, 3),
     3 ROTM1(3, 3), ROTM2(3, 3), DAM(3, 3), PAC(3, 5), RMS(5), QM(3, 3),
     4 SLN(10, 2), SXYZ(12, NP41), TM1(3, 3), TM2(3, 3), SHFT(3),
     5 RORO(3, 3), DXI(3), NCIF(20)
      COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9),
     1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10),
     2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10),
     3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /Q/ ICL, IFL(NP17)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      DIMENSION NRAT(4), NSCIF(4, 192)
      A       = 0.0
      SA      = 0.0
      ISA     = 0
      NDEC    = 0
      NRAT(3) = 0
      NRAT(4) = 0
      N3      = 0
      IER     = 0
      NSCF    = 0
      NAT     = IPR(39) + IPR(64)
      NAHAT   = 0
      NBHAT   = 0
      CALL GEN108 (LU11, 0)
   10 READ (LU11, END = 40) ICL(1:80), (IFL(I), I = 1, 4),
     1                      (FN(I), I = 1, 6)
      NHAT = 0
      IF (ICL(1:4) .EQ. 'SYMM') THEN
        CALL SGSM (ICL, 0, XJS, 0, 22, IER)
        IF (NSCF .LT. 192) THEN
          NSCF = NSCF + 1
          DO 20 I = 1, 4
            NSCIF(I, NSCF) = NINT (XJS(I + 8))
   20     CONTINUE
        ENDIF
        GOTO 10
      ELSE IF (ICL(1:4) .EQ.  'BOND') THEN
        N  = 2
        M7 = 1
      ELSE IF (ICL(1:4) .EQ.  'CONT') THEN
        N  = 2
        M7 = 4
      ELSE IF (ICL(1:4) .EQ.  'D-H ') THEN
        N  = 2
        M7 = 5
      ELSE IF (ICL(1:4) .EQ.  'H..A') THEN
        N  = 2
        M7 = 6
      ELSE IF (ICL(1:4) .EQ.  'D..A') THEN
        N  = 2
        M7 = 7
      ELSE IF (ICL(1:4) .EQ. 'ANGL') THEN
        N  = 3
        M7 = 2
      ELSE IF (ICL(1:6) .EQ. 'D-H..A') THEN
        N  = 3
        M7 = 8
      ELSE IF (ICL(1:4) .EQ. 'TORS') THEN
        N3 = N3 + 1
        N  = 4
        M7 = 3
      ELSE
        GOTO 10
      ENDIF
      NPOP  = 0
      NCSYM = 0
      DO 30 I = 1, N
        M0    =  INT (FN(I + 2)) * 1000
        M     = NINT (FN(I + 2)  * 1000.0)
        IF (M .EQ. M0) THEN
          M = M + 555
          FN(I + 2) = M / 1000.0
        ENDIF
        IF (M .NE. 1555) THEN
          NCSYM   = NCSYM + 1
          MS      = M  / 1000
          IF (MS .LE. 0 .OR. MS .GT. IPR(48)) GOTO 10
          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
          IPR(54) = NSCIF(1, MS)
          IF (IPR(54) .EQ. 0) GOTO 10
          ITR(1)  = M1 + NSCIF(2, MS)
          ITR(2)  = M2 + NSCIF(3, MS)
          ITR(3)  = M3 + NSCIF(4, MS)
        ENDIF
        NQ2 = IFL(I)
        IF (NQ2(1:1) .EQ. '?') GOTO 10
        CALL PLA046 (-2, NQ2, IENM, LBB, LBC, LBD, XNQNR, YNQNR, NIEN)
        IF (NIEN .GT. 0) THEN
          L       = NIEN
          NRAT(I) = L
          CALL GEN048 (-1, IFG(L), 7, IVAL)
          NHAT = NHAT + IVAL
          IF (M7 .EQ. 1) NBHAT = NBHAT + IVAL
          IF (M7 .EQ. 2) NAHAT = NAHAT + IVAL
          CALL GEN048 (-7, JFG(L), 1, IDIS)
          NPOP = NPOP + IPPR(IDIS + 1, 1) / 1000
        ELSE
          IF (NQ2(1:2) .NE. 'CG') THEN
            WRITE (LU20, 99995) 710 + M7, 1.0, 1.0, NQ2,
     1                          (IFL(J), J = 1, N)
          ENDIF
          GOTO 10
        ENDIF
        IF (FN(I + 2) .NE. 1.555) THEN
          K       = NAT + I
          NRAT(I) = K
          XLAB(K) = XLAB(L)
          CALL PLA059 (L, K)
          IFG(K) = IFG(L)
          JFG(K) = JFG(L)
          CALL GEN048 (1, IFG(K), 5, 1)
        ENDIF
   30 CONTINUE
      IF (N .EQ. 2) THEN
        IF (M7 .EQ. 1) THEN
          CALL GEN048 (-4, IFG(NRAT(1)), 15, NO1)
          CALL GEN048 (-4, IFG(NRAT(2)), 15, NO2)
          IEN1 = IEN(NO1 + 1)
          IEN2 = IEN(NO2 + 1)
          IAT1 = IATNR(IEN1)
          IAT2 = IATNR(IEN2)
          IF (IAT1 .LT. IAT2) THEN
            CALL GEN014 (IEN1, IEN2)
            CALL GEN014 (IAT1, IAT2)
          ENDIF
          IEN12 = IEN1 * 1000 + IEN2
          INR   = 0
          IF (IEN12 .EQ. 2001) THEN
            IF (FN(1) .GT. 1.3) INR = 770
          ELSE IF (IEN12 .EQ. 4001) THEN
            IF (FN(1) .GT. 1.3) INR = 771
          ELSE IF (IEN12 .EQ. 3001) THEN
            IF (FN(1) .GT. 1.3) INR = 772
          ELSE IF (IEN12 .EQ. 2002) THEN
            IF (FN(1) .GT. 1.7) INR = 773
          ENDIF
          IF (INR .GT. 0) WRITE (LU20, '(''_'', I3, 2F10.2, 2A)')
     1        INR, 1.0, FN(1), IFL(1), IFL(2)
        ENDIF
        M8 = M7
        IF (M7 .EQ. 1 .AND. NHAT .EQ. 0) IPR(316) = IPR(316) + 1
        CALL PLA053 (NRAT(1), NRAT(2), 0, 0, A, SA, ISA, NDEC, IER)
        IF (IER .NE. 0) GOTO 10
        SB = MAX (0.0, SA)
        RATIO = ABS(FN(1) - A)
        IF (FN(2) .LE. 0.0 .OR. SA .LE. 0.0) THEN
          M8 = M8 + 20
          RATIO1 = RATIO * 100
        ELSE
          RATIO  = RATIO / SA
          RATIO1 = RATIO
        ENDIF
        IF (RATIO1 .GT. 1.0) THEN
          IF (A .LT. 9.9) THEN
            WRITE (LU20, 99999) 700 + M8, RATIO1, RATIO, A, SB
            WRITE (LU20, 99993) (FN(I), I = 1, 2),
     1          (IFL(I)(1:5), I = 1, 2), (FN(I), I = 3, 4)
          ELSE IF (A .LT. 99.9) THEN
            WRITE (LU20, 99994) 700 + M8, RATIO1, RATIO, A, SB
            WRITE (LU20, 99990) (FN(I), I = 1, 2),
     1          (IFL(I)(1:5), I = 1, 2), (FN(I), I = 3, 4)
          ENDIF
        ENDIF
        IF (NPOP .EQ. 2) THEN
          IF (SA .GT. 0.0) THEN
            IF (FN(2) .GT. 0) THEN
              RATIO  = MIN (9.9, MAX (FN(2) / SA, SA / FN(2)))
              IF (RATIO .GT. 1.5) THEN
                M7 = M7 + 30
                IF (A .LT. 9.9) THEN
                  WRITE (LU20, 99999) 700 + M7, RATIO, RATIO, A, SB
                  WRITE (LU20, 99993) (FN(I), I = 1, 2),
     1                  (IFL(I)(1:5), I = 1, 2), (FN(I), I = 3, 4)
                ELSE IF (A .LT. 99.9) THEN
                  WRITE (LU20, 99994) 700 + M7, RATIO, RATIO, A, SB
                  WRITE (LU20, 99990) (FN(I), I = 1, 2),
     1                  (IFL(I)(1:5), I = 1, 2), (FN(I), I = 3, 4)
                ENDIF
              ENDIF
            ELSE
              M7 = M7 + 40
              IF (A .LT. 9.9) THEN
                WRITE (LU20, 99999) 700 + M7, 1.0, 1.0, A, SB
                WRITE (LU20, 99993) (FN(I), I = 1, 2),
     1            (IFL(I)(1:5), I = 1, 2), (FN(I), I = 3, 4)
              ELSE IF (A .LT. 99.9) THEN
                WRITE (LU20, 99994) 700 + M7, 1.0, 1.0, A, SB
                WRITE (LU20, 99990) (FN(I), I = 1, 2),
     1          (IFL(I)(1:5), I = 1, 2), (FN(I), I = 3, 4)
              ENDIF
            ENDIF
          ELSE IF (FN(2) .GT. 0.0) THEN
            M7 = M7 + 50
            IF (A .LT. 9.9) THEN
              WRITE (LU20, 99999) 700 + M7, 1.0, 1.0, A, SB
              WRITE (LU20, 99993) (FN(I), I = 1, 2),
     1          (IFL(I)(1:5), I = 1, 2), (FN(I), I = 3, 4)
            ELSE IF (A .LT. 99.9) THEN
              WRITE (LU20, 99994) 700 + M7, 1.0, 1.0, A, SB
              WRITE (LU20, 99990) (FN(I), I = 1, 2),
     1          (IFL(I)(1:5), I = 1, 2), (FN(I), I = 3, 4)
            ENDIF
          ENDIF
        ENDIF
      ELSE IF (N .EQ. 3) THEN
        IF (FN(1) .LT. 45.0) THEN
          CALL GEN048 (-1, IFG(NRAT(2)), 19, IVAL)
          IF (IVAL .EQ. 0) THEN
            WRITE (LU20, 99991) 779,  1.0, FN(1),
     1       (IFL(I)(1:5), I = 1, 3), (FN(I), I = 3, 5)
          ENDIF
        ENDIF
        M8 = M7
        CALL PLA053 (NRAT(1), NRAT(2), NRAT(3), 0, A, SA, ISA, NDEC,
     1      IER)
        IF (IER .NE. 0) GOTO 10
        SB    = MAX (0.0, SA)
        RATIO = ABS (FN(1) - A)
        IF (FN(2) .LE. 0.0 .OR. SA .LE. 0.0) THEN
          M8 = M8 + 20
          RATIO1 = RATIO
        ELSE
          RATIO  = RATIO / SA
          RATIO1 = RATIO
        ENDIF
        IF (RATIO1 .GT. 1.0) THEN
           WRITE (LU20, 99998) 700 + M8, RATIO1, RATIO, A, SB,
     1   (FN(I), I = 1, 2), (IFL(I)(1:5), I = 1, 3), (FN(I), I = 3, 5)
        ENDIF
        IF (NPOP .EQ. 3) THEN
          IF (NCSYM .EQ. 0) THEN
            IF (SA .GT. 0.0 .AND. ABS(A) .LT. 179.95) THEN
              IF (FN(2) .GT. 0) THEN
                RATIO  = MIN (9.9, MAX (FN(2) / SA, SA / FN(2)))
                IF (RATIO .GT. 1.5) THEN
                  M7 = M7 + 30
                  WRITE (LU20, 99998) 700 + M7, RATIO, RATIO, A, SB,
     1                  (FN(I), I = 1, 2), (IFL(I)(1:5), I = 1, 3),
     2                  (FN(I), I = 3, 5)
                ENDIF
              ELSE
                M7 = M7 + 40
                WRITE (LU20, 99998) 700 + M7, 1.0, 1.0, A, SB,
     1              (FN(I), I = 1, 2), (IFL(I)(1:5), I = 1, 3),
     2              (FN(I), I = 3, 5)
              ENDIF
            ELSE IF (FN(2) .GT. 0.0 .AND. ABS(A) .LT. 179.95) THEN
              M7 = M7 + 50
              WRITE (LU20, 99998) 700 + M7, 1.0, 1.0, A, SB,
     1              (FN(I), I = 1, 2), (IFL(I)(1:5), I = 1, 3),
     2              (FN(I), I = 3, 5)
            ENDIF
          ENDIF
        ENDIF
      ELSE IF (N .EQ. 4) THEN
        M8 = M7
        CALL PLA050 (NRAT(1), NRAT(2), NRAT(3), 0, A1)
        CALL PLA050 (NRAT(2), NRAT(3), NRAT(4), 0, A2)
        IF (A1 .LT. 170 .AND. A2 .LT. 170) THEN
          CALL PLA053 (NRAT(1), NRAT(2), NRAT(3), NRAT(4), A, SA,
     1                 ISA, NDEC, IER)
          IF (IER .NE. 0) GOTO 10
          SB = MAX (0.0, SA)
          RATIO = ABS(FN(1) - A)
          IF (RATIO .GT. 180.0) RATIO = 360.0 - RATIO
          IF (FN(2) .LE. 0.0 .OR. SA .LE. 0.0) THEN
            M8 = M8 + 20
            RATIO1 = RATIO
          ELSE
            RATIO  = RATIO / SA
            RATIO1 = RATIO
          ENDIF
          IF (RATIO .GT. 1.0)
     1      WRITE (LU20, 99997) 700 + M8, RATIO1, RATIO, A, SB,
     2            (FN(I), I = 1, 2), (IFL(I)(1:4), I = 1, 4),
     3        (FN(I), I = 3, 6)
          IF (NPOP .EQ. 4) THEN
            IF (ABS(A) .GT. 0.05 .AND. ABS(A) .LT. 179.95) THEN
              IF (SA .GT. 0.0) THEN
                IF (FN(2) .GT. 0.0) THEN
                  RATIO  = MIN (9.9, MAX (FN(2) / SA, SA / FN(2)))
                  IF (RATIO .GT. 1.5) THEN
                    M7 = M7 + 30
                    WRITE (LU20, 99997) 700 + M7, RATIO, RATIO, A, SB,
     1                    (FN(I), I = 1, 2), (IFL(I)(1:4), I = 1, 4),
     2                    (FN(I), I = 3, 6)
                  ENDIF
                ELSE
                  M7 = M7 + 40
                  WRITE (LU20, 99997) 700 + M7, 1.0, 1.0, A, SB,
     1                  (FN(I), I = 1, 2), (IFL(I)(1:4), I = 1, 4),
     2                  (FN(I), I = 3, 6)
                ENDIF
              ELSE IF (FN(2) .GT. 0.0) THEN
                M7 = M7 + 50
                WRITE (LU20, 99997) 700 + M7, 1.0, 1.0, A, SB,
     1                (FN(I), I = 1, 2), (IFL(I)(1:4), I = 1, 4),
     2                (FN(I), I = 3, 6)
              ENDIF
            ENDIF
          ENDIF
        ELSE
          WRITE (LU20, 99996) 1, 1, N3,
     1          (IFL(I)(1:4), I = 1, 4), (FN(I), I = 1, 6)
        ENDIF
      ENDIF
      GOTO 10
   40 IF (IGBL(94) .EQ. 0) THEN
        IF (IGBL(97) .EQ. 1 .AND. IPR(484) .GT. 0) THEN
          IF (NBHAT .EQ. 0) WRITE (LU20, 99992) 1, 1, 1
          IF (NAHAT .EQ. 0) WRITE (LU20, 99992) 2, 1, 1
        ENDIF
      ENDIF
      CALL GEN108 (LU11, 0)
99999 FORMAT ('_', I3, 2F10.2, 2F7.5, ' =')
99998 FORMAT ('_', I3, 2F10.2, 2F7.2, ' =', /,
     1        2F7.2, 2(A, '-'), A, 3F8.3)
99997 FORMAT ('_', I3, 2F10.2, 2F7.2, ' =', /,
     1        2F7.2, 3(A, '-'), A, 4F8.3)
99996 FORMAT ('_710', 2I10, I5, 9X, ' =', /,
     1        12X, 3(A, '-'), A, F8.2, F6.2, 4F8.3)
99995 FORMAT ('_', I3, 2F10.0, A, 7X, ' =', /, 20X, 4A)
99994 FORMAT ('_', I3, 2F10.2, F7.4, F7.5, ' =')
99993 FORMAT (2F7.5, A, '-', A, 2F8.3)
99992 FORMAT ('_76', I1, 2I10)
99991 FORMAT ('_', I3, 2F10.2, 14X, ' =', /,
     1        14X, 2(A, '-'), A, 3F8.3)
99990 FORMAT (F7.4, F7.5, A, '-', A, 2F8.3)
      RETURN
      END
      SUBROUTINE PLA297 (MODE)
      PARAMETER (NP12=600,NP13=500,NP17=99,NP38=125,NP39=30)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /CGGT/ IGGT
      CHARACTER IGGT*80
      CALL PLA013 (2, 5)
      IF (IGGT(1:4) .EQ. 'PLOT') THEN
        IF (MODE .EQ. 2) IGGT(1:4) = 'CALC'
      ENDIF
      IF (IGGT(1:4) .NE. 'CALC') CALL GEN038 (IGGT, 1, 80)
      IF (MODE .EQ. 1) THEN
        IF (IGBL(23) .EQ. 10) THEN
          CALL PLA280 ('!')
        ELSE
          CALL PLA280 ('PLOT')
        ENDIF
      ENDIF
      RETURN
      END
      SUBROUTINE PLA298 (MODE)
      PARAMETER (NP12=600,NP13=500,NP17=99,NP38=125,NP39=30,NP42=250)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /CCOM/ LINE, JFL, BDAT, FNM, FILE1, FILE3, SSTAT,
     1 SSTATA, SSTATB, SFC, COMPD, TSPGR, USRPATH, DATPATH, ARCPATH,
     2 SHXPATH, SHSPATH, SHDPATH, SR2PATH, SHLPATH, HELPATH, SIRPATH,
     3 DIRPATH, CRUPATH, SAVPATH, WORKDIR, PROBLEM, PSVIEWER, PSLASER,
     4 DATAORG, EDITOR, LNKS
      CHARACTER LINE*80, JFL(NP17)*10, BDAT*58, FNM*254, FILE1*40,
     1 FILE3*50, TSPGR(NP42)*50, PSVIEWER*80,DATAORG*80, SSTAT(6)*8,
     2 SSTATA(4)*10, SSTATB(7)*10, PSLASER*40, LNKS(2)*200, PROBLEM*80,
     3 WORKDIR*254, SAVPATH*25, SHXPATH*50, SFC(16)*2, COMPD*10,
     4 USRPATH*254, DATPATH*25, ARCPATH*25, SHSPATH*40, SHDPATH*40,
     5 SR2PATH*40, SHLPATH*40, EDITOR*80, HELPATH*40, SIRPATH*40,
     6 DIRPATH*40, CRUPATH*40
      COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0
      COMMON /CGGT/ IGGT
      CHARACTER IGGT*80
      COMMON /CGG11/ BCD, SBCD
      CHARACTER BCD*132, SBCD*132
      CHARACTER LIJN*80
      IF (MODE .EQ. 1) THEN
        LU = LU65
        OPEN (UNIT = LU, FILE = 'valid.chk',  STATUS = 'UNKNOWN')
      ELSE IF (MODE .EQ. 2) THEN
        LU = LU65
        OPEN (UNIT = LU, FILE = 'tm/sg/valid/valid.chk',
     1        STATUS = 'UNKNOWN')
      ELSE
        LU       = LU10
        IGBL(83) = 0
        CALL GEN108 (LU, 0)
      ENDIF
      N     = 0
      ISAVE = 0
   10 VRT   = 19.4
      BCD(1:11) = 'VALIDATION'//CHAR(0)
      CALL GGIP (HORS, VERT, 0.0, 1)
      N    = N + 1
      IF (N .EQ. 1) THEN
        LIJN = 'VALIDATION REPORT FOR CURRENT CIF'
        CALL GGIP20 (0.0, LIJN, 33, 0.375, 5 + IGBL(68), 2, 7.0,
     1               VRT - 0.6)
      ENDIF
   20 IF (ISAVE .EQ. 0) THEN
        READ (LU, 99999, END = 40) LIJN
        IF (LIJN(80:80) .EQ. '#' .AND. N .NE. 1) THEN
          ISAVE = 1
          GOTO 30
        ENDIF
      ENDIF
      ISAVE = 0
      M     = 1
      IF (INDEX (LIJN, 'ALERT A') .NE. 0) M = 2
      IF (INDEX (LIJN, 'ALERT B') .NE. 0) M = 6
      VRT = VRT - 0.5
      CALL GGIP20 (0.0, LIJN, 80, 0.35, M, 2, 1.0, VRT)
      IF (VRT .GT. 0.4) GOTO 20
   30 CALL PLA013 (1, 1)
      IF (IGGT(1:4) .EQ. 'PLOT') GOTO 30
      IF (IGGT(1:4) .EQ. 'CALC' .OR. IGGT(1:1) .EQ. 'Y') GOTO 10
      IF (IGGT(1:4) .EQ. 'EXIT') GOTO 50
      IF (IGGT(1:1) .NE. ' ' .AND. IGGT(1:1) .NE. '!') THEN
        IF (IGGT(1:1) .EQ. 'N') GOTO 50
        IF (LRET .EQ. 2) THEN
          CALL GEN108 (LU, 0)
          GOTO 10
        ENDIF
        LINE = IGGT
        CALL GEN038 (IGGT, 1, 80)
      ENDIF
      GOTO 10
   40 CALL PLA297 (0)
   50 CLOSE (LU)
      RETURN
99999 FORMAT (A)
      END
      SUBROUTINE PLA299
      PARAMETER (NP45=2048)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      CHARACTER ICL*(NP45), ICH*1
      DIMENSION XJX(12)
      COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0
      COMMON /CGGT/ IGGT
      CHARACTER IGGT*80
      IF (IWIN .EQ. 1) THEN
        VRT = VERT - 0.2
        CALL GGIP (HORS, VERT, 0.0, 1)
        OPEN (LU61, FILE = 'srcsrc', STATUS = 'UNKNOWN')
        CALL SGSM (ICL, 0, XJX, LU61, 2, IERR)
        CALL GEN108 (LU61, 0)
   10   READ (LU61, 99999, END = 20) ICL(1:80)
        IF (VRT - 0.5 .LT. 0.0) THEN
          CALL PLA013 (1, 1)
          ICH = IGGT(1:1)
          CALL GGIP (HORS, VERT, 0.0, 1)
          IF (ICH .NE. 'Y' .AND. ICH .NE. '!') GOTO 20
          VRT = VERT
        ENDIF
        VRT = VRT - 0.5
        CALL GGIP20 (0.0, ICL, 80, 0.35, 1, 2, 1.0, VRT)
        GOTO 10
   20   CLOSE (LU61, STATUS = 'DELETE')
        CALL PLA297 (0)
      ELSE
        CALL SGSM (ICL, 0, XJX, LU6, 2, IERR)
      ENDIF
      RETURN
99999 FORMAT (A)
      END
      SUBROUTINE PLA300 (M1, M2, M3)
      PARAMETER (NP4=9,NP10=16,NP12=600,NP13=500,NP17=99,NP22=256,
     1 NP38=125,NP39=30,NP45=2048,NP46=15)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /Q/ ICL, IFL(NP17)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0
      COMMON /PATHS/ PLAPATH, BROWSER, CGETENV
      CHARACTER PLAPATH*255, BROWSER*255, CGETENV*255
      CHARACTER N1*2, N2*2, N3*2
      EXTERNAL SYSTEM
      NA = M1
      NB = M2
      NC = M3
C * BROWSER-HTML HELP
      IF (IGBL(47) .GT. 0) THEN
        IF (NA .EQ. 1) THEN
          IF (IGBL(23) .GE. 10 .AND. IGBL(23) .LE. 12) THEN
            N1 = '00'
            IF (NC .LT. 0 .OR. NC .GT. NP46) THEN
              NB = 0
              NC = 0
            ENDIF
          ELSE
            GOTO 20
          ENDIF
          WRITE (N2, 99997) NB
        ELSE IF (NA .EQ. 2) THEN
          WRITE (N1, 99997) IGBL(23)
          N2 = '02'
        ELSE IF (NA .EQ. 3) THEN
          N1 = '10'
          N2 = '03'
          N3 = '00'
        ELSE IF (NA .EQ. 0) THEN
          WRITE (N1, 99997) NB
          N2 = '00'
        ENDIF
        WRITE (N3, 99997) MAX (0, NC)
C * PREPARE URL IN PRBUF
        CALL GETENV ('PLAHTM', LINE)
        IF (LINE(1:1) .EQ. ' ') THEN
          PRBUF = 'http://www.cryst.chem.uu.nl/platon/'
        ELSE
          PRBUF = 'file:'//LINE
        ENDIF
        CALL GEN039 (1, PRBUF, 1, 132, NX, NE)
        PRBUF(NE + 1:) = 'pl'//N1//N2//N3//'.html'
C * PREPARE NETSCAPE COMMAND LINE IN CGETENV
        CALL SYSTEM ('sh -c "rm nsk.x 2> /dev/null" ')
        NF = IGBL(47)
        IF (NF .GT. 0) THEN
          BROWSER(NF + 1: )  =
     1     ' -remote "openURL('//PRBUF(1:NE + 13)//')" 2> nsk.x'
          CALL SYSTEM ('sh -c '''//BROWSER(1:NF + NE + 42)//' '' ')
          OPEN (UNIT = 66, FILE = 'nsk.x', STATUS = 'UNKNOWN')
          READ (66, 99999, END = 10) ICL(1:80)
          WRITE (LU6, 99999) ICL(1:80)
          IF (NA .NE. 0) THEN
            LINE(1:4) = 'HELP'
            CALL GGIP20 (0.0,  LINE, 4,  1.0, 0, 4, HORS - 3.5, 0.3)
            LINE = 'Browser -'
            CALL GGIP20 (0.0,  LINE, 9, 0.7, 0, 3, HORS - 9.8, 0.3)
            LINE = 'Browser STARTUP'
            CALL GGIP20 (0.0,  LINE, 15, 0.7, 2, 3, HORS - 9.8, 0.3)
            CALL GGIP (0.0, 0.0, 0.0, 6)
          ELSE
            WRITE (LU6, 99998)
          ENDIF
          BROWSER(NF + 1:) = ' '//PRBUF(1:NE + 13)//' & '
          WRITE(LU6, 99999) BROWSER(1:NF + NE + 17)
          CALL SYSTEM (BROWSER(1:NF + NE + 17))
   10     CLOSE (66, STATUS = 'DELETE')
        ENDIF
      ENDIF
   20 CONTINUE
      RETURN
99999 FORMAT (A)
99998 FORMAT (/, '(Startup) Browser', /)
99997 FORMAT (I2.2)
      END
      SUBROUTINE PLA301
      PARAMETER (NUMAT=150,NELTS=16,NTOT=1000)
C * STRUCTURE TIDY: Program to standardize structure data.
C * see Gelato & Parthe, J. Appl. Cryst. 1987, 20, 139-143.
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /STID/ ISETS(73, 230)
      COMMON /STBL4/ ipol, r, ngr, iocfl, vol, nfl, volrat
      COMMON /at/ iat, pos(3), ihex, fnum
      COMMON /atch/ elt1, elt2, f
      COMMON /STBL1/ STAA, STBB, STCSH
      COMMON /STBL3/ STTEXT(21)
      COMMON /bur/ nt, spgr
      COMMON /cel/ a, b, c, al, be, ga, alf, bet, gam, cosa, cosb, cosg
      COMMON /ch/ xa(3, numat)
      COMMON /lab/ ax
      COMMON /matr/ ifmat, ifsh, ifplus, xmat(3, 3), plus(3), sh(3),
     1 nabc, nsh, nshtra, ifnig, xmsave(3, 3), shif(3), minsh
      COMMON /messa/ iw
      COMMON /orgin/ nor, orgadd(3, 8), ntext, icoord
      COMMON /par/ gmin
      COMMON /pol/ npol, xpol(3, ntot), xp(3, ntot), orga(3), smin,
     1        kkord(numat), nat(ntot)
      COMMON /posi/ x(3, 192), dist(192), kount
      COMMON /RES/ ATOM1, ATOM2, FOCCU, INTXT, CODE, ELT
      COMMON /rot/ xrot(3, numat), natom
      COMMON /sp/ n, nw, ns(26), is(27), mult(15), nset(8), kset,
     1            mu, kord
      COMMON /stng/ irot,ntio
      COMMON /trans/ s(3, 3), u(9), t(9), p(9)
      COMMON /trip/ dmin, min, korder(192), iflag, xmin(3, numat),
     1        mul(numat), let(numat), nrset(numat), nnset(8, numat)
      COMMON /xpolar/ ipolar, kpol(3), lowlet
      COMMON /PAGENM/ PAGET, PAGEIND(25)
      COMMON /NAMES/ NAME(8), EXTENS, PROGNM, FNLU1, FNLU16, RDTYPE
      CHARACTER NAME*80, EXTENS*9, PROGNM*28, FNLU1*80, FNLU16*80,
     1          RDTYPE*7
      COMMON /FNAME/ KNM(8), KXT, KNM16
      LOGICAL OPEND
      CHARACTER PAGET*8, PAGEIND*8
      CHARACTER elt1*2, atom1(numat)*2, STCSH(17)*14
      CHARACTER*1 nt(16), intext(70), ansr, ko, INTXT*40
      CHARACTER STAA(107)*11, STBB(39)*15, STTEXT*17, f*5,
     1 foccu(numat)*5, ax*47
      CHARACTER icel*51, code(2)*1, elt(NELTS)*2, spgr*10, forms(15)*16
      CHARACTER*4 elt2, atom2(numat), dat*50, eln(105)*2
      DIMENSION finxyz(3, numat), shift(3, 11), pear(NELTS),
     1 iform(44), ssave(3, 3), nsp(numat), orig(3), totsh(3)
      equivalence (icel, dat)
      data eln/  'H ','He','Li','Be','B ','C ','N ','O ','F ','Ne','Na',
     1 'Mg','Al','Si','P ','S ','Cl','Ar','K ','Ca','Sc','Ti','V ',
     2 'Cr','Mn','Fe','Co','Ni','Cu','Zn','Ga','Ge','As','Se','Br','Kr',
     3 'Rb','Sr','Y ','Zr','Nb','Mo','Tc','Ru','Rh','Pd','Ag','Cd','In',
     4 'Sn','Sb','Te','I ','Xe','Cs','Ba','La','Ce','Pr','Nd','Pm','Sm',
     5 'Eu','Gd','Tb','Dy','Ho','Er','Tm','Yb','Lu','Hf','Ta','W ','Re',
     6 'Os','Ir','Pt','Au','Hg','Tl','Pb','Bi','Po','At','Rn','Fr','Ra',
     7 'Ac','Th','Pa','U ','Np','Pu','Am','Cm','Bk','Cf','Es','Fm','Md',
     8 'No','Lr','Tu','D '/
      data shift/
     1 5*0.75,2*0.,2*0.75,0.25,0.75,0.,5*0.25,0.,0.25,0.75,
     1 0.25,0.,0.75,0.125,0.,0.25,4*0.125,3*0.375/
      DATA 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/
      DATA 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', 'Cubic cP',
     5 'Cubic cF', 'Cubic cI'/
      INQUIRE (FILE = NAME(1)(1:KNM(1))//'.lis', OPENED = OPEND)
      IF (.NOT. OPEND) THEN
        OPEN (LU7, FILE = NAME(1)(1:KNM(1))//'.lis', STATUS = 'UNKNOWN')
      ENDIF
      OPEN (UNIT = LU60, STATUS = 'SCRATCH', FORM = 'UNFORMATTED')
      OPEN (UNIT = LU61, STATUS = 'SCRATCH', FORM = 'UNFORMATTED')
      OPEN (UNIT = LU63, STATUS = 'SCRATCH')
      OPEN (UNIT = LU64, FILE = NAME(1)(1:KNM(1))//'.'//EXTENS(1:KXT),
     1        STATUS = 'UNKNOWN')
      PAGET = 'STR-TIDY'
      CALL PLA269 (0)
      WRITE (LU7, 99966)
      CALL PLA269 (6)
      R      = 180.0 / 3.1415926
      nigg   = 0
      ifshif = 0
      ipol   = 0
      CALL GEN126 (NT, 1, 16)
      READ (LU64, 99995, END = 400) INTEXT
      impcel = 0
      INTXT  = ' '
      J1     = 0
      IBL    = 0
      NIG    = 0
      IC     = 0
      MIX    = 0
      DO 20 J = 1, 70
        IF (INTEXT(J) .EQ. '*') THEN
          NIG       = 1
          INTEXT(J) = ' '
        ELSE IF (INTEXT(J) .EQ. '+') THEN
          IMPCEL    = 1
          INTEXT(J) = ' '
        ELSE IF (INTEXT(J) .EQ. ' ') THEN
          IF (J1 .NE. 0) THEN
            IBL = IBL + 1
            IF (IBL .EQ. 2) GOTO 30
            J1     = J1 + 1
            NT(J1) = ' '
          ENDIF
        ELSE
          J1 = J1 + 1
          IF (J1 .GT. 16) GOTO 380
          NT(J1)    = INTEXT(J)
          INTEXT(J) = ' '
          IBL       = 0
        ENDIF
   20 CONTINUE
   30 MKORD = 28
      DO 40 J = 1, 40
        INTXT(J:J) = INTEXT(15 + J)
   40 CONTINUE
      WRITE (LU7, 99999) INTXT, NT
      CALL PLA269 (3)
      IF (IMPCEL .EQ. 1) THEN
        CALL PLA269 (3)
        WRITE (LU7,  99993)
        WRITE (LU6,  99993)
        WRITE (LU63, 99992)
      ENDIF
      WRITE (LU63, 99991) INTXT
      ifsh   = 0
      ifplus = 0
      ifnig  = 0
      ihex   = 0
      iocfl  = 0
      ko     = ' '
      gmin   = 1000000.0
      volrat = 0.0
      al     = 0.0
      be     = 0.0
      ga     = 0.0
      CALL GEN021 (XMAT, 1)
      CALL GEN021 (S,    1)
      CALL GEN074 (PLUS, 0.0, 1, 3)
      CALL GEN074 (SH,   0.0, 1, 3)
      CALL GEN074 (PEAR, 0.0, 1, NELTS)
      CALL GEN097 (NRSET, 1, NUMAT, 0)
      CALL GEN126 (FOCCU, 1, NUMAT)
      code(1) = ' '
      code(2) = ' '
      ipears  = 0
      pmin    = 0.0
      ax      = 'abc'
      nabc    = 0
      nsh     = 0
      nshtra  = 0
      nfl = 0
      IF (ifshif .EQ. 1) ifsh = 1
      IF (nigg   .EQ. 1) nig  = 1
      READ  (LU64, 99998, END = 400) A, B, C, AL, BE, GA
      CALL PLA269 (2)
      WRITE (LU7 , 99997) A, B, C, AL, BE, GA
      CALL PLA306 (NCS, NTRANS, *380)
      IF (NSHTRA .GT. 0) THEN
        CALL PLA269 (1)
        WRITE (LU7, 99990) STCSH(NSHTRA)
        WRITE (LU6, 99990) STCSH(NSHTRA)
      ENDIF
      IW   = ISETS (1, NGR)
      IROT = ISETS (2, NGR)
      NTIO = ISETS (3, NGR)
      N    = ISETS (4, NGR)
      NW   = ISETS (5, NGR)
      ISH  = ISETS (6, NGR)
      DO 60 J = 1, N
        NS(J) = ISETS(J + 6, NGR)
        IS(J) = ISETS(J + N + 6, NGR)
   60 CONTINUE
      DO 70 J = 1, NW
        MULT(J) = ISETS(J + 2 * N + 6, NGR)
   70 CONTINUE
      IS(N + 1) = NW
      IF (IMPCEL .NE. 1) THEN
        IF (IW .EQ. 16) THEN
          IF (AL .GT. 0.0 .AND. AL .NE. 90.0) THEN
            CALL PLA269 (1)
            WRITE (LU7, 99989) A, AL
            al   = al / R
            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
            ax   = 'a-b,b-c,a+b+c'
            CALL PLA269 (1)
            WRITE (LU7, 99988) A, C
            IFMAT   = 2
            S(1, 1) = 1.0
            S(1, 2) = 0.0
            S(1, 3) = 1.0
            S(2, 1) = -1.0
            S(2, 2) = 1.0
            S(2, 3) = 1.0
            S(3, 1) = 0.0
            S(3, 2) =-1.0
            S(3, 3) = 1.0
            CALL PLA315 (*390)
          ENDIF
          IF (IFMAT .GT. 0) THEN
            CALL PLA269 (1)
            WRITE (LU7, 99987) NGR, SPGR
          ENDIF
        ENDIF
      ENDIF
      CALL PLA303 (IC, IMPCEL, LU7)
      IF (IMPCEL .NE. 1) THEN
        IF (IFMAT .EQ. 2.0) THEN
          CALL PLA315 (*390)
          CALL PLA310 (S)
        ENDIF
        IAT = 0
        IF (NIG .EQ. 1) THEN
          vol1 = vol
          ish  = 0
          iw   = 1
          irot = 1
          DO 90 I = 1, 3
            DO 80 J=1, 3
              SSAVE(J, I)  = S(J, I)
              XMSAVE(J, I) = XMAT(J, I)
   80       CONTINUE
   90     CONTINUE
          WRITE (LU63, 99986)
          IFNIG = 0
          CALL PLA312 (IFNIG)
          IF (IFNIG .EQ. 2) THEN
            CALL PLA315 (*390)
            CALL PLA310 (S)
          ENDIF
          IF (IFMAT .EQ. 1) THEN
            DO 110 J = 1, 3
              DO 100 I = 1, 3
                S(I, J) = - S(I, J)
  100         CONTINUE
  110       CONTINUE
          ENDIF
          DO 130 I = 1, 3
            DO 120 J = 1, 3
              K = (I - 1) * 3 + J
              U(K) = S(J, I)
              T(K) = SSAVE(J, I)
  120       CONTINUE
  130     CONTINUE
          CALL GEN004 (T, U, P)
          CALL PLA310 (P)
          CALL PLA269 (2)
          WRITE (LU7, 99983) AX
          CALL PLA323 (ISEQ)
          CALL PLA269 (5)
          WRITE (LU7, 99982) iseq, forms(iform(iseq))
          IF (ABS(A - B) .LT. 0.005) THEN
            CALL PLA269 (2)
            WRITE (LU7, 99981)
            IF (ABS(A - C) .LT. 0.005) THEN
              CALL PLA269 (4)
              WRITE (LU7, 99980)
              WRITE (LU7, 99979)
            ENDIF
          ELSE IF (ABS(B - C) .LT. 0.005) THEN
            CALL PLA269 (2)
            WRITE (LU7, 99980)
          ELSE IF (ABS(A - C) .LT. 0.005) THEN
            CALL PLA269 (2)
            WRITE (LU7, 99979)
          ENDIF
          CALL PLA325 (pear, ipears, pmin, kelt, ncs, ntio, *400)
          IS(N + 1) = NW
          VOL = A * B * C * SQRT(1.0 - COSG**2 - COSB**2 - COSA**2
     1        + 2.0 * COSA * COSB * COSG)
          VOLRAT = VOL / VOL1
          GOTO 250
        ENDIF
      ENDIF
      IF (IC .EQ. 1) THEN
        CODE(1) = 'a'
      ELSE IF (IC .EQ. 2) THEN
        CODE(1) = 'm'
      ELSE IF (IC .EQ. 3) THEN
        CODE(1) = 'o'
      ELSE IF (IC .EQ. 4) THEN
        CODE(1) = 't'
      ELSE IF (IC .EQ. 5) THEN
        CODE(1) = 'h'
      ELSE IF (IC .EQ. 6) THEN
        CODE(1) = 'c'
      ENDIF
      KO = SPGR(1:1)
      IF (KO .EQ. 'A' .or. KO .EQ. 'C') KO = 'S'
      CODE(2) = KO
      IF (IMPCEL .NE. 1) THEN
        IF (IW .NE. 0 .AND. IW .NE. 16) CALL PLA316
        IF (IFMAT .EQ. 2.0) THEN
          CALL PLA315 (*390)
          CALL PLA310 (S)
        ENDIF
        IF (NSH .GT. 0) THEN
          CALL PLA269 (2)
          WRITE (LU7, 99984) STCSH(nsh)
        ENDIF
        IF (NABC .GT. 0) THEN
          CALL PLA269 (2)
          WRITE (LU7, 99985) STCSH(NABC)
        ENDIF
        IF (IW .EQ. 1) THEN
          IF (ABS(A - B) .LT. 0.005) THEN
            CALL PLA269 (2)
            WRITE (LU7, 99981)
            IF (ABS(A - C) .LT. 0.005) THEN
              CALL PLA269 (4)
              WRITE (LU7, 99980)
              WRITE (LU7, 99979)
            ENDIF
          ELSE IF (ABS(B - C) .LT. 0.005) THEN
            CALL PLA269 (2)
            WRITE (LU7, 99980)
          ELSE IF (ABS(A - C) .LT. 0.005) THEN
            CALL PLA269 (2)
            WRITE(LU7, 99979)
          ENDIF
        ENDIF
        IF (ifsh .GT. 0) THEN
          DO 140 j = 1, 3
            sh(j) = shift(j, ish)
  140     CONTINUE
          CALL PLA269 (4)
          WRITE (LU7, 99978) STCSH(ish)
        ENDIF
      ENDIF
      CALL PLA302 (NGR)
      natom = 0
      kelt  = 0
  150 CALL PLA305 (NIG, *230)
      IF (MIX .NE. 1) THEN
        DO 160 I = 1, 105
          IF (ELT1 .EQ. ELN(I)) GOTO 170
  160   CONTINUE
        MIX = 1
      ENDIF
  170 CALL PLA326
      kset = 0
      IF (N .EQ. 0) THEN
        MU   = MULT(1)
        KORD = 1
        CALL PLA269 (1)
        WRITE (LU7, 99977) mu, CHAR(97)
      ELSE
        CALL PLA328 (NIG)
      ENDIF
      IF (KORD .LT. MKORD) MKORD = KORD
      fmu    = float(mu)
      fn     = fnum * fmu
      pmin   = pmin + fmu - fn
      ipears = ipears + mu
      IF (KELT .GT. 0) THEN
        DO 180 I = 1, KELT
          IF (elt1 .EQ. elt(i)) GOTO 190
  180   CONTINUE
      ENDIF
      kelt = kelt + 1
      IF (KELT .GT. NELTS) THEN
        CALL PLA269 (2)
        WRITE (LU7, 99976) NELTS
        kelt = kelt - 1
      ENDIF
      elt(kelt) = elt1
      I         = kelt
  190 pear(i)   = pear(i) + fn
      natom     = natom + 1
      IF (natom .LE. numat) THEN
        kkord(natom) = kord
        atom1(natom) = elt1
        atom2(natom) = elt2
        foccu(natom) = f
        DO 200 J = 1, 3
          XA(J, NATOM) = X(J, 1)
  200   CONTINUE
        nrset(natom) = kset
        IF (kset .GT. 0) THEN
          DO 210 i = 1, kset
            nnset(i, natom) = nset(i)
  210     CONTINUE
        ENDIF
        GOTO 150
      ELSE
       CALL PLA269 (1)
       WRITE (LU7, 99975) numat
        GOTO 400
      ENDIF
  230 ipol   = 1
      icoord = 0
      IF (nor .LT. 0) THEN
        ipol = 0
        dat  = ' '
        READ (LU64, 99974, END = 400) ansr, dat
        WRITE (LU6, '(''Special Read (Check ! )'', A, A)') ansr, dat
        IF (ansr .EQ. 'N' .or. ansr .EQ. 'n') THEN
          IF (dat .EQ. ' ') THEN
            orga(1) = 0.0
            orga(2) = 0.0
            orga(3) = 0.0
          ELSE
            READ (DAT, *) (ORGA(III), III = 1, 3)
          ENDIF
          ipol = 1
          nor  = 1
          DO 240 J = 1, 3
            orgadd(j, 1) = orga(j)
  240     CONTINUE
          CALL PLA269 (1)
          WRITE (LU7, 99972) orga
        ENDIF
      ENDIF
  250 IF (nor .LT. 0) THEN
        nor2   = -nor
        ii     = nor2 / 10
        nor    = nor2 - 10 * ii
        icoord = ii + 1
      ENDIF
      nsave = nor
      REWIND LU61
      nagain = 0
      keer   = 1
      IF (irot .GT. 1 .AND. irot .LT. 8) keer = 2
      IF (irot .EQ. 8) keer = 4
      ksave = keer
  260 CALL PLA334 (keer, nagain, ntext)
      IF (NTEXT .GT. 0) THEN
        CALL PLA269 (0)
        CALL PLA269 (2)
        WRITE (LU7, 99971) STTEXT(ntext)
      ENDIF
      nor = nsave
      IF (ipol .EQ. 0) THEN
        CALL PLA331 (natom, mkord, icoord, *400)
      ELSE
        DO 350 ior = 1, nor
          CALL PLA269 (0)
          CALL PLA269 (2)
          WRITE (LU7, 99969) ior, (orgadd(j, ior), j = 1, 3)
          sum = 0.
          DO 300 IA = 1, NATOM
            elt1 = atom1(ia)
            elt2 = atom2(ia)
            DO 270 j = 1, 3
              pos(j) = xrot(j, ia) - orgadd(j, ior)
              eps    = -0.000001
              eps1   = 1.0 + eps
              IF (pos(j) .LT. eps)  pos(j) = pos(j) + 1.0
              IF (pos(j) .GE. eps1) pos(j) = pos(j) - 1.0
  270       CONTINUE
            CALL PLA326
            CALL PLA269 (4)
            WRITE (LU7, 99970) elt1, elt2
            kord   = 0
            ipolar = 0
            CALL PLA330 (ia, np, *280)
            nsp(ia) = np
  280       IF (iflag .EQ. 1) THEN
              CALL PLA269 (5)
              WRITE (LU7, 99970) elt1, elt2
              WRITE (LU7, 99994)
              GOTO 350
            ENDIF
            DO 290 J = 1, 3
              finxyz(j, ia) = x(j, min)
  290       CONTINUE
            mul(ia) = mu
            let(ia) = kord
            sum     = sum + dmin
  300     CONTINUE
          DO 310 I = 1, 3
            orig(i) = orgadd(i, ior)
  310     CONTINUE
          IFS = 1
          IF (ngr .EQ. 85 .or. ngr .EQ. 86 .or. ngr .EQ. 88) THEN
            IF (STTEXT(ntext)(1:7) .EQ. 'x,-y,-z' .or.
     1          STTEXT(ntext)(1:6) .EQ. 'y,x,-z') IFS = 2
          ELSE
            ifs = 1
          ENDIF
          IF (ifsh .GT. 0 .or. ifplus .GT. 0) THEN
            DO 320 I = 1, 3
              IF (ifs .EQ. 1) totsh(i) = plus(i) + sh(i)
              IF (ifs .EQ. 2) totsh(i) = plus(i) + shif(i)
              IF (totsh(i) .GE. .9999) totsh(i) = totsh(i) - 1.0
              orig(i) = orig(i) + totsh(i)
              IF (orig(i) .GE. .9999) orig(i) = orig(i) - 1.0
  320       CONTINUE
            IF (minsh .GT. 0) THEN
              orig(minsh) = orig(minsh) - 2 * totsh(minsh)
              IF (orig(minsh) .LT. 0.0) THEN
  330           orig(minsh) = orig(minsh) + 1.0
                IF (orig(minsh) .LT. 0.) GOTO 330
              ENDIF
            ENDIF
          ENDIF
          IF (sum .LT. gmin)   gmin = sum
          CALL PLA327 (1, ior, natom, sum, finxyz, mul, let)
          IF (NTEXT .GT. 0) WRITE (LU61, err = 370)
     1      sum, STTEXT(ntext), (orig(k), k = 1, 3)
          DO 340 I = 1, NATOM
            WRITE (LU61, err = 370) nsp(i), (finxyz(j, i), j = 1, 3),
     1        mul(i), let(i), foccu(i)
  340     CONTINUE
  350   CONTINUE
      ENDIF
      keer = keer - 1
      IF (keer .GT. 0) GOTO 260
      IF (ntio .EQ. 0 .or. nagain .EQ. 1) GOTO 360
      keer   = ksave
      nagain = 1
      GOTO 260
  360 CALL PLA341 (natom, ihex, ipears, pmin, pear, kelt)
      GOTO 400
  370 WRITE (LU7, 99968)
      GOTO 400
  380 CONTINUE
  390 WRITE (LU6, 99967)
  400 WRITE (LU7, 99996)
      CLOSE (LU60)
      CLOSE (LU61)
      CLOSE (LU63)
      CLOSE (LU64)
      RETURN
99999 FORMAT ('Input Data for', 4X, ' :', A40, /,
     1        'Space Group Symbol : ', 16A1, /)
99998 FORMAT (6F10.4)
99997 FORMAT ('Cell Parameters : ', 3f9.5, 3f8.3, /)
99996 FORMAT (//, 'End of STRUCTURE TIDY Routine')
99995 FORMAT (70A1)
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   ', A40)
99990 FORMAT ('Origin shift due to change of setting : ', A14)
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, A10, '.')
99986 FORMAT ('REMARK Niggli-reduced cell')
99985 FORMAT ('Extra origin shift due to interchange of axes : ',
     1        A14, /)
99984 FORMAT ('Extra origin shift due to cell reduction : ', A14, /)
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 b of reduced cell are very',
     1' similar.'/)
99980 FORMAT ('WARNING : Axes b and c of reduced cell are very',
     1' similar.'/)
99979 FORMAT ('WARNING : Axes a and c of reduced cell are very',
     1' similar.'/)
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 limited to',
     1 I4, ' atoms.')
99974 FORMAT (A1, A50)
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 SUBROUTINE PLA315; determinant = 0.0',
     1        ' Stop job.')
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.', /)
      END
      SUBROUTINE PLA302 (NUM)
      COMMON /orgin/nor,orgadd(3,8),ntext,icoord
      DIMENSION igroup(230)
      data igroup/ 10,1,17,17,18,19,19,20,20,1,1,6,1,1,6,1,1,1,1,6,6,7,
     1 2*6,10*11,3*12,4*13,2*14,3*12,
     2 16*1,6*6,4,4,4*6,4*15,2*14,2,8,4*2,3,3,8*2,3,3,8*15,4*14,8*2,
     3 8,8,3,3,16*2,4*3,3*16,14,3,3,5,3,5,3,5,3,3,16,14,16,3*14,6*3,6*14
     4 ,5,8*3,4*14,5,5,6*3,4,7,9,4,9,4*4,9,4,9,4*4,9,4,4,9,4,7,9,4,7,9,
     5 8*4,9,9/
      DO 20 i = 1, 8
        DO 10 j = 1, 3
          orgadd(j, i) = 0.0
   10   CONTINUE
   20 CONTINUE
      IGR = igroup(num)
      IF (IGR .EQ. 1) THEN
        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
      ELSE IF (IGR .EQ. 2) THEN
        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
      ELSE IF (IGR .EQ. 3) THEN
        nor = 2
        orgadd(3, 2) = 0.5
      ELSE IF (IGR .EQ. 4) THEN
        nor = 2
        orgadd(1, 2) = 0.5
        orgadd(2, 2) = 0.5
        orgadd(3, 2) = 0.5
      ELSE IF (IGR .EQ. 5) THEN
        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
      ELSE IF (IGR .EQ. 6) THEN
        nor = 4
        orgadd(3, 2) = 0.5
        orgadd(2, 3) = 0.5
        orgadd(2, 4) = 0.5
        orgadd(3, 4) = 0.5
      ELSE IF (IGR .EQ. 7) THEN
        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
      ELSE IF (IGR .EQ. 8) THEN
        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
      ELSE IF (IGR .EQ. 9) THEN
        nor = 1
c x y z
      ELSE IF (IGR .EQ. 10) THEN
        nor = -31
      ELSE IF (IGR .EQ. 11) THEN
        nor = -4
        orgadd(2, 2) = 0.5
        orgadd(1, 3) = 0.5
        orgadd(1, 4) = 0.5
        orgadd(2, 4) = 0.5
      ELSE IF (IGR .EQ. 12) THEN
        nor = -2
        orgadd(2, 2) = 0.5
      ELSE IF (IGR .EQ. 13) THEN
        nor = -2
        orgadd(1, 2) = 0.5
      ELSE IF (IGR .EQ. 14) THEN
        nor = -1
      ELSE IF (IGR .EQ. 15) THEN
        nor = -2
        orgadd(1, 2) = 0.5
        orgadd(2, 2) = 0.5
      ELSE IF (IGR .EQ. 16) THEN
        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
      ELSE IF (IGR .EQ. 17) THEN
     	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
      ELSE IF (IGR .EQ. 18) THEN
        nor = -12
        orgadd(3, 2) = 0.5
      ELSE IF (IGR .EQ. 19) THEN
        nor = -22
        orgadd(2, 2) = 0.5
c x 0 z
      ELSE IF (IGR .EQ. 20) THEN
        nor = -21
      ENDIF
      RETURN
      END
      SUBROUTINE PLA303 (IC, IMPCEL, LU)
      COMMON /STBL4/ ipol, r, ngr, iocfl, vol, nfl, volrat
      COMMON /cel/ a,b,c,al,be,ga,alf,bet,gam,cosa,cosb,cosg
      COMMON /matr/ ifmat, ifsh, ifplus, xmat(3, 3), plus(3), sh(3),
     1 nabc, nsh, nshtra, ifnig, xmsave(3, 3), shif(3), minsh
      COMMON /trans/ s(9), u(9), t(9), p(9)
      vol  = 0.0
      alf  = al / r
      bet  = be / r
      gam  = ga / r
      cosb = cos(bet)
      IF (NGR .LE. 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 .GT. 0.0001) VOL = a * b * c * sqrt(V)
      ELSE
        al   = 90.0
        ga   = 90.0
        cosa = 0.0
        cosg = 0.0
        alf  = 90.0 / r
        gam  = alf
        IF (NGR .GE. 3 .AND. NGR .LE. 15) THEN
          ic = 2
          VOL = a * b * c * sin(bet)
          IF (IMPCEL .EQ. 1) RETURN
          IF (be .LT. 90.0) THEN
            be    = 180.0 - be
            bet   = be / r
            cosb  = - cosb
            ifmat = 2
            CALL GEN074 (U, 0.0, 1, 9)
            u(1) = -1.0
            u(5) = -1.0
            u(9) =  1.0
            CALL GEN004 (S, U, P)
            CALL GEN125 (P, S)
            CALL PLA269 (2)
            WRITE (LU, 99999) be
          ENDIF
        ELSE
          be   = 90.0
          cosb = 0.0
          bet  = 90.0 / r
          IF (NGR .GE. 16 .AND. NGR .LE. 74) THEN
            ic  = 3
            vol = a * b * c
          ELSE
            b = a
            IF (NGR .GE. 75 .AND. NGR .LE. 142) THEN
              ic  = 4
              VOL = a * a * c
            ELSE IF (NGR .GE. 143 .AND. NGR .LE. 194) THEN
              ga   = 120.0
              gam  = ga / r
              cosg = -0.5
              ic   = 5
              vol  = 0.86603 * a * a * c
            ELSE IF (NGR .GE. 195) THEN
              c   = a
              ic  = 6
              VOL = a**3
            ENDIF
          ENDIF
        ENDIF
      ENDIF
      IF (VOL .LT. 0.0001) THEN
        CALL PLA269 (1)
        WRITE (LU, 99998)
      ENDIF
      RETURN
99999 FORMAT ('In order to Obtain Obtuse Angle beta, Transform Axes',
     1' by -a,-b,c', /, ' new beta =', f9.3)
99998 FORMAT ('Parameters DO not Define Valid Cell ')
      END
      SUBROUTINE PLA305 (NIG, *)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /at/ iat, pos(3), ihex, fnum
      COMMON /atch/ elt1, elt2, f
      COMMON /matr/ ifmat, ifsh, ifplus, xmat(3, 3), plus(3), sh(3),
     1 nabc, nsh, nshtra, ifnig, xmsave(3, 3), shif(3), minsh
      CHARACTER*1 t(70), dat(30), aux*10, f*5, lab*4
      CHARACTER elt1*2, elt2*4
      DIMENSION numb(2), x(3)
      elt1 = ' '
      elt2 = ' '
      f    = ' '
      isl  = 0
      fnum = 1.0
      CALL GEN126 (DAT, 1, 30)
      IF (IAT .EQ. 0) THEN
        CALL PLA269 (13)
        WRITE (LU7, 99993)
      ENDIF
   10 READ (LU64, 99999) T
      iat = iat + 1
      DO 20 i = 1, 4
        lab(i:i) = t(i)
   20 CONTINUE
      IF (lab .EQ. 'DEFI') THEN
        WRITE (LU63, 99999) T
        GOTO 10
      ENDIF
      DO 50 i = 1, 70
        IF (t(i) .EQ. '.' .or. t(i) .EQ. '/' .or. t(i) .EQ. '0'
     1   .AND. t(i - 1) .EQ. ' ')  THEN
          IF (i .LT. 3) THEN
            CALL PLA269 (1)
            WRITE (LU7, 99998) t
            GOTO 10
          ENDIF
          IF (t(i) .EQ. '.') THEN
            ij = i - 1
            IF (t(i - 1) .EQ. '0') ij = i - 2
            IF (t(i - 2) .EQ. '+' .or. t(i - 2) .EQ. '-') ij = i - 3
            IF (t(i - 1) .EQ. '-' .or. t(i - 1) .EQ. '+') ij = i - 2
          ELSE IF (t(i) .EQ. '/') THEN
            i1 = i - 1
            DO 30 j = 1, i1
              k = i - j
              IF (t(k) .EQ. ' ') GOTO 40
   30       CONTINUE
            WRITE (LU6, 99988)
            GOTO 10
   40       ij = k
          ELSE
            ij = i - 1
          ENDIF
        ELSE
          GOTO 50
        ENDIF
        GOTO 60
   50 CONTINUE
      ij = 70
   60 ie = 1
      DO 70 i = 1, ij
        IF (t(i) .NE. ' ') THEN
          kk = ichar(t(i))
          IF (kk .LT. 65 .OR. kk .GT. 90 ) THEN
            IF (kk .GE. 97 .AND. kk .LE. 122) THEN
              kk   = kk - 32
              t(i) = char(kk)
            ELSE
              GOTO 70
            ENDIF
          ENDIF
          elt1(1:1) = t(i)
          kk = ichar(t(i + 1))
          IF (kk .LT. 97 .OR. kk .GT. 122) THEN
            IF (kk .GE. 65 .AND. kk .LE. 90) THEN
              kk       = kk + 32
              t(i + 1) = char(kk)
            ELSE
              elt1(2:2) = ' '
              i1        = i + 1
              GOTO 80
            ENDIF
          ENDIF
          elt1(2:2) = t(i + 1)
          i1        = i + 2
          IF (elt1 .ne. 'En') GOTO 80
          RETURN 1
        ENDIF
   70 CONTINUE
      WRITE (LU6, 99998) T
      WRITE (LU7, 99998) T
      GOTO 10
   80 IF (ij .EQ. 70) THEN
        DO 90 i = i1, 70
          IF (t(i) .EQ. '0' .AND. t(i - 1) .EQ. ' ') GOTO 100
   90   CONTINUE
        GOTO 110
  100   ij = i - 2
      ENDIF
  110 DO 120 i = i1, ij
        IF (t(i) .ne. ' ') GOTO 130
  120 CONTINUE
      IF (ij .EQ. 70) GOTO 180
      GOTO 150
  130 elt2(1:1) = t(i)
      DO 140 j = 1, 3
        k = i + j
        IF (t(k) .EQ. ' ') GOTO 150
        ie = j + 1
        elt2(ie:ie) = t(k)
  140 CONTINUE
  150 DO 170 j = 4, 1, -1
        IF (elt2(j:j) .NE. ' ') THEN
          IF (j .EQ. 4) GOTO 180
          DO 160 k = 1, j
            l           = j + 1 - k
            kk          = 5 - k
            elt2(kk:kk) = elt2(l:l)
  160     CONTINUE
          elt2(1:kk-1) = ' '
          GOTO 180
        ENDIF
  170 CONTINUE
  180 IF (ij .EQ. 70) THEN
        CALL GEN074 (POS, 0.0, 1, 3)
        fnum = 1.0
        CALL PLA269 (2)
        WRITE (LU7, 99992)
        WRITE (LU7, 99997) elt1, elt2
        GOTO 420
      ENDIF
      j  = 0
      ij = ij + 1
      DO 260 k = 1, 3
        DO 200 i = ij, 70
          IF (t(i) .ne.' ') GOTO 220
  200   CONTINUE
        k1      = (k - 1) * 10 + 2
  210   dat(k1) = '0'
        IF (k1 .GT. 20) GOTO 270
        k1 = k1 + 10
        GOTO 210
  220   j = j + 1
        dat(j) = t(i)
        i2 = i + 1
        DO 230 ii = i2, 70
          IF (t(ii) .EQ. ' ') GOTO 240
          j      = j + 1
          dat(j) = t(ii)
  230   CONTINUE
        GOTO 320
  240   j1 = j + 1
        j2 = (j1 / 10 + 1) * 10
        IF (j1 .LT. j2) THEN
          DO 250 l = j1, j2
            dat(l) = ' '
  250     CONTINUE
        ENDIF
        ij = ii + 1
        j  = j2
  260 CONTINUE
  270 DO 280 ii = ij, 70
        IF (t(ii) .ne. ' ') GOTO 290
  280 CONTINUE
      GOTO 310
  290 i1 = ii + 4
      j  = 0
      DO 300 i = ii, i1
        IF (t(i) .EQ. '/') isl = i
        j = j + 1
        f(j:j) = t(i)
  300 CONTINUE
  310 CALL PLA269 (2)
      WRITE (LU7, 99992)
      WRITE (LU7, 99996) elt1, elt2, dat, f
  320 IF (isl .EQ. 0) THEN
        READ (f, 99991) fnum
      ELSE
        num1 = 0
        num2 = 0
        DO 330 i = ii, isl - 1
          READ (t(i), 99990, err = 360) n
          num1 = 10 * num1 + n
  330   CONTINUE
        DO 340 i = isl + 1, i1
          IF (t(i) .EQ. ' ') GOTO 350
          READ (t(i), 99990, err = 360) n
          num2 = 10*num2 + n
  340   CONTINUE
  350   fnum = float(num1) / float(num2)
      ENDIF
      IF (fnum .EQ. 0.0) fnum = 1.0
      GOTO 370
  360 CALL PLA269 (1)
      WRITE (LU7, 99995) f
      fnum = 1.0
  370 DO 410 i = 1, 3
        j1  = (i - 1) * 10 + 1
        j2  = j1 + 9
        aux = ' '
        jj  = 0
        DO 380 k = j1, j2
          if (dat(k) .EQ. '/') GOTO 390
          jj = jj + 1
          aux(jj:jj) = dat(k)
  380   CONTINUE
        READ (aux, 99989) pos(i)
        GOTO 410
  390   kkk     = 1
        numb(1) = 0
        numb(2) = 0
        neg     = 1
        DO 400 k = j1, j2
          IF (dat(k) .NE. ' ') THEN
            IF (dat(k) .NE. '/') THEN
              IF (dat(k) .EQ. '-') THEN
                neg = -1
                GOTO 400
              ENDIF
              kk = ichar(dat(k)) - ichar('0')
              IF (kk .LT. 0 .OR. kk .GT. 9) THEN
                WRITE (LU7, 99987) dat(k), dat
                RETURN
              ENDIF
              numb(kkk) = kk + 10 * numb(kkk)
            ELSE
              kkk = 2
            ENDIF
          ENDIF
  400   CONTINUE
        f1     = numb(1) * neg
        f2     = numb(2)
        pos(i) = f1 / f2
  410 CONTINUE
  420 IF (ifsh .EQ. 1) THEN
        DO 430 j = 1, 3
          pos(j) = pos(j) - sh(j)
  430   CONTINUE
      ENDIF
      IF (ifmat .EQ. 2) THEN
        DO 440 j = 1, 3
          x(j) = pos(1) * xmat(1, j) + pos(2) * xmat(2, j)
     1         + pos(3) * xmat(3, j) - plus(j)
  440  CONTINUE
       DO 450 j = 1, 3
         pos(j) = x(j)
  450  CONTINUE
      ENDIF
      IF (ifmat .EQ. 1) THEN
         DO 460 j = 1, 3
           pos(j) = 1.0 - pos(j)
  460    CONTINUE
      ENDIF
      DO 490 j = 1, 3
  470   IF (pos(j) .LT. -0.000001) THEN
          pos(j) = pos(j) + 1.0
          GOTO 470
        ENDIF
  480   IF (pos(j) .GE. 0.999999) THEN
          pos(j) = pos(j) - 1.0
          GOTO 480
        ENDIF
  490 CONTINUE
      IF (ihex .EQ. 1) THEN
        DO 500 j = 1, 3
          IF (abs(pos(j)) .LT. 0.001) pos(j) = 0.0
  500   CONTINUE
      ENDIF
      IF (nig .EQ. 0) THEN
        IF (ifmat .GT. 0 .or. ifsh .EQ. 1 .or. ihex .EQ. 1) THEN
          CALL PLA269 (1)
          WRITE (LU7, 99994) elt1, elt2, pos, f
        ENDIF
      ENDIF
      RETURN
99999 FORMAT (70A1)
99998 FORMAT ('Error, no element name; Write this line again',
     1        /, ' ', 70a1)
99997 FORMAT (a2, 1x, a4, 2x, '0         0         0')
99996 FORMAT (a2, 1x, a4, 2x, 30a1, 5x, a5)
99995 FORMAT ('WARNING : Error in reading occupation factor', A5,
     1 ' we take value f=1')
99994 FORMAT ('Input changed into : ', a2, a4, 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 assymmetric 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 PLA305 : ',
     1        a1, 2x, 30a1)
      END
      SUBROUTINE PLA306 (NCS, NTRANS, *)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /STBL4/ ipol, rr, ngr, iocfl, vol, nfl, volrat
      COMMON /BRZ/ ngo, r, t, nbr
      COMMON /BUR/ nt, spgr
      COMMON /MATR/ ifmat, ifsh, ifplus, xmat(3, 3), plus(3), sh(3),
     1 nabc, nsh, nshtra, ifnig, xmsave(3, 3), shif(3), minsh
      COMMON /TRANS/ ss(9), dummy(27)
      CHARACTER*1 HBR(7), HS(14), NT(16), UP(6), low(6)
      CHARACTER*10 spgr, spg(230), aux*17
      INTEGER SYS, GES(3, 3, 36), NET(3), IN(7), GET(3, 25), NT1(1623),
     1 IS(14), S(3), LGT(48), NT2(45), cent(230), Z, MM(43, 3),
     2 M4(20, 18), LF(216), Q(3, 4, 5), SEM(3, 3, 18), SC(3, 3),
     3 LGN(3, 45), SY(45), T(48, 3), R(48, 3, 3), tgrp(541), trafo(541),
     4 NGT(48, 48), LIST(230)
      DIMENSION abc(9,30)
      DATA UP /'A', 'B', 'C', 'D', 'M', 'N'/
      DATA LOW/'a','b','c','d','m','n'/
      DATA SEM/1,3*0,1,3*0,1,96,3*0,1,3*0,1,1,3*0,96,3*0,1,1,3*0,1,3*0,9
     *6,1,3*0,96,3*0,2*96,3*0,1,3*0,2*96,3*0,96,3*0,1,96,3*0,96,3*0,3*96
     *,3*0,1,3*0,2*96,3*0,96,5*0,96,6*0,3*96,8*0,1,6*0,64,128,32,6*0,128
     *,64,3*0,1,3*0,128,64,3*0,96,3*0,3*48,96,3*0,96,0,2*96,2*0,96,48,2*
     *0,96/
      DATA NT2/0,1,14,40,53,58,68,73,107,141,175,192,194,200,212,218,224
     *,234,238,242,244,248,251,252,258,262,264,266,272,277,283,291,292,3
     *09,343,360,467,469,475,495,499,501,505,507,527/
      DATA Q/4*0,2*12,9*0,12,0,12,9*0,2*12,11*0,3*12,0,3*12,4*0,3*12,6*0
     */
      DATA LF/1,1,-2,1,-3,1,-4,1,2,1,3,1,4,1,2,-3,-4,1,3,-2,-4,1,4,-2,-3
     *,1,4,2,3,1,4,-15,-14,1,4,15,14,1,4,15,14,-2,-3,-13,-16,1,4,2,3,-13
     *,-16,-14,-15,1,4,13,16,-2,-3,-14,-15,1,4,2,3,13,16,14,15,1,3,5,1,3
     *,5,-9,-11,-7,1,3,5,-10,-8,-12,1,3,5,9,11,7,1,3,5,10,8,12,1,3,5,-4,
     *-2,-6,1,4,3,5,2,6,1,4,3,5,2,6,-9,-11,-7,-10,-8,-12,1,3,5,10,8,12,-
     *9,-11,-7,-4,-2,-6,1,3,5,9,11,7,-10,-8,-12,-4,-2,-6,1,4,3,5,2,6,9,1
     *1,7,10,8,12,1,4,2,3,5,9,7,12,8,10,6,11,1,4,2,3,5,9,7,12,8,10,6,11,
     *-13,-16,-14,-15,-17,-21,-19,-24,-20,-22,-18,-23,1,4,2,3,5,9,7,12,8
     *,10,6,11,13,16,14,15,17,21,19,24,20,22,18,23/LGN/1,0,0,2,0,0,2,0,0
     *,2,0,0,2,0,0,2,0,0,2,0,0,3,4,0,3,4,0,3,4,0,3,4,0,3,0,0,3,0,0,5,7,0
     *,5,3,0,5,3,0,3,5,0,2,0,0,2,4,0,2,4,0,2,6,0,2,5,0,5,0,0,5,0,0,7,10,
     *0,7,4,0,4,7,0,10,7,0,2,5,0,5,14,0,5,14,0,2,0,0,4,2,0,4,2,0,4,2,0,
     *7,8,6,5,0,0,3,6,0,10,11,13,8,10,0,8,10,0,14,19,22,5,8,0,26,5,37,14
     *,5,0/
      DATA GES/1,3*0,1,3*0,1,1,3*0,-1,3*0,2*-1,3*0,1,3*0,2*-1,3*0,
     *-1,3*0,1,0,1,3*0,1,1,3*0,1,3*0,2*-1,3*0,-1,3*0,1,-1,3*0,-1,3*0,-1,
     *1,4*0,1,1,3*0,1,3*0,1,-1,3*0,-1,3*0,-1,1,3*0,-1,3*0,2*-1,3*0,
     *1,2*0,-1,0,-1,4*0,-1,0,-1,0,1,4*0,1,0,1,0,-1,4*0,1,0,1,0,1,4*0,
     *2*-1,4*0,-1,0,-1,0,-1,4*0,1,0,1,0,1,4*0,-1,0,1,0,1,4*0,1,0,-1,
     *3*0,-1,0,-1,0,-1,4*0,-1,0,1,0,1,4*0,1,0,-1,0,1,4*0,1,0,1,0,-1,0,0,
     *1,3*0,1,3*0,1,1,1,0,-1,4*0,1,0,1,0,2*-1,3*0,1,-1,3*0,-1,3*0,1,2*-1
     *,0,1,4*0,1,0,-1,0,1,1,3*0,1,0,1,0,1,4*0,-1,1,1,0,0,-1,3*0,-1,1,0,
     *0,2*-1,3*0,-1,0,-1,0,-1,4*0,3*-1,0,0,1,3*0,2*-1,0,0,1,1,3*0,-1/
      DATA IS/1,5,6,7,11,18,13,17,21,22,28,24,31,29/
      DATA HBR/'P','A','B','C','F','I','R'/
      DATA HS/'M','A','B','C','N','D','-','1','2','3','4','5','6','/'/
      data  GET/3*0,12,3*0,12,3*0,12,
     *0,3*12,0,3*12,0,3*12,0,3*6,0,3*6,0,3*6,18,2*6,0,0,4,0,0,6,0,0,8,
     *0,12,6,0,0,16,0,0,18,0,0,20,12,0,6,2*12,18,12,12,6,6,18,18,6,6,18/
      DATA (NT1(i),i=1,249)
     */656,96,12351,8266,20521,286,8456,20711,381,12636,20806,476,
     *  8646,12731,0,572,0,4657,0,12827,0,20997,0,573,0
     *,4658,0,20998,0,574,0,12829,0,20999,0,575,0,4660,
     * 0,12830,586,4671,8756,21011,596,4681,21021,603,8773,21028,619,
     * 4704,8789,666,12921,8836,21091,761,0,576,0,4661,0,12831,
     * 0,21001,0,577,634,4719,8804,21059,644,682,4767,8852,12937,
     *21107,17022,699,8869,21124,12954,787,4872,685,8855,12940,21110,701
     *,8871,12956,21126,789,795,812,797,778,4863,693,4778,695,716,718,78
     *1,810,17065,117,4202,8287,12372,20542,16457,402,12657,20827,4487,1
     *34,8304,126,12381,4211,20551,411,20836,12666,4496,317,419,507,435,
     *308,8478,323,8493,339,513,529,150,498,18206,160,4245,8330,12415,20
     *585,16500,161,4246,20586,8331,172,12427,350,4435,8520,20775,351,20
     *776,4436,8521,362,456,363,551,455,12710,448,12703,543,449,544,550,
     *173,18215,736,4821,8906,12991,21161,17076,744,12999,831,4916,737,8
     *907,832,839,745,840,21265,1986,22411,2081,22506,2176,2271,2366,226
     *01,2012,22437,2014,2205,2206,2038,22440,2039,2226,2227,22573,22574
     *,1922,22347,1945,1923,1946,22386,1965,22390,1968,22393,1967,1969,2
     *066,22491,2067,2161,2162,2256,2257,2351,2352,22586,3031,27541,3221
     *,3316,2947,27536,2949,27537,2961,2985,2951,27538,3141,3236,3009/
       data (NT1(i),i=250,500)/ 3199,
     *   3294,3411,3506,3601,3981,3696,3886,3791,3437,3463,3725,3746,339
     *0,3393,3347,3370,3491,3586,3966,3681,3871,3776,749,17089,21174,844
     *,21269,1924,18264,22349,1956,18287,22387,2068,22493,18408,2163,225
     *8,2353,22588,18503,3126,856,9026,13111,21281,1236,9406,21661,1426,
     *13681,21851,1616,9786,13871,951,1331,1521,1711,0,578,0,4663,0,
     * 12833,0,21003,0,579,0,4664,0,21004,0,580,0,
     * 12835,0,21005,0,581,0,4666,0,12836,0,582,0,
     *583,0,584,0,585,657,4742,8827,21082,658,4743,21083,659,8829,
     *21084,660,4745,8830,661,662,663,664,112,4197,8282,12367,20537,1645
     *2,129,20547,8299,115,20538,12370,125,12379,146,123,20556,12377,828
     *3,4208,131,8300,148,122,20554,4207,113,20540,4198,124,130,145,116,
     *132,147,319,20832,4387,12384,8489,302,20822,8472,338,313,4398,321,
     *8491,305,315,336,400,20728,8285,4482,12655,397,20727,12652,433,416
     *,12671,408,4493,414,431,410,415,401,409,12664,407,4397,432,398,417
     *,430,528,505,526,509,12669,495,8475,503,492,511,335,320,8490,303,4
     *483,322,312,337,314,20739,306,512,527,496,525,504,510,502,493,1820
     *5,2936,27446,2461,22886,2556,2746,2841,23076,2392,22817,2418,22820
     *,2679,2704,2394,2419,2677,2703,2511,2490,2797,2776,2512,2491,2796,
     *2775,23048,23049,2852,27441,2854,27442,2866/
      DATA (NT1(i),i=501,1000) /                  2890,4007,4033,4105,41
     *26,4076,4171,119,120,20544,20545,16459,16460,531,532,151,152,16482
     *,16483,499,500,18169,18170,18192,18193,20677,20678,179,180,20604,2
     *0605,16519,16520,559,560,274,275,20699,20700,18229,18230,5*0,3*2,3
     **3,3*4,8*0,6*1,6*3,6*5,4*0,3*1,3*2,3*6,4*0,1,8*0,2*2,4*0,3,6*0,4*6
     *2,2*30,4*93,4*124,153,66,214,127,1,1,2*31,155,186,217,5,180,341,6*
     *0,4*93,2*60,4*31,4*155,36,123,157,215,2,2,2*62,186,124,217,180,4,3
     *41,6*0,4*31,2*90,4*62,4*186,122,35,216,187,3,3,2*93,124,155,217,4,
     *150,341,6*0,2*90,2*1,2*62,186,5,120,2*126,4*0,14,3,18,16,0,0,186,3
     *,7,2*93,217,90,216,480,606,0,0,93,186,217,496,0,0,2*93,186,217,0,0
     *,6,423,111,90,7,543,112,16,0,0,15,17,0,0,2*90,0,90,0,0,15,17,0,15,
     *17,0,0,13,19,15,17,3,0,93,3,90,0,3,0,90,0,19,13,17,15,3,3*0,2*5,3*
     *0,2*210,360,3*0,360,210,3*690,5*0,3*62,3*93,3*124,31,186,155,217,8
     **0,6*31,6*93,6*155,2*62,2*186,2*124,2*217,4*0,3*31,3*62,3*186,93,1
     *55,124,217,6*0,3*1860,3*2790,2*4650,5580,5*930,2*3720,6510,3*901,3
     **31,4591,1981,5461,2851,3811,6421,5*1802,3*62,6452,2*1082,2*3692,2
     *822,4712,5432,5*93,3*2703,5613,2*1923,2*4533,3663,6483,1053,3785,1
     *55,2*995,2*4505,5525,2735,2015,6365,5554,1114,6334,2*3604,2*124,46
     *84,2764,1894,5406,2*1836,2*186,3756,966,6396,2*4626,2916,1957/
      DATA (NT1(i),i=1001,1623)  /5497,
     * 217,6307,1027,3637,4567,2887,9278,4*0,3,181,184,162,2*0,2*2790,54
     *66,6426,5580,6510,36,2856,2700,90,6366,5526,6480,210,2736,156,2160
     *2,9992,0,0,2*90,0,90,0,2790,93,2703,0,93,6*0,2*6306,4*6300,2*6,2*1
     *0,2*6310,2*9902,6*0,2*6,4*5,2*10,1,13*2,26*3,13*4,5*5,10*6,5*7,34*
     *5,34*6,34*7,5*8,17,11*8,10,18,18*9,7*10,18,10,18,12*10,8*15,2*13,1
     *1,14,2*11,4*16,10*13,2*16,8*11,12,17,4*12,17,2*12,17,3*12,8,4*12,1
     *77*8,11,14,26*10,11,14,11,14,8*11,4*12,2*8,4*12,2*8,2*12,4*8,6*12,
     *2*8,6*12,2*8/
      data         MM/1,2,3,4,5,8,9,129,444,6654,669,10029,894,13404,111
     *9,16779,1344,20154,6,172,11,131,146,161,446,6671,10031,1346,20171,
     *157,10,127,130,145,202,13,133,148,163,178,193,448,6688,8,1,2,3,4,5
     *,6,9,129,10,157,0,444,669,1119,1344,6654,10029,16779,20154,23*-1,8
     *,1,2,3,4,5,6,9,129,0,444,669,894,1344,6654,10029,13404,20154,25*-1
     */M4/1,2,3,0,4,5,0,6,7,3*0,8,9,10,11,12,13,14,15,16,17,18,19,20,21,
     *0,22,23,24,25,9*0,26,27,28,0,29,30,0,31,32,11*0,33,34,35,0,36,37,0
     *,38,39,11*0,40,41,0,42,43,44,0,45,46,47,48,9*0,49,50,51,0,52,53,0,
     *54,55,56,57,10*0,58,0,0,59,0,60,61,0,62,63,9*0,64,65,66,67,68,69,7
     *0,71,72,73,10*0,74,75,76,0,77,78,0,79,80,12*0,81,0,0,82,0,0,83,0,8
     *4,85,86,8*0,87,19*0,88,19*0,89,19*0,90,19*0,91,19*0,92,19*0,93,19*
     *0,94,19*0/
      data SY/1,6*2,4*3,6*4,11*5,3*6,1,3*2,3,5,4,4,4*5,6,6/IRC/72/
      data (tgrp(i),i=1,466)/1,6,3*8,7,9,9,7,9,9,7,9,9,6,6,6*8,2*7,4*9,
     1 2*7,4*9,2*7,4*9,6,3*8,7,9,9,7,9,9,7,9,9,3,3*5,4,3,3,6*5,4,4,3,3*5
     2,4,25,35,2*38,44,42,28,40,46,39,26,36,28,39,40,46,32,2*41,45,2*29,
     3 2*33,26,36,27,37,2*30,34,2*31,43,25,38,35,38,44,42,28,40,46,39,
     4 26,36,28,39,40,46,32,45,2*41,2*29,2*33,26,36,27,37,2*30,34,2*31,
     5 43,25,2*38,35,44,42,28,40,46,39,26,36,28,39,40,46,32,45,2*41,2*29
     6,2*33,26,36,27,37,2*30,34,2*31,43,16,3*21,23,22,17,20,17,20,17,20,
     7 3*18,19,24,81,82,75,79,76,77,76,80,99,107,100,101,102,103,
     8 108,104,105,106,109,110,111,121,112,113,114,122,115,119,116,
     9 120,117,118,89,97,90,91,92,93,94,91,92,98,143,146,144,144,
     * 156,160,158,161,157,159,150,155,152,152,149,151,151,174,168,169,
     1 169,171,171,173,183,184,185,186,187,188,189,190,177,178,178,180,
     2 180,182,195,196,197,198,199,215,216,217,218,219,220,207,211,209,
     3213,208,213,214,210,2,10,3*12,13,2*15,13,2*15,13,2*15,11,3*14,2*10
     4,6*12,2*13,4*15,2*13,4*15,2*13,4*15,2*11,6*14,10,3*12,13,2*15,13,
     5 2*15,13,2*15,11,3*14,47,3*65,71,69,51,74,63,51,74,63,53,64,53,49,
     6 72,2*67,66,55,64,58,51,74,63,51,74,63,2*57,2*59,2*62,49,72,2*67,
     7 66,51,74,63,52,54,68,54,68,57,60,50,49,72,2*67,66,51,74,63,52,54,
     8 68,54,68,57,60,50,61,53,54,68,55,64,56,57,60,62,48,2*52,53,64,53,
     9 64,56,59,50,53,54,68,55,64,56,57,60,61,73,62,2*52,2*58,2*60,2*62/
      data (tgrp(i),i=467,541) /70,147,148,83,87,84,85,86,88,123,139,124
     1,140,125,126,127,128,129,130,131,132,133,134,135,136,137,138,141,
     2 142,164,166,165,167,162,163,191,192,193,194,175,176,2*221,2*229,
     3 2*225,2*222,2*223,2*226,2*224,2*227,2*228,2*230,2*200,2*204,
     4 2*202,2*201,2*205,2*206,2*203/
      data trafo /0,4,4,2,7,2,2,27,4,4,7,6,22,24,0,0,5,5,0,0,9,9,5,5,5,
     1 5,9,9,4*0,2*29,8,8,25,25,2*20,1,1,3,11,1,1,31,3,3,11,10,21,
     2 23,4,4,2,7,4,0,0,5,5,0,0,9,9,0,0,1,1,3,11,1,3*1,5,5*1,5,1,1,5,1,
     3 5,5,1,1,5,1,5,1,5,1,5,5,1,5,1,5,1,5,1,1,2,3,7*2,3,3,3,3,2,3,3,3*2
     4,3,3,2,3,6*2,3,2,3,2,2,0,0,4,6*0,4,0,0,4,0,4,4,3*0,4,4,0,4,0,4,4,
     5 3*0,4,0,4,3*0,1,2,5*0,1,1,2,2,0,2,1,8*0,-1,32*0,2*-1,4*0,-1,9*0,
     6 -1,2*0,-1,3*0,-1,0,-1,11*0,-1,0,-1,17*0,-1,3*0,4,2,4,7,2,2,47,4,4
     7,7,6,42,44,4,2,4,6,0,0,5,5,0,0,2*9,4*5,9,9,4*0,2*49,8,8,2*45,2*40
     8 ,0,0,5,5,0,0,8,8,1,1,3,11,1,1,51,3,3,11,10,41,43,1,1,3,10,
     8 0,1,2,3*0,4,0,3,2,3,3*0,3,1,1,0,3,1,1,3,1,0,4,1,3,2,5,1,5,0,2,4,
     9 3*2,1,4,2,1,5,2,3*1,2,2,0,2,3*0,2,5,0,5,1,4,5,4,4,5,5,3,4,2,
     * 3,5,0,0,2,1,0,4,3,5,0,0,3,4,4,2,2,4*1,3,3,0,5,2,2,3*0,1,4,2,0,2,
     1 1,5,0,3,0,74*0/
      data list/1,292,59,67,63,15,29,19,31,310,336,314,324,340,326,
     1 176,182,188,191,183,179,181,180,192,142,152,168,148,163,170,174,
     2 158,165,172,145,153,169,143,155,149,160,147,175,146,159,150,361,
     3 438,412,411,384,439,373,430,451,434,409,461,392,455,456,465,372,
     4 374,364,416,378,431,366,467,365,413,457,368,
     5 195,197,198,199,196,200,193,194,470,472,473,474,471,475,225,227,
     6 228,229,230,231,232,233,226,234,201,203,204,205,206,208,209,210,
     7 202,207,211,212,213,215,216,217,219,221,223,224,220,222,214,218,
     8 476,478,480,481,482,483,484,485,486,487,488,489,490,491,492,493,
     9 477,479,494,495,235,237,238,236,468,469,249,245,250,247,251,248,
     * 246,239,243,241,244,240,242,500,501,496,498,497,499,253,254,255,
     1 256,257,258,252,506,507,267,268,269,270,271,272,259,260,261,262,
     2 263,264,265,266,502,503,504,505,273,274,275,276,277,529,535,533,
     3 541,531,537,539,284,288,286,291,285,289,287,290,278,279,280,281,
     4 282,283,509,515,517,521,513,519,523,525,511,527/
      data cent/4*1,3,1,1,3,3,1,1,3,1,1,3,4*1,3,3,4,5,5,10*1,3*3,4*2,
     1 4,4,3*5,16*1,6*3,4,4,4*5,4*1,5,5,1,5,4*1,5,5,8*1,5,5,8*1,4*5,
     2 8*1,4*5,16*1,4*5,3*1,6,1,6,6*1,6,4*1,6,6,4*1,6,6,28*1,4,5,1,5,
     3 1,1,4,4,5,1,5,1,1,4,4,5,1,1,5,1,4,5,1,4,5,4*1,4*4,5,5/
      data (spg(i), i = 1, 119)
     1/'P 1','P -1','P 2','P 21','C 2','P m','P c','C m','C c','P 2/m',
     2 'P 21/m','C 2/m','P 2/c','P 21/c','C 2/c','P 2 2 2','P 2 2 21',
     3 'P 21 21 2','P 21 21 21','C 2 2 21','C 2 2 2','F 2 2 2','I 2 2 2'
     4,'I 21 21 21','P m m 2','P m c 21','P c c 2','P m a 2','P c a 21',
     5 'P n c 2','P m n 21','P b a 2','P n a 21','P n n 2','C m m 2',
     6 'C m c 21','C c c 2','A m m 2','A b m 2','A m a 2','A b a 2',
     7 'F m m 2','F d d 2','I m m 2','I b a 2','I m a 2','P m m m',
     8 'P n n n','P c c m','P b a n','P m m a','P n n a','P m n a',
     9 'P c c a','P b a m','P c c n','P b c m','P n n m','P m m n',
     * 'P b c n','P b c a','P n m a','C m c m','C m c a','C m m m',
     1 'C c c m','C m m a','C c c a','F m m m','F d d d','I m m m',
     2 'I b a m','I b c a','I m m a',
     3 'P 4','P 41','P 42',' ','I 4','I 41','P -4','I -4',
     4 'P 4/m','P 42/m','P 4/n','P 42/n','I 4/m','I 41/a',
     5'P 4 2 2','P 4 21 2','P 41 2 2','P 41 21 2','P 42 2 2','P 42 21 2'
     6,2*' ','I 4 2 2','I 41 2 2','P 4 m m','P 4 b m','P 42 c m','P 42 n
     7 m','P 4 c c','P 4 n c','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','P -4 21 m','P -4 21 c
     9','P -4 m 2','P -4 c 2','P -4 b 2','P -4 n 2','I -4 m 2'/
      data (spg(i),i=120,230) / 'I -4 c 2','I -4 2 m','I -4 2 d',
     1 'P 4/m m m','P 4/m c c','P 4/n b m','P 4/n n c','P 4/m b m',
     2 'P 4/m n c','P 4/n m m','P 4/n c c','P 42/m m c','P 42/m c m',
     3 'P 42/n b c','P 42/n n m','P 42/m b c','P 42/m n m','P 42/n m c',
     4 'P 42/n c m','I 4/m m m','I 4/m c m','I 41/a m d','I 41/a c d',
     5 'P 3','P 31',' ','R 3','P -3','R -3','P 3 1 2','P 3 2 1',
     6 'P 31 1 2','P 31 2 1',' ',' ','R 3 2','P 3 m 1','P 3 1 m',
     7 'P 3 c 1','P 3 1 c','R 3 m','R 3 c','P -3 1 m','P -3 1 c',
     8 'P -3 m 1','P -3 c 1','R -3 m','R -3 c','P 6','P 61',' ','P 62',
     9 ' ','P 63','P -6','P 6/m','P 63/m','P 6 2 2','P 61 2 2',' ',
     * 'P 62 2 2',' ','P 63 2 2','P 6 m m','P 6 c c','P 63 c m',
     1'P 63 m c','P -6 m 2','P -6 c 2','P -6 2 m','P -6 2 c','P 6/m m m'
     2,'P 6/m c c','P 63/m c m','P 63/m m c','P 2 3','F 2 3','I 2 3',
     3'P 21 3','I 21 3','P m -3','P n -3','F m -3','F d -3','I m -3',
     4 'P a -3','I a -3','P 4 3 2','P 42 3 2','F 4 3 2','F 41 3 2',
     5 'I 4 3 2',' ','P 41 3 2','I 41 3 2','P -4 3 m','F -4 3 m',
     6'I -4 3 m','P -4 3 n','F -4 3 c','I -4 3 d','P m -3 m','P n -3 n',
     7'P m -3 n','P n -3 m','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'/
c     transformations :
      data  abc/0.,1.,0.,0.,0.,1.,1.,0.,0.,  0.,0.,1.,1.,0.,0.,0.,1.,0.,
     1      1.,0.,0.,0.,0.,-1.,0.,1.,0.,  0.,1.,0.,-1.,0.,0.,0.,0.,1.,
     2      0.,0.,1.,0.,-1.,0.,1.,0.,0.,  0.,-1.,0.,1.,0.,0.,0.,1.,1.,
     3      0.,-1.,-1.,1.,0.,0.,0.,0.,1.,  0.,0.,-1.,0.,1.,0.,1.,0.,1.,
     4      -1.,0.,-1.,0.,1.,0.,1.,0.,0.,  -1.,0.,0.,0.,0.,1.,1.,1.,0.,
     5   -1.,-1.,0.,0.,0.,1.,0.,1.,0.,  0.,0.,-1.,-1.,0.,0.,0.,1.,1.,
     6   0.,-1.,-1.,-1.,0.,0.,0.,1.,0.,  -1.,0.,0.,0.,-1.,0.,1.,0.,1.,
     7   -1.,0.,-1.,0.,-1.,0.,0.,0.,1.,  0.,-1.,0.,0.,0.,-1.,1.,1.,0.,
     8   -1.,-1.,0.,0.,0.,-1.,1.,0.,0.,  0.,1.,0.,-1.,0.,0.,0.,-1.,1.,
     9   0.,1.,-1.,-1.,0.,0.,0.,0.,1.,  0.,0.,1.,0.,-1.,0.,1.,0.,-1.,
     *   -1.,0.,1.,0.,-1.,0.,1.,0.,0.,  1.,0.,0.,0.,0.,-1.,-1.,1.,0.,
     1   1.,-1.,0.,0.,0.,-1.,0.,1.,0.,  0.,0.,1.,1.,0.,0.,0.,1.,-1.,
     2   0.,-1.,1.,1.,0.,0.,0.,1.,0.,  1.,0.,0.,0.,1.,0.,-1.,0.,1.,
     3   1.,0.,-1.,0.,1.,0.,0.,0.,1.,  0.,1.,0.,0.,0.,1.,1.,-1.,0.,
     4   -1.,1.,0.,0.,0.,1.,1.,0.,0.,  -1.,0.,0.,0.,-1.,0.,0.,0.,-1./
      NBR = 0
      z   = 0
      iz  = 0
      ngc = 0
      ngo = 0
      id  = 0
      LT  = 0
      CALL GEN074 (PLUS, 0.0, 1, 3)
      CALL GEN097 (S, 1, 3, 0)
      DO 20 i = 1, 3
        DO 10 j = 1, 48
          T(j, i) = 0
   10   CONTINUE
   20 CONTINUE
      DO 50 i = 1, 3
        DO 40 j = 1, 3
          DO 30 k = 1, 48
            R(k, j, i) = 0
   30     CONTINUE
   40   CONTINUE
   50 CONTINUE
      CALL GEN097 (LGT, 1, 48, 0)
   60 DO 70 I = 1, 7
        IN(I) = 0
        IF (NT(1) .EQ. HBR(I)) NBR = I
   70 CONTINUE
      IF (NBR .EQ. 0 .OR. NT(2) .NE. ' ') RETURN 1
      N = 0
      DO 90 I = 2, 16
        IF (NT(I) .EQ. ' ') THEN
          K = 0
          N = N + 1
        ELSE
          M = 0
          DO 80 J = 1, 14
            IF(NT(I) .EQ. HS(J)) M = J
   80     CONTINUE
          IF(M .EQ. 0 .OR. K .GT. 3) RETURN 1
          IN(N + 1) = IN(N + 1) + M * 15**K
          K = K + 1
        ENDIF
   90 CONTINUE
      DO 110 I = 1, 3
        NET(I) = 0
        DO 100 J = 1, 43
          IF (MM(J, I) .EQ. IN(I + 1)) NET(I) = J
  100   CONTINUE
        IF (NET(I) .EQ. 0) RETURN 1
  110 CONTINUE
      MD4 = M4(NET(2), NET(3))
      IF (MD4 .EQ. 0) RETURN 1
      MC = MD4 + NET(1) * 95 + (NBR - 1) * 4085
      DO 120 I = 1, 541
        IF (MC .EQ. NT1(I)) Z = I
  120 CONTINUE
      IF (NT(1) .EQ. 'I' .AND. NT(3) .EQ. 'C' .AND. NT(5) .EQ. 'A'
     1   .AND. NT(7) .EQ. 'B') THEN
        NGR     = 73
        IFPLUS  = 1
        NTRANS  = -2
        PLUS(1) = 0.25
        PLUS(2) = 0.25
        PLUS(3) = 0.25
        NSHTRA  = 5
        GO TO 180
      ENDIF
      IF (Z .EQ. 0) CALL PLA307 (nbr, *500, *60)
      ntrans = trafo(z)
      IF (ntrans .GT. 0) THEN
        nbl      = 0
        aux      = ' '
        aux(1:1) = NT(1)
        k        = 2
        DO 140 i = 3, 16
          k = k + 1
          aux(k:k) = NT(i)
          IF (NT(i) .EQ. ' ') THEN
            nbl = nbl + 1
            if (nbl .EQ. 2) GOTO 150
            GOTO 140
          ELSE
            nbl = 0
          ENDIF
          DO 130 j = 1, 6
            IF (NT(i) .EQ. UP(j)) then
              aux(k:k) = low(j)
              GOTO 140
            ENDIF
  130     CONTINUE
  140   CONTINUE
  150   DO 160 I = 16, 1, -1
          IF (aux(i:i) .ne. ' ') THEN
            k = i + 1
            aux(k:k) = '.'
            GOTO 170
          ENDIF
  160   CONTINUE
  170   WRITE (LU63, 99995) aux
      ENDIF
      ngr = tgrp(z)
      iz  = z
  180 IF (z .EQ. 182 .or. z .EQ. 183) THEN
        CALL PLA269 (2)
        WRITE (LU7, 99998)
      ELSE IF (z .EQ. 184 .or.z .EQ. 185) THEN
        CALL PLA269 (2)
        WRITE (LU7, 99997)
      ELSE IF (z .EQ. 186 .or. z .EQ. 187) THEN
        CALL PLA269 (2)
        WRITE (LU7, 99996)
      ENDIF
      z    = list(ngr)
      spgr = spg(ngr)
      nbr  = cent(ngr)
      nb   = nbr
      IF (nbr .GT. 2) nb = nbr + 1
      CALL PLA269 (1)
      WRITE (LU7, 99999) NGR
      DO 190 I = 1, 45
        IF(NT2(I) .LT. Z) NGC = I
  190 CONTINUE
      SYS    = SY(NGC)
      NSE    = NT1(Z + 1082)
      NET(3) = NT1(Z + 541) / 900 + 1
      NET(2) = (NT1(Z + 541) - 900 * (NET(3) - 1)) / 30 + 1
      NET(1) = 1 + MOD(NT1(Z + 541), 30)
      NCS    = 1 - NGC / 32
      ND     = NGC
      IF (ND .GT. 31) ND = IS(NGC - 31)
      DO 230 I = 1, 216
        IF (LF(I) .EQ. 1) ID = ID + 1
        IF (ID - ND) 230, 200, 240
  200   M = LF(I) * ISIGN (1, LF(I)) + 24 * (5 / SYS) * (SYS / 5)
        NGO = NGO + 1
        DO 220 K = 1, 3
          DO 210 L = 1, 3
            R(NGO, K, L) = GES(K, L, M) * ISIGN (1, LF(I))
  210     CONTINUE
  220   CONTINUE
  230 CONTINUE
  240 DO 330 I = 1, NGO
        DO 260 J = 1, 3
          DO 250 K = 1, 3
            IF (NCS .EQ. 0) R(NGO + I, J, K) = - R(I, J, K)
  250     CONTINUE
  260   CONTINUE
        DO 320 J = 1, NGO
          DO 280 K = 1, 3
            DO 270 L = 1, 3
              SC(K, L) = R(I, K, 1) * R(J, 1, L)
     1                 + R(I, K, 2) * R(J, 2, L)
     2                 + R(I, K, 3) * R(J, 3, L)
  270       CONTINUE
  280     CONTINUE
          DO 310 K = 1, NGO
            DO 300 L = 1, 3
              DO 290 M = 1, 3
                IF (SC(L, M) .NE. R(K, L, M)) GOTO 310
  290         CONTINUE
  300       CONTINUE
            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)
            GOTO 320
  310     CONTINUE
  320   CONTINUE
  330 CONTINUE
      NGO = NGO + NGO * (1 - NCS)
      DO 350 I = 1, 3
        ID = LGN(I, NGC)
        DO 340 J = 1, 3
          IF (ID .NE. 0) T(ID, J) = GET(J, NET(I))
          SC(I, J) = SEM(I, J, NSE)
  340   CONTINUE
  350 CONTINUE
      DO 360 I = 1, 3
        IF (LGN(I, NGC) .NE. 0) THEN
          LT = LT + 1
          LGT(LT) = LGN(I, NGC)
        ENDIF
  360 CONTINUE
  370 IF (LT .NE. NGO) THEN
        N = 0
        DO 420 I = 1, LT
          DO 410 J = 1, LT
            KL = NGT(LGT(I), LGT(J))
            DO 380 M = 1, NGO
              IF (LGT(M) .EQ. KL) GOTO 410
  380       CONTINUE
            DO 400 K = 1, 3
              DO 390 L = 1, 3
                T(KL, K) = T(KL, K) + R(LGT(I), K, L) * T(LGT(J), L)
  390         CONTINUE
              T(KL, K) = MOD(T(KL, K) + T(LGT(I), K) + 48, 24)
  400       CONTINUE
            N = N + 1
            LGT(LT + N) = KL
  410     CONTINUE
  420   CONTINUE
        LT = LT + N
        GOTO 370
      ENDIF
      DO 480 I = 1, NGO
        DO 430 J = 1, 3
          T(I, J) = T(I, J) + R(I, J, 1) * S(1)
     1            + R(I, J, 2) * S(2) + R(I, J, 3) * S(3) - S(J)
          T(I, J) = MOD (T(I, J) + 48, 24)
  430   CONTINUE
        IF (NB .EQ. 1 .OR. NB .EQ. 7) GOTO 470
        DO 460 L = 1, 4
          DO 440 K = 1, 3
            NET(K) = MOD(T(I, K) + Q(K, L, NB - 1), 24)
  440     CONTINUE
          IF (IRC .GT. NET(1) + NET(2) + NET(3)) THEN
            IRC = NET(1) + NET(2) + NET(3)
            DO 450 K = 1, 3
              T(I, K) = NET(K)
  450       CONTINUE
          ENDIF
  460   CONTINUE
  470   IRC = 72
  480 CONTINUE
      ifmat = 0
      n = mod (ntrans, 20)
      IF (NTRANS .EQ. -2) N = 30
      IF (ntrans .EQ. -1) ifmat = 1
      IF (n .GT. 0) THEN
        ifmat = 2
        IF (NTRANS .GT. 0) CALL PLA308 (n, *500)
        DO 490 k = 1, 9
          ss(k) = abc(k, n)
  490   CONTINUE
      ENDIF
      IF (NTRANS .EQ. -2) RETURN
      IF (n .EQ. 13 .or. n .EQ. 25) then
        IF (iz .EQ. 8)   ntrans = 7
        IF (iz .EQ. 11)  ntrans = 27
        IF (iz .EQ. 299) ntrans = 7
        IF (iz .EQ. 302) ntrans = 47
      ELSE IF (n .EQ. 15 .or. n .EQ. 27) then
        IF (iz .EQ. 28)  ntrans = 29
        IF (iz .EQ. 34)  ntrans = 9
        IF (iz .EQ. 323) ntrans = 49
        IF (iz .EQ. 329) ntrans = 9
      ELSE IF (n .EQ. 17 .or. n .EQ. 29) then
        IF (iz .EQ. 47)  ntrans = 11
        IF (iz .EQ. 50)  ntrans = 31
        IF (iz .EQ. 350) ntrans = 11
        IF (iz .EQ. 353) ntrans = 51
      ENDIF
      IF (ntrans .LT. 20) RETURN
        ifplus  = 1
        plus(2) = 0.25
      IF (ntrans .GE. 40) THEN
        plus(1) = 0.25
        nshtra  = 6
      ELSE
        nshtra = 17
      ENDIF
      RETURN
c space groupsymbol not accepted :
  500 RETURN 1
99999 FORMAT ('Number in International Tables :', 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  ', A17)
      END
      SUBROUTINE PLA307 (nbr, *, *)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /bur/nt,spgr
      COMMON /cel/ a,b,c,al,be,ga,alf,bet,gam,cosa,cosb,cosg
      CHARACTER*1 nt(16),nt1(16),spgr*10
      CHARACTER*14 ntt,p(17),ba(7),bb(7),bc(7),bi(9)
      data p/
     1 '2', '21', 'M', 'N', 'A', 'B', 'C', '2/M', '21/M', '2/A', '2/B',
     1 '2/C', '2/N', '21/A', '21/B', '21/C', '21/N'/
      data ba/ '2', 'M', 'N', 'A', '2/M', '2/A', '2/N'/
      data bb/ '2', 'M', 'N', 'B', '2/M', '2/B', '2/N'/
      data bc/ '2', 'M', 'N', 'C', '2/M', '2/C', '2/N'/
      data bi/ '2', 'M', 'A', 'B', 'C', '2/M', '2/A', '2/B', '2/C'/
      ntt = ' '
      DO 20 i = 1, 14
        WRITE (ntt(i:i), 99997) nt(i + 2)
   20 CONTINUE
      GOTO (40, 60, 80, 100, 30, 120, 30), NBR
   30 RETURN 1
   40 DO 50 i = 1, 17
       IF (ntt .EQ. p(i)) GOTO 140
   50 CONTINUE
      RETURN 1
   60 DO 70 i = 1, 7
        IF (ntt .EQ. ba(i)) GOTO 140
   70 CONTINUE
      RETURN 1
   80 DO 90 i = 1, 7
        IF (ntt .EQ. bb(i)) GOTO 140
   90 CONTINUE
      RETURN 1
  100 DO 110 i = 1, 7
        IF (ntt .EQ. bc(i)) GOTO 140
  110 CONTINUE
      RETURN 1
  120 DO 130 i = 1, 9
        IF (ntt .EQ. bi(i)) GOTO 140
  130 CONTINUE
      RETURN 1
  140 CALL GEN126 (NT1, 1, 16)
      ii = 1
      IF (al .ne. 0.0 .AND. al .ne. 90.0) ii = 2
      IF (be .ne. 0.0 .AND. be .ne. 90.0) ii = ii + 2
      IF (ga .ne. 0.0 .AND. ga .ne. 90.0) ii = ii + 4
      GOTO (180, 160, 190, 150, 230, 150, 150, 150), II
  150 RETURN 1
  160 DO 170 i = 3, 16
        IF (nt(i) .EQ. ' ') THEN
          nt(i + 1) = '1'
          nt(i + 2) = ' '
          nt(i + 3) = '1'
          GOTO 260
        ENDIF
  170 CONTINUE
  180 WRITE (LU7, 99998)
  190 nt1(3) = '1'
      DO 200 i = 3, 16
        IF (nt(i) .EQ. ' ') GOTO 210
        nt1(i + 2) = nt(i)
  200 CONTINUE
  210 nt1(i + 3) = '1'
      DO 220 i = 3, 16
        nt(i) = nt1(i)
  220 CONTINUE
      GOTO 260
  230 nt1(3) = '1'
      nt1(5) = '1'
      DO 240 i = 3, 12
        nt1(i + 4) = nt(i)
  240 CONTINUE
      DO 250 i = 3, 16
        nt(i) = nt1(i)
  250 CONTINUE
  260 CALL PLA269 (1)
      WRITE (LU7, 99999) NT
      RETURN 2
99999 FORMAT ('Complete Symbol for Space Group Setting : ', 16A1)
99998 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')
99997 FORMAT (A1)
      END
      SUBROUTINE PLA308 (N, *)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /STBL4/ ipol,r,ngr,iocfl,vol,nfl,volrat
      COMMON /bur/nt,spgr
      COMMON /cel/ a,b,c,al,be,ga,alf,bet,gam,cosa,cosb,cosg
      COMMON /matr/ifmat,ifsh,ifplus,xmat(3,3),plus(3),sh(3),nabc,nsh,
     1 nshtra,ifnig,xmsave(3,3),shif(3),minsh
      CHARACTER axes*9,nt*16,spgr*10
      eps  = 0.0001
      alf  = al/r
      bet  = be/r
      gam  = ga/r
      cosa = cos(alf)
      cosb = cos(bet)
      cosg = cos(gam)
c b,c,a
   10 IF (N .EQ. 1) THEN
        axes = 'b,c,a'
        an   = b
        bn   = c
        cn   = a
        ben  = ga
c c,a,b
      ELSE IF (N .EQ. 2) THEN
        axes = 'c,a,b'
        an   = c
        bn   = a
        cn   = b
        ben  = al
c a,-c,b
      ELSE IF (N .EQ. 3) THEN
        axes = 'a,-c,b'
        an   = a
        bn   = c
        cn   = b
        ben  = ga
c b,-a,c
      ELSE IF (N .EQ. 4) THEN
        axes = 'b,-a,c'
        an = b
        bn = a
        cn = c
        ben = al
c c,-b,a
      ELSE IF (N .EQ. 5) THEN
        axes = 'c,-b,a'
        an = c
        bn = b
        cn = a
        ben = be
c -b,a,b+c
      ELSE IF (N .EQ. 6) THEN
        IF (al .LT. 90.0) THEN
          N = 18
          GOTO 10
        ENDIF
        IF (c .LT. b) THEN
          N = 12
          GOTO 10
        ENDIF
        axes = '-b,a,b+c'
        an   = b
        bn   = a
        cn2  = b**2 + c**2 + 2.0 * b * c * cosa
        cn   = sqrt(cn2)
        IF (b .LT. eps .or. cn .LT. eps) GOTO 20
        ben  = r * acos (-((b**2 + cn2 - c**2) / (2.0 * b * cn)))
c -b-c,a,c
      ELSE IF (N .EQ. 7) THEN
        IF (al .LT. 90.0) THEN
          N = 19
          GOTO 10
        ENDIF
        IF (b .LT. c) THEN
          N = 13
          GOTO 10
        ENDIF
        axes = '-b-c,a,c'
        an2  = b**2 + c**2 + 2.0 * b * c * cosa
        an   = sqrt(an2)
        bn   = a
        cn   = c
        IF (c .LT. eps .or. an .LT. eps) GOTO 20
        ben  = r * acos(-((an2 + c**2 - b**2) / (2.0 * an * c)))
c -c,b,a+c
      ELSE IF (N .EQ. 8) THEN
        IF (be .LT. 90.0) THEN
          N = 20
          GOTO 10
        ENDIF
        IF (a .LT. c) THEN
          N = 14
          GOTO 10
        ENDIF
        axes = '-c,b,a+c'
        an   = c
        bn   = b
        cn2  = a**2 + c**2 + 2.0 * a * c * cosb
        cn   = sqrt(cn2)
        IF (c .LT. eps .or. cn .LT. eps) GOTO 20
        ben  = r * acos(-((c**2 + cn2 - a**2) / (2.0 * c * cn)))
c -(a+c),b,a
      ELSE IF (N .EQ. 9) THEN
        IF (be .LT. 90.0) THEN
          N = 21
          GOTO 10
        ENDIF
        IF (c .LT. a) THEN
          N = 15
          GOTO 10
        ENDIF
        axes = '-a-c,b,a'
        an2  = a**2 + c**2 + 2.0 * a * c * cosb
        an   = sqrt(an2)
        bn   = b
        cn   = a
        IF (a .LT. eps .or. an .LT. eps) GOTO 20
        ben = r * acos(-((an2 + a**2 - c**2) / (2.0 * an * a)))
c -a,c,a+b
      ELSE IF (N .EQ. 10) THEN
        IF (ga .LT. 90.0) THEN
          N = 22
          GOTO 10
        ENDIF
        IF (b .LT. a) THEN
          N = 16
          GOTO 10
        ENDIF
        axes = '-a,c,a+b'
        an   = a
        bn   = c
        cn2  = a**2+b**2+2.*a*b*cosg
        cn   = sqrt(cn2)
        IF (a .LT. eps .or. cn .LT. eps) GOTO 20
        ben  = r * acos(-((cn2 + a**2 - b**2) / (2.0 * cn * a)))
c -(a+b),c,b
      ELSE IF (N .EQ. 11) THEN
        IF (ga .LT. 90.0) THEN
          N = 23
          GOTO 10
        ENDIF
        IF (a .LT. b) THEN
          N = 17
          GOTO 10
        ENDIF
        axes = '-a-b,c,b'
        an2  = a**2 + b**2 + 2.0 * a * b * cosg
        bn   = c
        cn   = b
        an   = sqrt(an2)
        IF (b .LT. eps .or. an .LT. eps) GOTO 20
        ben  = r * acos(-((an2 + b**2 - a**2) / (2.0 * an * b)))
      ELSE IF (N .EQ. 12) THEN
        axes = '-c,-a,b+c'
        an   = c
        bn   = a
        cn2  = b**2 + c**2 + 2.0 * b * c * cosa
        cn   = sqrt(cn2)
        IF (c .LT. eps .or. cn .LT. eps) GOTO 20
        ben  = r * acos(-((c**2 + cn2 - b**2) / (2.0 * c * cn)))
      ELSE IF (N .EQ. 13) THEN
        axes = '-b-c,-a,b'
        an2  = b**2 + c**2 + 2.0 * b * c * cosa
        an   = sqrt(an2)
        bn   = a
        cn   = b
        IF (b .LT. eps .or. an .LT. eps) GOTO 20
        ben  = r * acos(-((an2 + b**2 - c**2) / (2.0 * an * b)))
      ELSE IF (N .EQ. 14) THEN
        axes = '-a,-b,a+c'
        an   = a
        bn   = b
        cn2  = a**2 + c**2 + 2.0 * a * c * cosb
        cn   = sqrt(cn2)
        IF (a .LT. eps .or. cn .LT. eps) GOTO 20
        ben  = r * acos(-((a**2 + cn2 - c**2) / (2.0 * a * cn)))
      ELSE IF (N .EQ. 15) THEN
        axes = '-a-c,-b,c'
        an2  = a**2+c**2+2.*a*c*cosb
        an   = sqrt(an2)
        bn   = b
        cn   = c
        IF (c .LT. eps .or. an .LT. eps) GOTO 20
        ben  = r*acos(-((an2+c**2-a**2)/(2.*an*c)))
      ELSE IF (N .EQ. 16) THEN
        axes = '-b,-c,a+b'
        an   = b
        bn   = c
        cn2  = a**2+b**2+2.*a*b*cosg
        cn   = sqrt(cn2)
        IF (b .LT. eps .or. cn .LT. eps) GOTO 20
        ben  = r*acos(-((cn2+b**2-a**2)/(2.*cn*b)))
      ELSE IF (N .EQ. 17) THEN
        axes = '-a-b,-c,a'
        an2  = a**2+b**2+2.*a*b*cosg
        bn   = c
        cn   = a
        an   = sqrt(an2)
        IF (a .LT. eps .or. an .LT. eps) GOTO 20
        ben  = r*acos(-((an2+a**2-b**2)/(2.*an*a)))
c b,-a,c-b
      ELSE IF (N .EQ. 18) THEN
        IF (c .LT. b) THEN
          N = 24
          GOTO 10
        ENDIF
        axes = 'b,-a,c-b'
        an   = b
        bn   = a
        cn2  = b**2+c**2-2.*b*c*cosa
        cn   = sqrt(cn2)
        IF (b .LT. eps .or. cn .LT. eps) GOTO 20
        ben  = r*acos(-((b**2+cn2-c**2)/(2.*b*cn)))
c b-c,-a,c
      ELSE IF (N .EQ. 19) THEN
        IF (b .LT. c) THEN
          N = 25
          GOTO 10
        ENDIF
        axes = 'b-c,-a,c'
        an2  = b**2+c**2-2.*b*c*cosa
        an   = sqrt(an2)
        bn   = a
        cn   = c
        IF (c .LT. eps .or. an .LT. eps) GOTO 20
        ben  = r*acos(-((an2+c**2-b**2)/(2.*an*c)))
      ELSE IF (N .EQ. 20) THEN
        IF (a .LT. c) THEN
          N = 26
          GOTO 10
        ENDIF
        axes = 'c,-b,a-c'
        an   = c
        bn   = b
        cn2  = a**2 + c**2 - 2.0 * a * c * cosb
        cn   = sqrt(cn2)
        IF (c .LT. eps .or. cn .LT. eps) GOTO 20
        ben  = r * acos(-((c**2 + cn2 - a**2) / (2.0 * c * cn)))
c c-a,-b,a
      ELSE IF (N .EQ. 21) THEN
        IF (c .LT. a) THEN
          N = 27
          GOTO 10
        ENDIF
        axes = 'c-a,-b,a'
        an2  = a**2 + c**2 - 2.0 * a * c * cosb
        an   = sqrt(an2)
        bn   = b
        cn   = a
        IF (a .LT. eps .or. an .LT. eps) GOTO 20
        ben  = r * acos(-((an2 + a**2 - c**2) / (2.0 * an * a)))
      ELSE IF (N .EQ. 22) THEN
        IF (b .LT. a) THEN
          N = 28
          GOTO 10
        ENDIF
        axes = 'a,-c,b-a'
        an   = a
        bn   = c
        cn2  = a**2 + b**2 - 2.0 * a * b * cosg
        cn   = sqrt(cn2)
        IF (a .LT. eps .or. cn .LT. eps) GOTO 20
        ben  = r * acos(-((cn2 + a**2 - b**2) / (2.0 * cn * a)))
      ELSE IF (N .EQ. 23) THEN
        IF (a .LT. b) THEN
          N = 29
          GOTO 10
        ENDIF
        axes = 'a-b,-c,b'
        an2  = a**2 + b**2 - 2.0 * a * b * cosg
        bn   = c
        cn   = b
        an   = sqrt(an2)
        IF (b .LT. eps .or. an .LT. eps) GOTO 20
        ben  = r * acos(-((an2 + b**2 - a**2) / (2.0 * an * b)))
      ELSE IF (N .EQ. 24) THEN
        axes = 'c,a,b-c'
        an   = c
        bn   = a
        cn2  = b**2 + c**2 - 2.0 * b * c * cosa
        cn   = sqrt(cn2)
        IF (c .LT. eps .or. cn .LT. eps) GOTO 20
        ben  = r * acos(-((c**2 + cn2 - b**2) / (2.0 * c * cn)))
      ELSE IF (N .EQ. 25) THEN
        axes = 'c-b,a,b'
        an2  = b**2 + c**2 - 2.0 * b * c * cosa
        an   = sqrt(an2)
        bn   = a
        cn   = b
        IF (b .LT. eps .or. an .LT. eps) GOTO 20
        ben  = r * acos(-((an2 + b**2 - c**2) / (2.0 * an * b)))
c a,b,c-a
      ELSE IF (N .EQ. 26) THEN
        axes = 'a,b,c-a'
        an   = a
        bn   = b
        cn2  = a**2 + c**2 - 2.0 * a * c * cosb
        cn   = sqrt(cn2)
        IF (a .LT. eps .or. cn .LT. eps) GOTO 20
        ben  = r * acos(-((a**2 + cn2 - c**2) / (2.0 * a * cn)))
c a-c,b,c
      ELSE IF (N .EQ. 27) THEN
        axes = 'a-c,b,c'
        an2  = a**2 + c**2 - 2.0 * a * c * cosb
        an   = sqrt(an2)
        bn   = b
        cn   = c
        IF (c .LT. eps .or. an .LT. eps) GOTO 20
        ben  = r * acos(-((an2 + c**2 - a**2) / (2.0 * an * c)))
c b,c,a-b
      ELSE IF (N .EQ. 28) THEN
        axes = 'b,c,a-b'
        an   = b
        bn   = c
        cn2  = a**2 + b**2 - 2.0 * a * b * cosg
        cn   = sqrt(cn2)
        IF (b .LT. eps .or. cn .LT. eps) GOTO 20
        ben  = r * acos(-((cn2 + b**2 - a**2) / (2.0 * cn * b)))
      ELSE IF (N .EQ. 29) THEN
        axes = 'b-a,c,a'
        an2  = a**2 + b**2 - 2.0 * a * b * cosg
        bn   = c
        cn   = a
        an   = sqrt(an2)
        IF (a .LT. eps .or. an .LT. eps) GOTO 20
        ben  = r * acos(-((an2 + a**2 - b**2) / (2.0 * an * a)))
      ENDIF
      a  = an
      b  = bn
      c  = cn
      be = ben
      IF (be .EQ. 0.0) be = 90.0
      ifmat = 2
      CALL PLA269 (2)
      WRITE (LU7, 99999) spgr, axes, a, b, c, be
      RETURN
   20 CALL PLA269 (1)
      WRITE (LU7, 99998)
      RETURN 1
99999 FORMAT ('Transformation of axes into standard setting ',
     1 A10, ' : ', a, /, 'New axes :', 3F8.4, 5x, 'beta=', F6.2)
99998 FORMAT ('Division by 0; no transformation performed.')
      END
      SUBROUTINE PLA309
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /cel/ a, b, c, al, be, ga, alf, bet, gam, cosa, cosb, cosg
      COMMON /matr/ ifmat, ifsh, ifplus, xmat(3, 3), plus(3), sh(3),
     1 nabc, nsh, nshtra, ifnig, xmsave(3, 3), shif(3), minsh
      COMMON /messa/ iw
      COMMON /trans/ s(9), u(9), t(9), p(9)
      CHARACTER axes*6
      DIMENSION pl(3)
c
      axes  = 'a,b,c'
      axtol = 0.005
      iab   = 0
      ibc   = 0
      minsh = 0
      ii    = iw - 6
      CALL GEN074 (U, 0.0, 1, 9)
      GOTO (10, 30, 30, 10, 30, 30, 10, 10), ii
   10 IF (abs(a - b) .LT. axtol) THEN
        CALL PLA269 (2)
        WRITE (LU7, 99998) a, b
        iab = 1
      ENDIF
      IF (abs(b - c) .LT. axtol) THEN
        CALL PLA269 (2)
        WRITE (LU7, 99997) b, c
        ibc = 1
      ENDIF
      IF (iab .EQ. 1 .AND. ibc .EQ. 1) RETURN
      IF (a .LT. b) THEN
        IF (b .GT. c) THEN
          IF (a .LT. c) THEN
            IF (iw .EQ. 14) RETURN
c a-cb
            axes  = 'a,-c,b'
            x     = c
            c     = b
            b     = x
            u(1)  = 1.0
            u(6)  =-1.0
            u(8)  = 1.0
            minsh = 2
c x-1/4 -z-1/4 y-1/4
            IF (iw .EQ. 10) THEN
              pl(1) = 0.25
              pl(2) = 0.25
              pl(3) = 0.25
              nabc  = 5
            ENDIF
            IF (iw .EQ. 13) THEN
              pl(1) = 0.25
              pl(3) = 0.25
              nabc = 12
            ENDIF
          ELSE
            axes = 'c,a,b'
            x    = c
            c    = b
            b    = a
            a    = x
            u(3) = 1.
            u(4) = 1.
            u(8) = 1.
          ENDIF
        ENDIF
      ELSE
        IF (b .LT. c) THEN
          IF (a .LT. c) THEN
            IF (iw .EQ. 14) GOTO 20
            axes  = 'b,a,-c'
            x     = b
            b     = a
            a     = x
            u(2)  = 1.0
            u(4)  = 1.0
            u(9)  =-1.0
            minsh = 3
            IF (iw .EQ. 10) THEN
              pl(1) = 0.25
              pl(2) = 0.25
              pl(3) = 0.25
              nabc  = 5
            ENDIF
            IF (iw .EQ. 13) THEN
              pl(1) = 0.25
              pl(2) = 0.25
              nabc  = 6
            ENDIF
          ELSE
            axes = 'b,c,a'
            x    = b
            b    = c
            c    = a
            a    = x
            u(2) = 1.0
            u(6) = 1.0
            u(7) = 1.0
          ENDIF
        ELSE
          IF (iw .EQ. 14) GOTO 25
          axes  = '-c,b,a'
          x     = c
          c     = a
          a     = x
          u(3)  =-1.0
          u(5)  = 1.0
          u(7)  = 1.0
          minsh = 1
          IF (iw .EQ. 10) THEN
            pl(1) = 0.25
            pl(2) = 0.25
            pl(3) = 0.25
            nabc  = 5
          ENDIF
c -z y-1/4 x-1/4
          IF (iw .EQ. 13) THEN
            pl(2) = 0.25
            pl(3) = 0.25
            nabc  = 15
          ENDIF
        ENDIF
      ENDIF
      GOTO 40
c bca  (for Pbca, iw=14)
   20 axes = 'b,c,a'
      x    = b
      b    = c
      c    = a
      a    = x
      u(2) = 1.0
      u(6) = 1.0
      u(7) = 1.0
      GOTO 40
   25 axes = 'c,a,b'
      x    = c
      c    = b
      b    = a
      a    = x
      u(3) = 1.0
      u(4) = 1.0
      u(8) = 1.0
      GOTO 40
c a<b
   30 IF (abs(a - b) .LT. axtol) THEN
        CALL PLA269 (2)
        WRITE (LU7, 99998) a, b
        RETURN
      ENDIF
      IF (a .GT. b) THEN
        axes  = 'b,a,-c'
        x     = b
        b     = a
        a     = x
        u(2)  = 1.0
        u(4)  = 1.0
        u(9)  =-1.0
        minsh = 3
        IF (iw .EQ. 9) THEN
          pl(3) = 0.25
          nabc  = 16
        ENDIF
c y-1/4 x-1/4 3/4-z
        IF (iw .EQ. 11) THEN
          pl(1) = 0.25
          pl(2) = 0.25
          pl(3) = 0.25
          nabc  = 5
        ENDIF
        IF (iw .EQ. 12) THEN
          pl(1) = 0.25
          pl(2) = 0.25
          nabc  = 6
        ENDIF
      ENDIF
   40 IF (axes .EQ. 'a,b,c') RETURN
      DO 50 I = 1, 3
        plus(i) = plus(i) + pl(i)
        if (plus(i) .GT. 1.0) plus(i) = plus(i) - 1.0
   50 CONTINUE
      IF (ifmat .EQ. 2) THEN
        CALL GEN004 (S, U, P)
        CALL GEN125 (P, S)
      ELSE
        DO 60 i = 1, 9
          s(i) = u(i)
   60   CONTINUE
      ENDIF
      ifmat = 2
      IF (nabc .GT. 0) ifplus = ifplus + 2
      CALL PLA269 (1)
      WRITE (LU7, 99999) 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 PLA310 (s)
      COMMON /lab/ ax
      CHARACTER ax*47, cc(3)*1
      DIMENSION iflag(9), s(9)
      data cc/ 'a', 'b', 'c'/
      ax = ' '
      ep = 0.00001
      DO 10 i = 1, 9
        iflag(i) = 0
        sabs = abs(s(i))
        k = ifix (sabs + ep)
        IF (abs (float (k) - sabs) .GT. 0.0001) iflag(i) = 1
   10 CONTINUE
      k = 0
      m = 1
      DO 30 i = 1, 3
        mm = m
        DO 20 j = 1, 3
          m1 = m
          k  = k + 1
          kk = 0
          sk = abs(s(k))
          IF (sk .GT. ep) THEN
            IF (iflag(k) .EQ. 0) kk = ifix(sk + ep)
            IF (s(k) .LT. 0.0) then
              ax(m:m) = '-'
              m = m + 1
            ELSE IF (m .GT. mm) THEN
              ax(m:m) = '+'
              m = m + 1
            ENDIF
            IF (iflag(k) .EQ. 0) THEN
              IF (kk .EQ. 1) m1 = m1-1
              IF (kk .GT. 1) THEN
                WRITE (ax(m:m), 99999) kk
                m = m + 1
              ENDIF
            ELSE
              ii = IFIX (sk + 0.00001)
              WRITE (ax(m:m), 99999) ii
              ax(m+1:m+1) = '.'
              WRITE (ax(m+2:m+2), 99999)
     1          IFIX ((sk + 0.05 - FLOAT(ii)) * 10)
              m = m + 3
            ENDIF
            IF (m .EQ. m1 .AND. kk .EQ. 0) GOTO 20
            ax(m:m) = cc(j)
            m = m + 1
          ENDIF
   20   CONTINUE
        IF (i .LT. 3) THEN
          ax(m:m) = ','
          m = m + 1
        ENDIF
   30 CONTINUE
      RETURN
99999 FORMAT (I1)
      END
      SUBROUTINE PLA311
      PARAMETER (nsiz=50)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /STBL4/ ipol, r, ngr, iocfl, vol, nfl, volrat
      COMMON /cel/ a, b, c, al, be, ga, alf, bet, gam, cosa, cosb, cosg
      COMMON /lab/ axs
      COMMON /matr/ ifmat, ifsh, ifplus, xmat(3, 3), plus(3), sh(3),
     1 nabc, nsh, nshtra, ifnig, xmsave(3, 3), shif(3), minsh
      COMMON /messa/ iw
      COMMON /trans/ s(9), u(9), t(9), p(9)
      CHARACTER axs*47
      DIMENSION v(nsiz, nsiz), vs(nsiz), ii(nsiz), jj(nsiz)
c remember if axes have already been transformed :
      iftra = 0
      IF (ifmat .EQ. 2) iftra = 1
      CALL GEN074 (U, 0.0, 1, 9)
      bb   = be
      anew = a
      cnew = c
      l1   = 0
      l2   = 1
      sinb = sin(bet)
      DO 20 i = 1, nsiz
        DO 10 j = 1, nsiz
          v(j, i) = - 0.5
   10   CONTINUE
   20 CONTINUE
      ip     = 1
      iq     = 0
      ir     = 0
      is     = 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 .GE. nsiz .or. jmax .GE. nsiz) THEN
        WRITE (LU7, 99991) imax, jmax
        RETURN
      ENDIF
      DO 40 i = 1, imax
        ax = i * a
        ax2 = ax**2
        DO 30 j = 1, jmax
          cx = j * c
          v2 = ax2 + cx**2 + 2.0 * ax * cx * cosb
          IF (v2 .LE. v2max) THEN
            vv              = sqrt(v2)
            v(i + 1, j + 1) = vv
          ENDIF
   30   CONTINUE
   40 CONTINUE
      v(2,1) = a
      v(1,2) = c
      k    = 0
   50 vmin = vmax
      ifk  = 0
      k    = k + 1
      imax = imax + 1
      jmax = jmax + 1
      IF (k .GT. nsiz) GOTO 240
      DO 70 j = 1, jmax
        DO 60 i = 1, imax
          IF (v(i, j) .GE. 0.0) THEN
            IF (v(i,j) .LE. vmin) THEN
              vmin = v(i, j)
              ii(k) = i
              jj(k) = j
              ifk   = 1
            ENDIF
          ENDIF
   60   CONTINUE
   70 CONTINUE
      IF (ifk .EQ. 0) THEN
        k = k - 1
      ELSE
        vs(k)   = vmin
        i       = ii(k)
        j       = jj(k)
        v(i, j) = -vmin
        GOTO 50
      ENDIF
      IF (iw .EQ. 2) THEN
        IF (vs(1) .EQ. vs(2)) THEN
          WRITE (LU7, 99993)
        ENDIF
        ifa  = 1
        ifc  = 1
        anew = vs(1)
        cnew = vs(2)
        ip   = ii(1) - 1
        ir   = ii(2) - 1
        iq   = jj(1) - 1
        is   = jj(2) - 1
        GOTO 220
        ENDIF
c
      igroup = iw - 2
      ifa    = 0
      ifc    = 0
      GOTO (90, 80, 150, 150), igroup
c group 1 : C-groups ; q even, s odd
c group 2 : P-groups ; p odd, r even
   80 l1 = 1
      l2 = 0
   90 k1 = 1
  100 DO 110 i = k1, k
        i1 = ii(i) - 1
        j1 = jj(i) - 1
        kk = i1
        IF (igroup .EQ. 1) kk = j1
        IF (mod(kk, 2) .EQ. l1) THEN
          IF (ifc .EQ. 0 .or. abs(i1 * is - j1 * ir) .EQ. 1) THEN
            ip   = i1
            iq   = j1
            ifa  = i
            anew = vs(i)
          ENDIF
        ELSE
          IF (ifa .EQ. 0 .or. abs (i1 * iq - j1 * ip) .EQ. 1) THEN
            is   = j1
            ir   = i1
            cnew = vs(i)
            ifc  = i
          ENDIF
        ENDIF
        IF (ifa .GT. 0 .AND. ifc .GT. 0) GOTO 220
        IF (ifa .GT. 0 .or.  ifc .GT. 0) GOTO 120
  110 CONTINUE
  120 IF (ifa .GT. 0) THEN
        DO 130 j = 1, k
          IF (j .NE. ifa) THEN
            i1 = ii(j) - 1
            j1 = jj(j) - 1
            kk = i1
            IF (igroup .EQ. 1) kk = j1
            IF (mod(kk, 2) .EQ. l2) THEN
              IF (abs (i1 * iq - j1 * ip) .EQ. 1) THEN
                is   = j1
                ir   = i1
                cnew = vs(j)
                ifc  = j
                GOTO 220
              ENDIF
            ENDIF
          ENDIF
  130   CONTINUE
        IF (k1 .EQ. k) GOTO 230
        ifa = 0
        ifc = 0
        k1  = k1 + 1
        GOTO 100
      ELSE
        DO 140 j = 1, k
          IF (j .NE. ifc) THEN
            i1 = ii(j) - 1
            j1 = jj(j) - 1
            kk = i1
            IF (igroup .EQ. 1) kk = j1
            IF (mod(kk, 2) .EQ. l1) THEN
              IF (abs (i1 * is - j1 * ir) .EQ. 1) THEN
                ip   = i1
                iq   = j1
                ifa  = j
                anew = vs(j)
                GOTO 220
              ENDIF
            ENDIF
          ENDIF
  140   CONTINUE
        IF (k1 .EQ. k) GOTO 230
        ifa = 0
        ifc = 0
        k1  = k1 + 1
        GOTO 100
      ENDIF
c
  150 k1 = 1
  160 DO 170 i = k1, k
        i1 = ii(i) - 1
        j1 = jj(i) - 1
        IF (mod(j1, 2) .EQ. 0) THEN
          IF (mod(i1, 2) .EQ. 1) THEN
            IF (ifc .EQ. 0 .or. abs (i1 * is - j1 * ir) .EQ. 1) THEN
              ip   = i1
              iq   = j1
              ifa  = i
              anew = vs(i)
            ENDIF
          ENDIF
        ELSE
          IF (ifa .EQ. 0 .or. abs (i1 * iq - j1 * ip) .EQ. 1) THEN
            is   = j1
            ir   = i1
            cnew = vs(i)
            ifc  = i
          ENDIF
        ENDIF
        IF (ifa .GT. 0 .AND. ifc .GT. 0) GOTO 210
        IF (ifa .GT. 0 .or.  ifc .GT. 0) GOTO 180
  170 CONTINUE
  180 IF (ifa .GT. 0) THEN
        DO 190 j = 1, k
          IF (j .NE. ifa) THEN
            i1 = ii(j) - 1
            j1 = jj(j) - 1
            IF (mod(j1, 2) .EQ. 1) THEN
              IF (abs (i1 * iq - j1 * ip) .EQ. 1) THEN
                is   = j1
                ir   = i1
                cnew = vs(j)
                ifc  = j
                GOTO 210
              ENDIF
            ENDIF
          ENDIF
  190   CONTINUE
        IF (k1 .EQ. k) GOTO 230
        ifa = 0
        ifc = 0
        k1  = k1 + 1
        GOTO 160
      ELSE
        DO 200 j = 1, k
          IF (j .NE. ifc) THEN
            i1 = ii(j) - 1
            j1 = jj(j) - 1
            IF (mod(i1, 2) .EQ. 1 .AND. mod(j1, 2) .EQ. 0) THEN
              IF (abs (i1 * is - j1 * ir) .EQ. 1) THEN
                ip   = i1
                iq   = j1
                ifa  = j
                anew = vs(j)
                GOTO 210
              ENDIF
            ENDIF
          ENDIF
  200   CONTINUE
        IF (k1 .EQ. k) GOTO 230
        ifa = 0
        ifc = 0
        k1  = k1 + 1
        GOTO 160
      ENDIF
c
  210 IF (mod(ir,2) .EQ. 1) THEN
        IF (igroup .EQ. 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
        ENDIF
        ifplus = ifplus + 4
      ENDIF
c
  220 IF (ip .EQ. 1 .AND. iq .EQ. 0 .AND. ir .EQ. 0 .AND.
     1    ip .EQ. 1) RETURN
      ifmat = 2
      IF (ip .EQ. 0 .or. iq .EQ. 0) ifa = 0
      IF (ir .EQ. 0 .or. is .EQ. 0) ifc = 0
      u(5) = 1.0
      u(1) = float(ip)
      u(3) = float(iq)
      csc  = 1.0
      IF (iq .ne. 0) csc = (anew**2 + (iq * c)**2 - (ip * a)**2) /
     1   (2.0 * anew * iq * c)
      u(7) = float(ir)
      u(9) = float(is)
      csa = 1.0
      IF (ir .ne. 0) csa = (cnew**2 + (ir * a)**2 - (is * c)**2) /
     1   (2.0 * cnew * ir * a)
      neg = 1
      IF (ifa .GT. 0 .AND. ifc .GT. 0) THEN
        b1 = r * acos(csa)
        b2 = r * acos(csc)
        bb = be - b1 - b2
        IF (bb .LT. 0.0) THEN
          bb  = 180.0 + bb
          neg = - 1
        ENDIF
        if (bb .LT. 90.0) THEN
          bb = 180.0 - bb
          neg = - neg
        ENDIF
      ELSE IF (ifa .GT. 0) THEN
        IF (ir .EQ. 0) THEN
          cs = csc
        ELSE
          cs = ((ip * a)**2 + anew**2 - (iq * c)**2) /
     1         (2.0 * ip * a * anew)
        ENDIF
        IF (cs .GT. 0.0) neg = -1
        bb = r * acos(neg * cs)
      ELSE IF (ifc .GT. 0) THEN
        IF (iq .EQ. 0) THEN
          cs = csa
        ELSE
          cs = ((is * c)**2 + cnew**2 - (ir * a)**2) /
     1         (2.0 * is * c * cnew)
        ENDIF
        IF (cs .GT. 0.0) neg = -1
        cosb = neg * cs
        bb   = r * acos(neg * cs)
      ENDIF
c
      CALL PLA269 (4)
      WRITE (LU7, 99999) ip, a, iq, c, anew
      WRITE (LU7, 99998) ir, a, is, c, cnew
      WRITE (LU7, 99997) bb
      u(1) = neg * u(1)
      u(3) = neg * u(3)
      det  = u(1) * u(9) - u(3) * u(7)
      IF (det .LT. 0.0) u(5) = - u(5)
      CALL PLA310 (U)
      WRITE (LU7, 99996) axs
      CALL GEN004 (S, U, P)
      CALL GEN125 (P, S)
      a  = anew
      c  = cnew
      be = bb
      IF (iftra .EQ. 1) THEN
        CALL PLA310 (S)
        CALL PLA269 (1)
        WRITE (LU7, 99995) axs
      ENDIF
      CALL PLA269 (3)
      WRITE (LU7, 99994) a, b, c, al, be, ga
      RETURN
  230 WRITE (LU7, 99993)
      RETURN
  240 WRITE (LU7, 99992)
      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 : ', A47)
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 PLA311'/
     1 'cell needed are : ', 2I4)
      END
      SUBROUTINE PLA312 (IFMAT)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /STBL4/ ipol, r, ngr, iocfl, vol, nfl, volrat
      COMMON /brz/ ngo, ir(48, 3, 3), it(48, 3), nbr
      COMMON /cel/ a, b, c, al, be, ga, alf, bet, gam, cosa, cosb, cosg
      COMMON /DOTS/ SF11, SF22, SF33, SF23, SF13, SF12, ITYPE
      COMMON /garb/ ierr, igo, ired, e1, ithru
      COMMON /trans/ uvw(9), u(9), t(9), p(9)
c
      e1   = 0.000001
      ierr = 0
      CALL PLA321 (nbr)
      CALL PLA314
      CALL PLA319
      WRITE (LU7, 99999) uvw
      IF (uvw(1) .NE. 1.0 .OR. uvw(2) .NE. 0.0 .OR. uvw(3) .NE. 0.0
     1 .OR. uvw(4) .NE. 0.0 .OR. uvw(5) .NE. 1.0 .OR.
     2 uvw(6) .NE. 0.0 .OR. uvw(7) .NE. 0.0 .OR.
     2 uvw(8) .NE. 0.0 .OR. uvw(9) .NE. 1.0) THEN
        ifmat = 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 * r
        be   = bet * r
        ga   = gam * r
        WRITE (LU7, 99998) a, b, c, al, be, ga
        CALL PLA310 (UVW)
      ELSE
        WRITE (LU7, 99997) a, b, c, al, be, ga
        ifmat = 0
      ENDIF
      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 PLA314
      COMMON /STBL4/ ipol, r, ngr, iocfl, vol, nfl, volrat
      COMMON /cel/ a, b, c, al, be, ga, alf, bet, gam, cosa, cosb, cosg
      COMMON/TRANS/ U1, V1, W1, U2, V2, W2, U3, V3, W3, U(9), T(9), P(9)
      DIMENSION DOT(6), axf(6), ux1(3), ux2(3), ux(9)
      UX(1) = U1
      UX(2) = V1
      UX(3) = W1
      UX(4) = U2
      UX(5) = V2
      UX(6) = W2
      UX(7) = U3
      UX(8) = V3
      UX(9) = W3
      N     = 0
      DO 20 N = 1, 6
        DO 10 II = 1, 3
          NN = II
          MM = II
          IF (N .EQ. 2) THEN
            MM = II + 3
            NN = II + 3
          ELSE IF (N .EQ. 3) THEN
            MM = II + 6
            NN = II + 6
          ELSE IF (N .EQ. 4) THEN
            NN = II + 3
          ELSE IF (N .EQ. 5) THEN
            NN = II + 6
          ELSE IF (N .EQ. 6) THEN
            MM = II + 3
            NN = II + 6
          ENDIF
          UX1(II) = UX(MM)
          UX2(II) = UX(NN)
   10   CONTINUE
        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)
        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)
   20 CONTINUE
      AXF(1) = SQRT(DOT(1))
      AXF(2) = SQRT(DOT(2))
      AXF(3) = SQRT(DOT(3))
      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) * R
      AXF(5) = ACOS(COSB) * R
      AXF(6) = ACOS(COSG) * R
      A      = AXF(1)
      B      = AXF(2)
      C      = AXF(3)
      alf    = AXF(4)/R
      bet    = AXF(5)/R
      gam    = AXF(6)/R
      al     = AXF(4)
      be     = AXF(5)
      ga     = AXF(6)
      RETURN
      END
      SUBROUTINE PLA315 (*)
c so t transforms the ROW matrix (x,y,z).
      COMMON /matr/ ifmat, ifsh, ifplus, tt(3, 3), plus(3), sh(3),
     1 nabc, nsh, nshtra, ifnig, xmsave(3, 3), shif(3), minsh
      COMMON /trans/ s(3, 3), u(9), t(9), p(9)
      d = s(1, 1) * (s(2, 2) * s(3, 3) - s(2, 3) * s(3, 2)) -
     1    s(1, 2) * (s(2, 1) * s(3, 3) - s(3, 1) * s(2, 3)) +
     2    s(1, 3) * (s(2, 1) * s(3, 2) - s(3, 1) * s(2, 2))
      IF (abs(d) .LT. 0.00001) RETURN 1
      DO 20 j = 1, 3
        DO 10 i = 1, 3
          i1 = i + 1
          IF (i1 .GT. 3) i1 = i1 - 3
          i2 = i + 2
          IF (i2 .GT. 3) i2 = i2 - 3
          j1 = j + 1
          j2 = j + 2
          IF (j1 .GT. 3) j1 = j1 - 3
          IF (j2 .GT. 3) j2 = j2 - 3
          tt(i, j) = (s(i1, j1) * s(i2, j2)
     1             -  s(i2, j1) * s(i1, j2)) / d
   10   CONTINUE
   20 CONTINUE
      RETURN
      END
      SUBROUTINE PLA316
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /cel/ a, b, c, al, be, ga, alf, bet, gam, cosa, cosb, cosg
      COMMON /matr/ ifmat, ifsh, ifplus, xmat(3, 3), plus(3), sh(3),
     1 nabc, nsh, nshtra, ifnig, xmsave(3, 3), shif(3), minsh
      COMMON /messa/ iw
      CHARACTER ansr*1
      ifbest = 0
      root   = 1.0
      csb    = - cosb
      csb    = - cosb
      cs     = 1.0 / 2.0 * csb
      css    = csb
      ca     = c / a
      IF (IW .LT. 0) THEN
        WRITE (LU7, 99998)
        IW = -IW
        READ (LU64, 99997) ansr
        IF (ansr .EQ. 'Y'.or. ansr .EQ. 'y') ifsh = 1
      ENDIF
      GOTO (10, 20, 30, 40, 30, 30, 70, 80, 90, 100, 110, 120,
     1      130, 140, 150, 160), IW
   10 WRITE (LU7, 99992)
      CALL PLA312 (ifmat)
      RETURN
   20 CALL PLA269 (1)
      WRITE (LU7, 99999)
      IF (a .GT. c) GOTO 60
      root = 1.0
      cs   = 1.0 / (2.0 * csb)
      IF (ca .GE. 1.0 .AND. ca .GE. cs)  GOTO 60
      css = 2.0 * csb
      IF (ca .LE. 1.0 .AND. ca .LE. css) GOTO 60
      WRITE (LU7, 99981)
      IF (abs(a - c) .LT. 0.001 * a) THEN
        WRITE (LU7, 99982)
      ENDIF
      GOTO 180
   30 root = 1.0 / sqrt(2.0)
      cs   = 1.0 / (2.0 * csb)
      css  = csb
      IF (ca .GE. root .AND. ca .GE. cs)  GOTO 50
      IF (ca .LE. root .AND. ca .LE. css) GOTO 50
      WRITE (LU7, 99981)
      GOTO 180
   40 root = sqrt(2.0)
      cs = 1./csb
      IF (ca .GE. root .AND. ca .GE. cs)  GOTO 50
      css = 2.0 * csb
      IF (ca .LE. root .AND. ca .LE. css) GOTO 50
      WRITE (LU7, 99981)
      GOTO 180
   50 WRITE (LU7, 99991)
   60 CALL PLA311
      ifbest = 1
      ca  = c / a
      csb = - cos(be * 3.1415926 / 180.0)
      IF (iw .EQ. 2) THEN
        root = 1.
        cs   = 1.0 / (2.0 * csb)
        css  = 2.0 * csb
      ELSE IF (iw .EQ. 3 .or. iw .EQ. 5 .or. iw .EQ. 6) THEN
        root = 1.0 / sqrt(2.0)
        cs   = 1.0 / (2.0 * csb)
        css  = csb
      ELSE IF (iw .EQ. 4) THEN
        root = sqrt(2.0)
        cs   = 1.0 / csb
        css  = 2.0 * csb
      ENDIF
      GOTO 180
   70 WRITE (LU7, 99990)
      GOTO 170
   80 WRITE (LU7, 99989)
      GOTO 170
   90 WRITE (LU7, 99988)
      GOTO 170
  100 WRITE (LU7, 99987)
      GOTO 170
  110 WRITE (LU7, 99986)
      GOTO 170
  120 WRITE (LU7, 99985)
      GOTO 170
  130 WRITE (LU7, 99984)
      GOTO 170
  140 WRITE (LU7, 99983)
      GOTO 170
  150 WRITE (LU7, 99998)
      READ (LU64, 99997) ANSR
      IF (ANSR .EQ. 'Y' .OR. ANSR .EQ. 'y') IFSH = 1
  160 GOTO 190
  170 CALL PLA309
      GOTO 190
  180 rt1  = root - 0.01 * root
      rt2  = root + 0.01 * root
      cs1  = cs   - 0.01 * cs
      css2 = css  + 0.01 * css
      IF (ca .GE. rt1 .AND. ca .GE. cs1) THEN
        IF (ifbest .EQ. 0) THEN
          WRITE (LU7, 99996)
        ELSE
          WRITE (LU7, 99995)
        ENDIF
      ELSE IF (ca .LE. rt2 .AND. ca .LE. css2) THEN
        IF (ifbest .EQ. 0) THEN
          WRITE (LU7, 99996)
        ELSE
          WRITE (LU7, 99995)
        ENDIF
      ENDIF
      IF (ca .GE. .97 .AND. ca .LE. 1.03 .AND. iw .EQ. 2) THEN
        WRITE (LU7, 99994)
      ENDIF
      IF (be .LE. 90.3) THEN
        WRITE (LU7, 99993)
      ENDIF
  190 RETURN
99999 FORMAT ('Take Reset Niggli Reduced Cell with  a < c.')
99998 FORMAT ('Take setting with origin in centre of symmetry')
99997 FORMAT (a1)
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 (' 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 PLA317
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /DOTS/ SF11, SF22, SF33, SF23, SF13, SF12, ITYPE
      COMMON/GARB/ ierr, igo, ired ,e1,ithru
      IGO    = 0
      IRED   = 0
      IMAIN1 = 0
      ER     = 0.000001
      Q      = 0.0005
      QQ     = 0.0005
      IF (ITHRU .EQ. 1 .AND. ITYPE .EQ. 1) GO TO 10
      IF (ITHRU .EQ. 1 .AND. ITYPE .EQ. 2) GO TO 20
      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 .LE. X22 .AND. X22 .LE. X33 .AND. Q1 .LE. X22 .AND.
     1 Q2 .LE. X11 .AND. Q3 .LE. X11) IMAIN1 = 1
      IF (ITYPE .NE. 1) THEN
        TEMP1 = SF11 + SF22 + ER
        TEMP2 = 2.0 * (ABS(SF23) + ABS(SF13) + ABS(SF12))
        IF (TEMP1 .LT. TEMP2) IMAIN1 = 0
      ENDIF
      ITHRU = 1
      E1    = 0.00001
      IF (IMAIN1 .EQ. 0) THEN
        WRITE (LU7, 99999)
        IERR = IERR + 1
      ENDIF
      GOTO 30
   10 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) .LE. QQ) THEN
        WRITE (LU7, 99998) SF11, SF22, SF33, SF23, SF13, SF12
        IF ((SF13 + ER) .LT. SF23) THEN
          IGO = 1
          GOTO 30
        ENDIF
      ENDIF
      IF ((TS2 / SF22) .LE. QQ) THEN
        WRITE(LU7, 99997) SF11, SF22, SF33, SF23, SF13, SF12
        IF ((SF12 + ER) .LT. SF13) THEN
          IGO = 2
          GOTO 30
        ENDIF
      ENDIF
      IF ((TS3 / SF22) .LE. Q) THEN
        WRITE (LU7, 99996) SF11, SF22, SF33, SF23, SF13, SF12
        IF ((2.0 * SF13 + ER) .LT. SF12) THEN
          IGO=3
          GO TO 30
        ENDIF
      ENDIF
      IF ((TS4 / SF11) .LE. Q) THEN
        WRITE(LU7, 99995) SF11, SF22, SF33, SF23, SF13, SF12
        IF ((2.0 * SF23 + ER) .LT. SF12) THEN
          IGO = 4
          GOTO 30
        ENDIF
      ENDIF
      IF ((TS5 / SF11) .LE. Q) THEN
        WRITE (LU7, 99994) SF11, SF22, SF33, SF23, SF13, SF12
        IF ((2.0 * SF23 + ER) .LT. SF13) THEN
          IGO = 5
          GOTO 30
        ENDIF
      ENDIF
      IRED = 1
      GOTO 30
   20 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) .LE. QQ) THEN
        WRITE (LU7, 99993) SF11, SF22, SF33, SF23, SF13, SF12
        IF ((ABS(SF13) + ER) .LT. ABS(SF23)) THEN
          IGO = 1
          GOTO 30
        ENDIF
      ENDIF
      IF ((TS2 / SF22) .LE. QQ) THEN
        WRITE (LU7, 99992) SF11, SF22, SF33, SF23, SF13, SF12
        IF ((ABS(SF12) + ER) .LT. ABS(SF13)) THEN
          IGO = 2
          GOTO 30
        ENDIF
      ENDIF
      IF ((TS3 / SF22) .LE. Q) THEN
        WRITE (LU7, 99991) SF11, SF22, SF33, SF23, SF13, SF12
        IF (Q .LT. ABS(SF12)) THEN
          IGO = 6
          GOTO 30
        ENDIF
      ENDIF
      IF ((TS4 / SF11) .LE. Q) THEN
        WRITE (LU7, 99990) SF11, SF22, SF33, SF23, SF13, SF12
        IF (Q .LT. ABS(SF12)) THEN
          IGO = 7
          GOTO 30
        ENDIF
      ENDIF
      IF ((TS5 / SF11) .LE. Q) THEN
        WRITE (LU7, 99989) SF11, SF22, SF33, SF23, SF13, SF12
        IF (Q .LT. ABS(SF13)) THEN
          IGO = 8
          GOTO 30
        ENDIF
      ENDIF
      IF ((TS6 / (SF11 + SF22)) .LE. Q) THEN
        WRITE (LU7, 99988) SF11, SF22, SF33, SF23, SF13, SF12
        X1 = ABS(SF13)
        X2 = ABS(SF12)
        X3 = 2.0 * X1 + X2
        IF ((X3 + ER) .LT. SF11) THEN
          IGO = 9
          GOTO 30
        ENDIF
      ENDIF
      IRED = 1
   30 RETURN
99999 FORMAT (//,'**ERROR**FAILED MAIN CONDITIONS FOR REDUCTION')
99998 FORMAT ('NIGGLI +++ A', 2X, 6F15.6)
99997 FORMAT ('NIGGLI +++ B', 2X, 6F15.6)
99996 FORMAT ('NIGGLI +++ C', 2X, 6F15.6)
99995 FORMAT ('NIGGLI +++ D', 2X, 6F15.6)
99994 FORMAT ('NIGGLI +++ E', 2X, 6F15.6)
99993 FORMAT ('NIGGLI --- A', 2X, 6F15.6)
99992 FORMAT ('NIGGLI --- B', 2X, 6F15.6)
99991 FORMAT ('NIGGLI --- C', 2X, 6F15.6)
99990 FORMAT ('NIGGLI --- D', 2X, 6F15.6)
99989 FORMAT ('NIGGLI --- E', 2X, 6F15.6)
99988 FORMAT ('NIGGLI --- F', 2X, 6F15.6)
      END
      SUBROUTINE PLA318
c This routine was adapted from NBS*AIDS80 (Mighell, Hubbard & Stali
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /DOTS/ SF11, SF22, SF33, SF23, SF13, SF12, ITYPE
      COMMON /GARB/ ierr, igo, ired ,e1, ithru
      COMMON /TRANS/ uvw(9), U(9), T(9), P(9)
      ITYPE = 0
      CALL GEN125 (UVW, T)
      CALL GEN074 (U, 0.0, 1, 9)
      Z     = 0
      COSA  = SF23 / (SQRT(SF22) * SQRT(SF33))
      ACOSA = ABS(COSA)
      COSB  = SF13 / (SQRT(SF11) * SQRT(SF33))
      ACOSB = ABS(COSB)
      COSG  = SF12 / (SQRT(SF11) * SQRT(SF22))
      ACOSG = ABS(COSG)
      IF (ACOSA .LE. E1 .OR. ACOSB .LE. E1 .OR. ACOSG .LE. E1) THEN
        IF (COSA .LE. E1 .AND. COSB .LE. E1 .AND. COSG .LE. E1)
     1      ITYPE = 2
        IF (COSA .LE. E1 .AND. COSB .LE. E1 .AND. COSG .LE. E1) GOTO 10
        IF (ACOSA .LE. E1 .AND. COSB  .GT. E1 .AND.  COSG .GT. E1 .OR.
     1      ACOSA .LE. E1 .AND. COSB  .GT. E1 .AND. ACOSG .LE. E1 .OR.
     2      ACOSA .GT. E1 .AND. COSA  .LT. Z  .AND.
     3      COSB  .GT. E1 .AND. ACOSG .LE. E1 .OR.
     4      ACOSA .GT. E1 .AND. COSA  .LT. Z  .AND.
     5      ACOSB .LE. E1 .AND. COSG  .GT. E1) THEN
          U(1) =  1.0
          U(5) = -1.0
          U(9) = -1.0
        ELSE IF (COSA .GT. E1 .AND. ACOSB .LE. E1 .AND.
     1           COSG .GT. E1 .OR.  ACOSA .LE. E1 .AND.
     2          ACOSB .LE. E1 .AND. COSG  .GT. E1 .OR.
     3           COSA .GT. E1 .AND. ACOSB .GT. E1 .AND.
     4           COSB .LT. Z  .AND. ACOSG .LE. E1 .OR.
     5          ACOSA .LE. E1 .AND. ACOSB .GT. E1 .AND.
     6           COSB .LT. Z  .AND. COSG  .GT. E1) THEN
          U(1) = -1.0
          U(5) =  1.0
          U(9) = -1.0
        ELSE IF (COSA .GT. E1 .AND. COSB  .GT. E1 .AND.
     1          ACOSG .LE. E1 .OR.  COSA  .GT. E1 .AND.
     2          ACOSB .LE. E1 .AND. ACOSG .LE. E1 .OR.
     3           COSA .GT. E1 .AND. ACOSB .LE. E1 .AND.
     4          ACOSG .GT. E1 .AND. COSG  .LT. Z  .OR.
     5          ACOSA .LE. E1 .AND. COSB  .GT. E1 .AND.
     6          ACOSG .GT. E1 .AND. COSG  .LT. Z) THEN
          U(1) = -1.0
          U(5) = -1.0
          U(9) =  1.0
        ELSE
          GOTO 10
        ENDIF
        SF23 = - ABS(SF23)
        SF13 = - ABS(SF13)
        SF12 = - ABS(SF12)
        CALL GEN004 (T, U, P)
        ITYPE = 2
      ELSE
        IF (SF23  .GT. Z .AND. SF13 .GT. Z .AND. SF12 .GT. Z) ITYPE = 1
        IF (SF23  .LE. Z .AND. SF13 .LE. Z .AND. SF12 .LE. Z) ITYPE = 2
        IF (ITYPE .EQ. 1 .OR.  ITYPE .EQ. 2) GOTO 10
        IF (SF23 .GT. Z .AND. SF13 .LE. Z .AND. SF12 .LE. Z) THEN
          SF23 = ABS(SF23)
          SF13 = ABS(SF13)
          SF12 = ABS(SF12)
          U(1) = 1.0
          U(5) = -1.0
          U(9) = -1.0
          CALL GEN004 (T, U, P)
          ITYPE = 1
        ELSE IF (SF23 .LE. Z .AND. SF13 .GT. Z .AND. SF12 .LE. Z) THEN
          SF23 = ABS(SF23)
          SF13 = ABS(SF13)
          SF12 = ABS(SF12)
          U(1) = -1.0
          U(5) = 1.0
          U(9) = -1.0
          CALL GEN004 (T, U, P)
          ITYPE = 1
        ELSE IF (SF23 .LE. Z .AND. SF13 .LE. Z .AND. SF12 .GT. Z) THEN
          SF23 = ABS(SF23)
          SF13 = ABS(SF13)
          SF12 = ABS(SF12)
          U(1) = -1.0
          U(5) = -1.0
          U(9) = 1.0
          CALL GEN004 (T, U, P)
          ITYPE = 1
        ELSE IF (SF23 .GT. Z .AND. SF13 .GT. Z .AND. SF12 .LE. Z) THEN
          SF23 = -ABS(SF23)
          SF13 = -ABS(SF13)
          SF12 = -ABS(SF12)
          U(1) = -1.0
          U(5) = -1.0
          U(9) = 1.0
          CALL GEN004 (T, U, P)
          ITYPE = 2
        ELSE IF (SF23 .GT. Z .AND. SF13 .LE. Z .AND. SF12 .GT. Z) THEN
          SF23 = -ABS(SF23)
          SF13 = -ABS(SF13)
          SF12 = -ABS(SF12)
          U(1) = -1.0
          U(5) = 1.0
          U(9) = -1.0
          CALL GEN004 (T, U, P)
          ITYPE = 2
        ELSE IF (SF23 .LE. Z .AND. SF13 .GT. Z .AND. SF12 .GT. Z) THEN
          SF23 = -ABS(SF23)
          SF13 = -ABS(SF13)
          SF12 = -ABS(SF12)
          U(1) = 1.0
          U(5) = -1.0
          U(9) = -1.0
          CALL GEN004 (T, U, P)
          ITYPE = 2
        ELSE
          GOTO 10
        ENDIF
      ENDIF
      CALL GEN125 (P, UVW)
   10 IF (ITYPE .NE. 0) RETURN
      WRITE (LU6, 99999)
      IERR = IERR + 1
99999 FORMAT(//, '**ERROR**SUBROUTINE NORM FAILED TO TYPE CELL')
      RETURN
      END
      SUBROUTINE PLA319
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /cel/af,bf,cf,al,be,ga,aalp,abet,agam,cosa,cosb,cosg
      COMMON /DOTS/ SF11, SF22, SF33, SF23, SF13, SF12, ITYPE
      COMMON/GARB/ ierr, igo, ired ,e1 ,ithru
      COMMON /trans/ uvw(9), u(9), t(9), p(9)
      ithru = 0
      ICT   = 0
      S11 = AF**2
      S22 = BF**2
      S33 = CF**2
      IF (ABS(Al - 90.0) .LT. 0.0001) THEN
        S23 = 0
      ELSE
        S23 = BF * CF * COS(AALP)
      ENDIF
      IF (ABS(ga - 90.0) .LT. 0.0001) THEN
        S12 = 0
      ELSE
        S12 = AF * BF * COS(AGAM)
      ENDIF
      IF (ABS(be - 90.0) .LT. 0.0001) THEN
        S13 = 0
      ELSE
        S13 = AF * CF * COS(ABET)
      ENDIF
      A23 = ABS(S23)
      A13 = ABS(S13)
      A12 = ABS(S12)
   10 IF (2.0 * A23 .GT. S22 .OR. 2.0 * A23 .GT. S33) THEN
        IF (S23 .LT. 0.0) THEN
          XN  = 1.0
          XN1 = 0.0
          GOTO 60
        ELSE IF (S23 .GT. 0.0) THEN
          XN  = -1.0
          XN1 = 0.0
          GOTO 60
        ENDIF
      ENDIF
   40 IF (2.0 * A13 .GT. S11 .OR. 2.0 * A13 .GT. S33) THEN
        IF (S13 .GT. 0.0) THEN
          XN = -1.0
        ELSE
          XN  = 1.0
        ENDIF
        XN1 = 0.0
        R13 = ABS(S13 + XN * S11)
        GOTO 80
      ENDIF
      IF ((2.0 * A12 .GT. S11) .OR.
     1    (2.0 * A12 .GT. S22)) THEN
        IF (S12 .LE. 0.0) THEN
          XN = 1.0
        ELSE
          XN = -1.0
        ENDIF
        XN1 = 0.0
        GOTO 110
      ENDIF
      A    = SQRT(S11)
      B    = SQRT(S22)
      C    = SQRT(S33)
      COSA = S23 / (B * C)
      COSB = S13 / (A * C)
      COSG = S12 / (A * B)
      GOTO 130
   50 R23 = ABS(S23 + XN * S22)
      IF (R23 .LE. A23) THEN
        IF (S23 .LT. 0.0) THEN
          XN  = XN  + 1.0
          XN1 = XN1 + 1.0
        ELSE
          XN  = XN  - 1.0
          XN1 = XN1 - 1.0
        ENDIF
        A23 = R23
        GOTO 50
      ENDIF
      S33 = S33 + (XN1**2) * S22 + 2.0 * XN1 * S23
      S23 = S23 + XN1 * S22
      S13 = S13 + XN1 * S12
      A23 = ABS(S23)
      A13 = ABS(S13)
      CALL GEN125 (UVW, T)
      CALL GEN074 (U, 0.0, 1, 9)
      U(1) = 1.0
      U(5) = 1.0
      U(8) = XN1
      U(9) = 1.0
      CALL GEN004 (T, U, P)
      CALL GEN125 (P, UVW)
      IF (S23 .LT. 0.0) THEN
        XN  = 1.0
        XN1 = 0.0
      ELSE IF (S23 .GT. 0.0) THEN
        XN  = -1.0
        XN1 = 0.0
      ELSE
        GOTO 40
      ENDIF
   60 R23 = ABS(S23 + XN * S22)
      IF (R23 .LE. A23) THEN
        IF (S23 .LT. 0.0) THEN
          XN  = XN  + 1.0
          XN1 = XN1 + 1.0
        ELSE
          XN  = XN  - 1.0
          XN1 = XN1 - 1.0
        ENDIF
        A23 = R23
        GOTO 60
      ENDIF
      S22 = S22 + (XN1**2) * S33 + 2.0 * XN1 * S23
      S23 = S23 + XN1  * S33
      S12 = S12 + (XN1 * S13)
      A23 = ABS(S23)
      A12 = ABS(S12)
      CALL GEN125 (UVW, T)
      CALL GEN074 (U, 0.0, 1, 9)
      U(1) = 1.0
      U(5) = 1.0
      U(6) = XN1
      U(9) = 1.0
      CALL GEN004 (T, U, P)
      CALL GEN125 (P, UVW)
      GOTO 10
   80 IF (R13 .LE. A13) THEN
        IF (S13 .GE. 0.0) THEN
          XN  = XN  - 1.0
          XN1 = XN1 - 1.0
        ELSE
          XN  = XN  + 1.0
          XN1 = XN1 + 1.0
        ENDIF
        A13 = R13
        R13 = ABS(S13 + XN * S11)
        GOTO 80
      ENDIF
      S33 = S33 + (XN1**2) * S11 + 2.0 * XN1 * S13
      S13 = S13 + XN1 * S11
      S23 = S23 + XN1 * S12
      A13 = ABS(S13)
      A23 = ABS(S23)
      CALL GEN125 (UVW, T)
      CALL GEN074 (U, 0.0, 1, 9)
      U(1) = 1.0
      U(5) = 1.0
      U(7) = XN1
      U(9) = 1.0
      CALL GEN004 (T, U, P)
      CALL GEN125 (P, UVW)
      IF (S13 .GT. 0.0) THEN
        XN = -1.0
      ELSE
        XN  = 1.0
      ENDIF
      XN1 = 0.0
   90 R13 = ABS(S13 + XN * S33)
      IF (R13 .GT. 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)
        CALL GEN125 (UVW, T)
      CALL GEN074 (U, 0.0, 1, 9)
        U(1) = 1.0
        U(3) = XN1
        U(5) = 1.0
        U(9) = 1.0
        CALL GEN004 (T, U, P)
        CALL GEN125 (P, UVW)
        GOTO 10
      ENDIF
      IF (S13 .LT. 0.0) THEN
        XN  = XN  + 1.0
        XN1 = XN1 + 1.0
      ELSE
        XN  = XN  - 1.0
        XN1 = XN1 - 1.0
      ENDIF
      A13 = R13
      GOTO 90
  110 R12 = ABS(S12 + XN * S11)
      IF (R12 .LE. A12) THEN
        IF (S12 .LT. 0.0) THEN
          XN  = XN  + 1.0
          XN1 = XN1 + 1.0
        ELSE
          XN  = XN  - 1.0
          XN1 = XN1 - 1.0
        ENDIF
        A12 = R12
        GOTO 110
      ENDIF
      S22 = S22 + (XN1**2) * S11 + 2.0 * XN1 * S12
      S12 = S12 + XN1 * S11
      S23 = S23 + XN1 * S13
      A12 = ABS(S12)
      A23 = ABS(S23)
      CALL GEN125 (UVW, T)
      CALL GEN074 (U, 0.0, 1, 9)
      U(1) = 1.0
      U(4) = XN1
      U(5) = 1.0
      U(9) = 1.0
      CALL GEN004 (T, U, P)
      CALL GEN125 (P, UVW)
      IF (S12 .GT. 0.0) THEN
        XN = -1.0
      ELSE
        XN = 1.0
      ENDIF
      XN1 = 0.0
  120 R12 = ABS(S12 + XN * S22)
      IF (R12 .LE. A12) THEN
        IF (S12 .GE. 0.0) THEN
          XN  = XN  - 1.0
          XN1 = XN1 - 1.0
        ELSE
          XN  = XN  + 1.0
          XN1 = XN1 + 1.0
        ENDIF
        A12 = R12
        GOTO 120
      ENDIF
      S11 = S11 + (XN1**2) * S22 + 2.0 * XN1 * S12
      S12 = S12 + XN1 * S22
      S13 = S13 + XN1 * S23
      A12 = ABS(S12)
      A13 = ABS(S13)
      CALL GEN125 (UVW, T)
      CALL GEN074 (U, 0.0, 1, 9)
      U(1) = 1.0
      U(2) = XN1
      U(5) = 1.0
      U(9) = 1.0
      CALL GEN004 (T, U, P)
      CALL GEN125 (P, UVW)
      GOTO 10
  130 CALL GEN125 (UVW, T)
      CALL GEN074 (U, 0.0, 1, 9)
      IF (A .LE. B) THEN
        IF (A .GT. C) THEN
          T1   = C
          T2   = A
          T3   = B
          E12  = COSB
          E13  = COSA
          E23  = COSG
          U(3) = 1.0
          U(4) = 1.0
          U(8) = 1.0
          GOTO 140
        ENDIF
        T1  = A
        IF (B .LE. C) THEN
          T2   = C
          T3   = B
          E12  = COSB
          E13  = -COSG
          E23  = -COSA
          U(1) = 1.0
          U(6) = 1.0
          U(8) = -1.0
          GOTO 140
        ENDIF
        T2  = B
        T3  = C
        E23 = COSA
        E13 = COSB
        E12 = COSG
        GOTO 150
      ENDIF
      IF (A .GT. C) THEN
        T3   = A
        IF (B .GT. C) THEN
          T1   = C
          T2   = B
          E12  = COSA
          E13  = -COSB
          E23  = -COSG
          U(3) = 1.0
          U(5) = 1.0
          U(7) = -1.0
        ELSE
          T1   = B
          T2   = C
          E12  = COSA
          E13  = COSG
          E23  = COSB
          U(2) = 1.0
          U(6) = 1.0
          U(7) = 1.0
        ENDIF
      ELSE
        T1   = B
        T2   = A
        T3   = C
        E12  = COSG
        E13  = -COSA
        E23  = -COSB
        U(2) = 1.0
        U(4) = 1.0
        U(9) = -1.0
      ENDIF
  140 CALL GEN004 (T, U, P)
      CALL GEN125 (P, UVW)
  150 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
      CALL PLA318
      IF (ITYPE .EQ. 2) THEN
        CALL GEN125 (UVW, T)
        CALL GEN074 (U, 0.0, 1, 9)
        TX1 = SF11 + SF22
        TX2 = 2.0 * (ABS(SF23) + ABS(SF13) + ABS(SF12))
        ICT = ICT + 1
        IF (ICT .LE. 2) THEN
          IF (TX1 .LT. TX2) THEN
            SF33 = SF11 + SF22 + SF33 + 2.0 * SF12 + 2.0 * SF13
     1           + 2.0 * SF23
            SF23 = SF12 + SF23 + SF22
            SF13 = SF11 + SF12 + SF13
            U(1) = 1.0
            U(2) = 0.0
            U(3) = 0.0
            U(4) = 0.0
            U(5) = 1.0
            U(6) = 0.0
            U(7) = 1.0
            U(8) = 1.0
            U(9) = 1.0
            CALL GEN004 (T, U, P)
            CALL GEN125 (P, UVW)
            A    = SQRT(SF11)
            B    = SQRT(SF22)
            C    = SQRT(SF33)
            COSA = SF23 / (B * C)
            COSB = SF13 / (A * C)
            COSG = SF12 / (A * B)
            GO TO 130
          ENDIF
        ENDIF
      ENDIF
      CALL PLA317
      ICOUNT = 0
  160 CALL PLA318
      CALL PLA317
      IF (IRED .NE. 1) THEN
        IF (IGO .GE. 1 .AND. IGO .LE. 9) THEN
          CALL PLA322
          ICOUNT = ICOUNT + 1
          IF (ICOUNT .LT. 20) GOTO 160
        ENDIF
        WRITE (LU7, 99999)
        IERR = IERR + 1
      ENDIF
      RETURN
99999 FORMAT('ERROR - PROGRAM FAILS AT END OF SUBROUTINE PLA319')
      END
      SUBROUTINE  PLA321 (NBR)
c called by PLA312 - ASSIGNS INITIAL TRANSFORMATION MATRIX
      COMMON /TRANS/ U1, V1, W1, U2, V2, W2, U3, V3, W3, U(9), T(9),
     1               P(9)
c     these are respectively : P, A, C, F, I and R centrings
      IF (NBR .EQ. 1) THEN
        U1 = 1.0
        V1 = 0.0
        W1 = 0.0
        U2 = 0.0
        V2 = 1.0
        W2 = 0.0
        U3 = 0.0
        V3 = 0.0
        W3 = 1.0
      ELSE IF (NBR .EQ. 2) THEN
        U1 = 0.0
        V1 = 0.5
        W1 = -0.5
        U2 = 0.0
        V2 = 0.5
        W2 = 0.5
        U3 = 1.0
        V3 = 0.0
        W3 = 0.0
      ELSE IF (NBR .EQ. 3) THEN
        U1 = 0.5
        V1 = -0.5
        W1 = 0.0
        U2 = 0.5
        V2 = 0.5
        W2 = 0.0
        U3 = 0.0
        V3 = 0.0
        W3 = 1.0
      ELSE IF (NBR .EQ. 4) THEN
        U1 = 0.5
        V1 = 0.5
        W1 = 0.0
        U2 = 0.0
        V2 = 0.5
        W2 = 0.5
        U3 = 0.5
        V3 = 0.0
        W3 = 0.5
      ELSE IF (NBR .EQ. 5) THEN
        U1 = 0.5
        V1 = 0.5
        W1 = -0.5
        U2 = -0.5
        V2 = 0.5
        W2 = 0.5
        U3 = 0.5
        V3 = -0.5
        W3 = 0.5
      ELSE IF (NBR .EQ. 6) THEN
        c1 = 1.0 / 3.0
        c2 = 2.0 / 3.0
        U1 = c1
        V1 = -c1
        W1 = -c1
        U2 = -c2
        V2 = -c1
        W2 = -c1
        U3 = c1
        V3 = c2
        W3 = -c1
      ENDIF
      RETURN
      END
      SUBROUTINE PLA322
      COMMON /DOTS/ SF11, SF22, SF33, SF23, SF13, SF12, ITYPE
      COMMON /GARB/  ierr, igo, ired ,E1, ithru
      COMMON /TRANS/ UVW(9), U(9), T(9), P(9)
      CALL GEN125 (UVW, T)
      CALL GEN074 (U, 0.0, 1, 9)
      SSF23 = SF23
      SSF13 = SF13
      SSF12 = SF12
      IF (IGO .EQ. 1) THEN
        SF23 = SSF13
        SF13 = SSF23
        SF12 = SSF12
        U(2) = -1.0
        U(4) = -1.0
        U(9) = -1.0
      ELSE IF (IGO .EQ. 2) THEN
        SF23 = SSF23
        SF13 = SSF12
        SF12 = SSF13
        U(1) = -1.0
        U(6) = -1.0
        U(8) = -1.0
      ELSE IF (IGO .EQ. 3) THEN
        SF23 = SSF23
        SF13 = SSF12 - SSF13
        SF12 = SSF12
        U(1) = -1.0
        U(5) = -1.0
        U(8) = -1.0
        U(9) =  1.0
      ELSE IF (IGO .EQ. 4) THEN
        SF23 = SSF12 - SSF23
        SF13 = SSF13
        SF12 = SSF12
        U(1) = -1.0
        U(5) = -1.0
        U(7) = -1.0
        U(9) =  1.0
      ELSE IF (IGO .EQ. 5) THEN
        SF23 = SSF13 - SSF23
        SF13 = SSF13
        SF12 = SSF12
        U(1) = -1.0
        U(4) = -1.0
        U(5) =  1.0
        U(9) = -1.0
      ELSE IF (IGO .EQ. 6) THEN
        SF23 = ABS(SSF23)
        SF13 = ABS(SSF13) + ABS(SSF12)
        SF12 = ABS(SSF12)
        U(1) =  1.0
        U(5) = -1.0
        U(8) = -1.0
        U(9) = -1.0
      ELSE IF (IGO .EQ. 7) THEN
        SF23 = ABS(SSF23) + ABS(SSF12)
        SF13 = ABS(SSF13)
        SF12 = ABS(SSF12)
        U(1) = -1.0
        U(5) =  1.0
        U(7) = -1.0
        U(9) = -1.0
      ELSE IF (IGO .EQ. 8) THEN
        SF23 = ABS(SSF23) + ABS(SSF13)
        SF13 = ABS(SSF13)
        SF12 = ABS(SSF12)
        U(1) = -1.0
        U(4) = -1.0
        U(5) = -1.0
        U(9) =  1.0
      ELSE IF (IGO .EQ. 9) THEN
        SF23 = ABS(SSF12) + ABS(SSF23) - SF22
        SF13 = ABS(SSF12) + ABS(SSF13) - SF11
        SF12 = SSF12
        U(1) = -1.0
        U(5) = -1.0
        U(7) =  1.0
        U(8) =  1.0
        U(9) =  1.0
      ENDIF
      CALL GEN004 (T, U, P)
      CALL GEN125 (P, UVW)
      RETURN
      END
      SUBROUTINE PLA323 (ISEQ)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /cel/ a,b,c,al,be,ga,alf,bet,gam,cosa,cosb,cosg
      Q      = 0.004
      DQ     = 0.04
      IFLAG1 = 0
      IFLAG2 = 0
      IFLAG3 = 0
      NEG    = 1
      ISEQ   = 0
      e1     = a**2
      e2     = b**2
      e3     = c**2
      e4     = cosa * b * c
      e5     = cosb * a * c
      e6     = cosg * a * b
      ONE    = ABS(E1 - E3)
      TWO    = ABS(E1 - E2)
      THREE  = ABS(E2 - E3)
      IF (ONE .LT. (Q * E3)) IFLAG1 = 1
      IF (TWO .LT. (Q * E2)) IFLAG2 = 1
      IF (THREE .LT. (Q * E3)) IFLAG3 = 1
      IF (e4 .LT. Q .AND. e5 .LT. Q .AND. e6 .LE. Q) NEG = -1
      IF (e4 .GT. Q .AND. e5 .GT. Q .AND. e6 .GE. Q) NEG = 0
      IF (NEG .EQ. 1) THEN
        NEG = -1
        IF (AL .LT. 89.99 .OR. BE .LT. 89.99 .OR. GA .LT. 89.99) NEG = 0
        WRITE (LU7, 99999)
      ENDIF
      IF (IFLAG1 .EQ. 1) GOTO 10
      IF (IFLAG2 .EQ. 1) GOTO 20
      IF (IFLAG3 .EQ. 1) GOTO 40
      GOTO 60
   10 IF (NEG .NE. -1) THEN
        X = E1 / 2.0
        IF (ABS(E4 - X) .LT. (E4 * Q + DQ) .AND.
     1      ABS(E5 - X) .LT. (E5 * Q + DQ) .AND.
     2      ABS(E6 - X) .LT. (E6 * Q + DQ)) ISEQ = 1
        IF (ISEQ .NE. 0) GOTO 80
        IF (ABS(E4 - E5) .LT. (E4 * Q + DQ) .AND.
     1      ABS(E5 - E6) .LT. (E5 * Q + DQ)) ISEQ = 2
        IF (ISEQ .NE. 0) GOTO 80
        GO TO 20
      ENDIF
      Z = E1 / 3.0
      IF ((ABS(E4) + ABS(E5) + ABS(E6)) .LT. (DQ * 3.0)) ISEQ = 3
      IF (ISEQ .NE. 0) GOTO 80
      IF (ABS(E4 + Z) .LT. (ABS(E4 * Q) + DQ) .AND.
     1    ABS(E5 + Z) .LT. (ABS(E5 * Q) + DQ) .AND.
     2    ABS(E6 + Z) .LT. (ABS(E6 * Q) + DQ)) ISEQ = 5
      IF (ISEQ .NE. 0) GOTO 80
      IF (ABS(E4 - E5) .LT. (ABS(E4 * Q) + DQ) .AND.
     1    ABS(E5 - E6) .LT. (ABS(E5 * Q) + DQ)) ISEQ = 4
      IF (ISEQ .NE. 0) GOTO 80
      IF (ABS(E4 - E5) .LT. (ABS(E4 * Q) + DQ) .AND.
     1    ABS((E6 + E1) / 2.0 + E4) .LT. (ABS(E4 * Q) + DQ)) ISEQ = 6
      IF (ISEQ .NE. 0) GOTO 80
      IF (ABS(E5 - E6) .LT. (ABS(E5 * Q) + DQ) .AND.
     1    ABS((E4 + E1) / 2.0 + E5) .LT. (ABS(E5 * Q) + DQ)) ISEQ = 7
      IF (ISEQ .NE. 0) GOTO 80
      IF (ABS(E1 + E4 + E5 + E6) .LT. (ABS(E6 * Q) + DQ)) ISEQ = 8
      IF (ISEQ .NE. 0) GOTO 80
      GO TO 30
   20 IF (NEG .NE. -1) THEN
        X = E1 / 2.0
        IF (ABS(E4 - X) .LT. (E4 * Q + DQ) .AND.
     1      ABS(E5 - X) .LT. (E5 * Q + DQ) .AND.
     2      ABS(E6 - X) .LT. (E6 * Q + DQ)) ISEQ = 9
        IF (ISEQ .NE. 0) GOTO 80
        IF (ABS(E4 - E5) .LT. (ABS(E4 * Q) + DQ)) ISEQ = 10
        IF (ISEQ .NE. 0) GOTO 80
        GO TO 40
      ENDIF
   30 X = E1 / 2.0
      IF (ABS(E4 + E5) .LT. (DQ * 2.0) .AND.
     1    ABS(E6 + X)  .LT. (ABS(E6 * Q) + DQ)) ISEQ = 12
      IF (ISEQ .NE. 0) GOTO 80
      IF ((ABS(E4) + ABS(E5) + ABS(E6)) .LT. (DQ * 3.0)) ISEQ = 11
      IF (ISEQ .NE. 0) GOTO 80
      IF (ABS(E4 - E5) .LT. (ABS(E4 * Q) + DQ) .AND.
     1    ABS(E4 + X)  .LT. (ABS(E4 * Q) + DQ)) ISEQ = 15
      IF (ISEQ .NE. 0) GOTO 80
      IF (ABS(E4 + E5) .LT. (DQ * 2.0)) ISEQ = 13
      IF (ISEQ .NE. 0) GOTO 80
      IF (ABS(E4 - E5) .LT. (ABS(E4 * Q) + DQ) .AND.
     1    ABS(E1 + 2.0 * E4 + E6) .LT. (ABS(E6 * Q)  + DQ)) ISEQ = 16
      IF (ISEQ .NE. 0) GOTO 80
      IF (ABS(E1 + E4 + E5 + E6) .LT. (ABS(E6 * Q) + DQ)) ISEQ = 17
      IF (ISEQ .NE. 0) GOTO 80
      IF (ABS(E4 - E5) .LT. (ABS(E4 * Q) + DQ)) ISEQ = 14
      IF (ISEQ .NE. 0) GOTO 80
      GOTO 50
   40 IF (ABS(b - c) .GT. ABS(b * Q)) GOTO 60
      IF (NEG .NE. -1) THEN
        X = E1 / 2.0
        IF (ABS(E4 - X / 2.0) .LT. (ABS(E4 * Q) + DQ) .AND.
     1      ABS(E5 - E6) .LT. (ABS(E5 * Q) + DQ) .AND.
     2      ABS(E5 - X)  .LT. (ABS(E5 * Q) + DQ)) ISEQ = 18
        IF (ISEQ .NE. 0) GOTO 80
        IF (ABS(E5 - E6) .LT. (ABS(E5 * Q) + DQ) .AND.
     1      ABS(E5 - X)  .LT. (ABS(E5 * Q) + DQ)) ISEQ = 19
        IF (ISEQ .NE. 0) GOTO 80
        IF (ABS(E5 - E6) .LT. (ABS(E5 * Q) + DQ)) ISEQ = 20
        IF (ISEQ .NE. 0) GOTO 80
        GOTO 60
      ENDIF
   50 IF (ABS(b - c) .LE. ABS(b * Q)) THEN
        Y = E2 / 2.0
        IF (ABS(((E2 - E1 / 3.0) / 2.0) + E4) .LT. (ABS(E4 * Q) + DQ)
     1    .AND. ABS(E5 - E6) .LT. (ABS(E5 * Q) + DQ)
     2    .AND. ABS(E5 + E1 / 3.0) .LT. (ABS(E5 * Q) + DQ)) ISEQ = 24
        IF (ISEQ .NE. 0) GOTO 80
        IF (ABS(E6 + E5) .LT. (DQ * 2.0) .AND.
     1      ABS(E4 + Y)  .LT. (ABS(E4 * Q) + DQ)) ISEQ = 22
        IF (ISEQ .NE. 0) GOTO 80
        IF ((ABS(E4) + ABS(E5) + ABS(E6)) .LT. (DQ * 3.0)) ISEQ = 21
        IF (ISEQ .NE. 0) GOTO 80
        IF (ABS(E6 + E5) .LT. (DQ * 2.0)) ISEQ = 23
        IF (ISEQ .NE. 0) GOTO 80
        IF (ABS(E5 - E6) .LT. (ABS(E5 * Q) + DQ)) ISEQ = 25
        IF (ISEQ .NE. 0) GOTO 80
      ENDIF
      GOTO 70
   60 IF (NEG .NE. -1) THEN
        X = E1 / 2.0
        Y = E2 / 2.0
        IF (ABS(E4 - X / 2.0) .LT. (ABS(E4 * Q) + DQ) .AND.
     1      ABS(E5 - E6) .LT. (ABS(E5 * Q) + DQ) .AND.
     2      ABS(E5 - X) .LT. (ABS(E5 * Q) + DQ)) ISEQ = 26
        IF (ISEQ .NE. 0) GOTO 80
        IF (ABS(E5 - E6) .LT. (ABS(E5 * Q) + DQ) .AND.
     1      ABS(E5 - X)  .LT. (ABS(E5 * Q) + DQ)) ISEQ = 27
        IF (ISEQ .NE. 0) GOTO 80
        IF (ABS(E4 - E6 / 2.0) .LT. (ABS(E4 * Q) + DQ) .AND.
     1      ABS(E5 - X) .LT. (ABS(E5 * Q) + DQ)) ISEQ = 28
        IF (ISEQ .NE. 0) GOTO 80
        IF (ABS(E4 - E5 / 2.0) .LT. (ABS(E4 * Q) + DQ) .AND.
     1      ABS(E6 - X) .LT. (ABS(E6 * Q) + DQ)) ISEQ = 29
        IF (ISEQ .NE. 0) GOTO 80
        IF (ABS(E4 - Y) .LT. (ABS(E4 * Q) + DQ) .AND.
     1      ABS(E5 - E6 / 2.0) .LT. (ABS(E5 * Q) + DQ)) ISEQ = 30
        IF (ISEQ .NE. 0) GOTO 80
        ISEQ = 31
        GOTO 80
      ENDIF
   70 X = E1 / 2.0
      Y = E2 / 2.0
      IF ((ABS(E4) + ABS(E5) + ABS(E6)) .LT. (DQ * 3.0)) ISEQ = 32
      IF (ISEQ .NE. 0) GOTO 80
      IF (ABS(E6 + E4) .LT. (DQ * 2.0) .AND.
     1    ABS(E5 + X)  .LT. (ABS(E5 * Q) + DQ)) ISEQ = 36
      IF (ISEQ .NE. 0) GOTO 80
      IF (ABS(E5 + E4) .LT. (DQ * 2.0) .AND.
     1    ABS(E6 + X)  .LT. (ABS(E6 * Q) + DQ)) ISEQ = 38
      IF (ISEQ .NE. 0) GOTO 80
      IF (ABS(E6 + E5) .LT. (DQ * 2.0) .AND.
     1    ABS(E4 + Y)  .LT. (ABS(E4 * Q) + DQ)) ISEQ = 40
      IF (ISEQ .NE. 0) GOTO 80
      IF (ABS(E6) .LT. DQ .AND. ABS(E4 + Y) .LT. (ABS(E4 * Q) + DQ)
     1   .AND. ABS(E5 + X) .LT. (ABS(E5 * Q) + DQ)) ISEQ = 42
      IF (ISEQ .NE. 0) GOTO 80
      IF (ABS(E4 + E6) .LT. (DQ * 2.0)) ISEQ = 33
      IF (ISEQ .NE. 0) GOTO 80
      IF (ABS(E4 + E5) .LT. (DQ * 2.0)) ISEQ = 34
      IF (ISEQ .NE. 0) GOTO 80
      IF (ABS(E6 + E5) .LT. (DQ * 2.0)) ISEQ = 35
      IF (ISEQ .NE. 0) GOTO 80
      IF (ABS(E5 + X) .LT. (ABS(E5 * Q) + DQ) .AND.
     1    ABS(E6) .LT. DQ) ISEQ = 37
      IF (ISEQ .NE. 0) GOTO 80
      IF (ABS(E6 + X) .LT. (ABS(E6 * Q) + DQ) .AND.
     1    ABS(E5) .LT. DQ) ISEQ = 39
      IF (ISEQ .NE. 0) GOTO 80
      IF (ABS(E4 + Y) .LT. (ABS(E4 * Q) + DQ) .AND.
     1    ABS(E6) .LT. DQ) ISEQ = 41
      IF (ISEQ .NE. 0) GOTO 80
      IF (ABS(E4 + (E2 + E6) / 2.0) .LT. (ABS(E4 * Q) + DQ) .AND.
     1    ABS(E5 + (E1 + E6) / 2.0) .LT. (ABS(E5 * Q) + DQ)) ISEQ = 43
      IF (ISEQ .EQ. 0) ISEQ = 44
   80 RETURN
99999 FORMAT(//,'**WARNING**REDUCED FORM MAY NOT BE CORRECT')
      END
      SUBROUTINE PLA325 (pear, ipears, pmin, kelt, ncs, ntio, *)
      PARAMETER (numat=150,NELTS=16)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /STBL4/ ipol, r, ngr, iocfl, vol, nfl, volrat
      COMMON /at/ iat, pos(3), ihex, fnum
      COMMON /atch/ elt1, elt2, f
      COMMON /brz/ ngo, ir(48, 3, 3), it(48, 3), nbr
      COMMON /bur/ nt, spgr
      COMMON /ch/ xa(3, numat)
      COMMON /matr/ ifmat, ifsh, ifplus, xmat(3, 3), plus(3), sh(3),
     1 nabc, nsh, nshtra, ifnig, xmsave(3, 3), shif(3), minsh
      COMMON /orgin/ nor, orgadd(3, 8), ntext, icoord
      COMMON /posi/ x(3, 192), dist(192), kount
      COMMON /res/ atom1, atom2, foccu, intxt, code, elt
      COMMON /rot/ xrot(3, numat), natom
      COMMON /sp/ n, nw, ns(26), is(27), mult(15), nset(8), kset, mu,
     1 kord
      common/trip/ dmin, min, korder(192), iflag, xmin(3, numat),
     1 mul(numat), let(numat), nrset(numat), nnset(8, numat)
      CHARACTER*1 nt(16), code(2), intxt*40
      CHARACTER spgr*10, atom1(numat)*2, atom2(numat)*4,
     1          foccu(numat)*5
      CHARACTER elt(NELTS)*2, elt1*2, elt2*4, f*5
      DIMENSION pear(NELTS), xx(3, numat), sav(3, 3), nent(11), y(3),
     1 ff(numat)
      data nent /76, 91, 92, 144, 151, 152, 169, 171, 178, 180, 213/
      ep  = 0.000001
      nig = 1
      DO 20 j = 1, numat
        DO 10 i = 1, 3
          XX(I, J) = 0.0
   10   CONTINUE
   20 CONTINUE
      DO 40 i = 1, 3
        DO 30 j = 1, 3
          sav(j, i)  = xmat(j, i)
          xmat(j, i) = xmsave(j, i)
   30   CONTINUE
   40 CONTINUE
      ipears = 0
      pmin   = 0.0
c
c if centric group, take only half of positions :
      IF (ncs .EQ. 0) ngo = ngo / 2
      natom = 0
      kelt  = 0
      knt   = 0
c set centring as for primitive cell :
      nbr = 1
   50 CALL PLA305 (nig, *160)
      CALL PLA326
      DO 150 i = 1, kount
        IF (ifnig .EQ. 2) THEN
          DO 60 j = 1, 3
            pos(j) = x(1, i) * sav(1, j) + x(2, i) * sav(2, j)
     1             + x(3, i) * sav(3, j)
   60     CONTINUE
c put positions between 0 and 1 :
          DO 90 j = 1, 3
   70       IF (pos(j) .LT. - 0.000001) THEN
              pos(j) = pos(j) + 1.0
              GOTO 70
            ENDIF
   80       IF (pos(j) .GE. 0.999999) THEN
              pos(j) = pos(j) - 1.0
              GOTO 80
            ENDIF
   90     CONTINUE
        ELSE
          DO 100 j = 1, 3
            pos(j) = x(j, i)
  100     CONTINUE
        ENDIF
c get out doubles caused by transformation :
        IF (knt .GT. 0) THEN
          DO 110 j = 1, knt
            IF (abs(pos(1) - xx(1, j)) .LT. ep .AND.
     1          abs(pos(2) - xx(2, j)) .LT. ep .AND.
     2          abs(pos(3) - xx(3, j)) .LT. ep) GOTO 150
  110     CONTINUE
c for P-1 eliminate also positions -x,-y,-z :
          IF (ncs .EQ. 0) THEN
            DO 130 j = 1, knt
              DO 120 k = 1, 3
                y(k) = pos(k) + xx(k, j)
                IF (y(k) .GT. 0.999999) y(k) = y(k) - 1.0
  120         CONTINUE
              IF (abs(y(1)) .LT. ep .AND. abs(y(2)) .LT. ep .AND.
     1            abs(y(3)) .LT. ep) GOTO 150
  130       CONTINUE
          ENDIF
        ENDIF
        knt        = knt + 1
        atom1(knt) = elt1
        atom2(knt) = elt2
        foccu(knt) = f
        ff(knt)    = fnum
        DO 140 j = 1, 3
          xx(j, knt) = pos(j)
  140   CONTINUE
  150 CONTINUE
      IF (knt .GE. numat) GOTO 350
      GOTO  50
  160 natom = knt
      WRITE (LU7, 99998)
      DO 170 i = 1, natom
        WRITE (LU7, 99997) atom1(i), atom2(i), (xx(j, i), j = 1, 3)
  170 CONTINUE
c new symmetry factors :
      DO 200 i = 1, 3
        DO 190 j = 1, 3
          DO 180 k = 1, 48
            ir(k, j, i) = 0
  180     CONTINUE
  190   CONTINUE
  200 CONTINUE
      DO 220 i = 1, 3
        DO 210 j = 1, 48
          it(j, i) = 0
  210   CONTINUE
  220 CONTINUE
      DO 240 i = 1, 8
        DO 230 j = 1, 3
          orgadd(j, i) = 0.0
  230   CONTINUE
  240 CONTINUE
      nt(1)   = 'P'
      nt(2)   = ' '
      code(1) = 'a'
      code(2) = 'P'
      IF (ncs .EQ. 0) THEN
        nt(3) = '-'
        nt(4) = '1'
        spgr  = 'P -1'
        ngr   = 2
        n     = 8
        nw    = 2
        ntio  = 0
        DO 250 i = 1, 8
          is(i) = 1
          ns(i) = 9 - i
  250   CONTINUE
        mult(1) = 1
        mult(2) = 2
        DO 260 i = 1, 3
          ir(1, i, i) = 1
          ir(2, i, i) = -1
  260   CONTINUE
        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
        spgr        = 'P 1'
        ipol        = 0
        nor         = -31
        nt(3)       = '1'
        nt(4)       = ' '
        n           = 0
        nw          = 1
        is(1)       = 1
        ntio        = 1
        mult(1)     = 1
        ir(1, 1, 1) = 1
        ir(1, 2, 2) = 1
        ir(1, 3, 3) = 1
        ngo         = 1
        ngr         = 1
        DO 270 i = 1, 11
          IF (ngr .EQ. nent(i)) THEN
            ntio = 0
            nfl  = 1
            GOTO 280
          ENDIF
  270   CONTINUE
      ENDIF
  280 CALL GEN126 (NT, 5, 16)
      WRITE (LU7, 99996) ngr, spgr
      DO 340 ia = 1, natom
        DO 290 j = 1, 3
          pos(j) = xx(j, ia)
  290   CONTINUE
        CALL PLA326
        kset = 0
        IF (n .EQ. 0) THEN
          mu = mult(1)
          kord = 1
        ELSE
          CALL PLA328 (nig)
        ENDIF
        fmu    = float(mu)
        fn     = ff(ia) * fmu
        ipears = ipears + mu
        pmin   = pmin + fmu - fn
        elt1   = atom1(ia)
        IF (kelt .GT. 0) THEN
          DO 300 i = 1, kelt
            IF (elt1 .EQ. elt(i)) GOTO 310
  300     CONTINUE
        ENDIF
        kelt = kelt + 1
        IF (kelt .GT. NELTS) THEN
          WRITE (LU7, 99999) NELTS
          kelt = kelt - 1
        ENDIF
        elt(kelt) = elt1
        i         = kelt
  310   pear(i)   = pear(i) + fn
        DO 320 j = 1, 3
          xa(j, ia) = x(j, 1)
  320   CONTINUE
        IF (kset .NE. 0) THEN
          DO 330 j = 1, kset
            nnset(j, ia) = nset(j)
  330     CONTINUE
          nrset(ia) = kset
        ENDIF
  340 CONTINUE
      RETURN
  350 WRITE (LU7, 99995)
      RETURN 1
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 PLA326
      COMMON /at/ iat, pos(3), ihex, fnum
      COMMON /brz/ ngo, r, t, nbr
      COMMON /posi/ x(3, 192), dist(192), kount
      integer r(48, 3, 3), t(48, 3)
      ng = ngo
      k  = ng
      p1 = 1.0 / 3.0
      p2 = 2.0 / 3.0
      DO 20 i = 1, ng
        DO 10 j = 1, 3
          s = float(t(i, j)) / 24.0
          x(j, i) = r(i, j, 1) * pos(1) + r(i, j, 2) * pos(2)
     1            + r(i, j, 3) * pos(3) + s
   10   CONTINUE
   20 CONTINUE
      GOTO (130, 30, 50, 30, 70, 100), nbr
   30 DO 40 i = 1, ng
        k = ng + i
        x(1, k) = x(1, i)
        x(2, k) = x(2, i) + 0.5
        x(3, k) = x(3, i) + 0.5
   40 CONTINUE
      ng = k
      IF (nbr .ne. 4) GOTO 130
   50 DO 60 i = 1, ng
        k = ng + i
        x(1, k) = x(1, i) + 0.5
        x(2, k) = x(2, i) + 0.5
        x(3, k) = x(3, i)
   60 CONTINUE
      ng = k
      GOTO 130
   70 DO 90 i = 1, ng
        k = ng + i
        DO 80 j = 1, 3
          x(j, k) = x(j, i) + 0.5
   80   CONTINUE
   90 CONTINUE
      ng = k
      GOTO 130
  100 DO 110 i = 1, ng
        k = ng + i
        x(1, k) = x(1, i) + p2
        x(2, k) = x(2, i) + p1
        x(3, k) = x(3, i) + p1
  110 CONTINUE
      k1 = ng + ng
      DO 120 i = 1, ng
        k = k1 + i
        x(1, k) = x(1, i) + p1
        x(2, k) = x(2, i) + p2
        x(3, k) = x(3, i) + p2
  120 CONTINUE
      ng = k
c Put positions between 0 and 1:
  130 DO 170 j = 1, ng
        DO 160 i = 1, 3
          eps  = - 0.000001
          eps1 = 1.0 + eps
  140     if (x(i, j) .LT. eps) THEN
            x(i, j) = x(i, j) + 1.0
            GOTO 140
          ENDIF
  150     if (x(i, j) .GE. eps1) THEN
            x(i, j) = x(i, j) - 1.0
            GOTO 150
          ENDIF
  160   CONTINUE
  170 CONTINUE
c Get out doubles
      eps = 0.0001
      ng1 = ng - 1
      DO 190 i = 1, ng1
        xx = x(1, i)
        if (xx .LE. 1.0) THEN
          yy = x(2, i)
          zz = x(3, i)
          i1 = i + 1
          DO 180 j = i1, ng
            if (x(1, j) .LE. 1.0) THEN
              d1 = abs(x(1, j) - xx)
              d2 = abs(x(2, j) - yy)
              d3 = abs(x(3, j) - zz)
              IF (d1 .LT. eps .AND. d2 .LT. eps .AND. d3 .LT. eps)
     1           x(1, j) = 10.0
            ENDIF
  180     CONTINUE
        ENDIF
  190 CONTINUE
      kount = 0
      DO 220 i = 1, ng
        IF (x(1, i) .LE. 1.0) THEN
          kount = kount + 1
          sum   = 0.0
          DO 200 j = 1, 3
            sum = sum + x(j, i)**2
  200     CONTINUE
          dist(kount) = sqrt(sum)
          DO 210 j = 1, 3
            x(j, kount) = x(j, i)
  210     CONTINUE
        ENDIF
  220 CONTINUE
      RETURN
      END
      SUBROUTINE PLA327 (nn, ior, natom, sum, finxyz, mul, let)
      PARAMETER (numat=150,ntot=1000,NELTS=16)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /STBL3/ STTEXT(21)
      COMMON /orgin/ nor, orgadd(3, 8), ntext, icoord
      common /pol/ npol, xpol(3, ntot), xp(3, ntot), orga(3), smin,
     1 kkord(numat), nat(ntot)
      COMMON /res/ atom1, atom2, foccu, intxt, code, elt
      DIMENSION finxyz(3, numat), mul(numat), let(numat)
      CHARACTER atom1(numat)*2, atom2(numat)*4, foccu(numat)*5, intxt*40
      CHARACTER STTEXT*17
      CHARACTER code(2)*1, elt(NELTS)*2
      IF (NTEXT .GT. 0) THEN
        CALL PLA269 (0)
        CALL PLA269 (3)
        IF (NN .EQ. 1) THEN
          WRITE (LU7, 99999) STTEXT(ntext), (orgadd(j, ior), j = 1, 3)
        ELSE IF (NN .EQ. 2) THEN
          WRITE (LU7, 99999) STTEXT(ntext), orga
        ENDIF
      ENDIF
      CALL PLA269 (3)
      WRITE (LU7, 99998)
      DO 10 I = 1, natom
        k = let(i)
        CALL PLA269 (1)
        WRITE (LU7, 99996) atom1(i), atom2(i),
     1    (finxyz(j, i), j = 1, 3), foccu(i), mul(i), CHAR(k + 96)
   10 CONTINUE
      CALL PLA269 (2)
      WRITE (LU7, 99997) sum
      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 (A2, 1x, A4, 3F10.5, 5x, A5, 5x, I3, '(', A1, ')')
      END
      SUBROUTINE PLA328 (NIG)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /STBL1/ STAA, STBB, STCSH
      COMMON /STBL2/ SPECIA(3, 107)
      COMMON /posi/ x(3, 192), dist(192), kount
      COMMON /sp/ nspec, nw, ns(26), is(27), mult(15), nset(8), kset,
     1            km, ipos
      CHARACTER STAA(107)*11, STBB(39)*15, STCSH(17)*14
      DIMENSION pos(3)
      IATOM = 1
      DO 70 npos = 1, kount
        np = npos
        DO 10 j = 1, 3
          pos(j) = x(j, np)
   10   CONTINUE
        DO 60 i = 1, nspec
          k = ns(i)
          IF (k .GE. 0) THEN
            DO 20 j = 1, 3
              IF (SPECIA(j, k) .GE. 0.0) THEN
                IF (abs(pos(j) - SPECIA(j, k)) .GT. 0.0001) GOTO 60
              ENDIF
   20       CONTINUE
            IF (kset .NE. 0) THEN
              IF (is(i) .GE. kset) GOTO 60
            ENDIF
          ELSE
            ifound = 0
            CALL PLA329 (pos, ifound, k)
            IF (ifound .EQ. 0) GOTO 60
            IF (kset .NE. 0) THEN
              IF (is(i) .GE. kset) GOTO 60
            ENDIF
          ENDIF
          kset  = is(i)
          iatom = np
          ipos  = i
   60   CONTINUE
   70 CONTINUE
      IF (kset .EQ. 0) THEN
        km   = mult(nw)
        ipos = nspec + 1
        IF (nig .EQ. 0) THEN
          CALL PLA269 (1)
          WRITE (LU7, 99996) km, CHAR(96 + IPOS)
        ENDIF
        RETURN
      ENDIF
      km = mult(kset)
      IF (iatom .GT. 1) THEN
        DO 80 j = 1, 3
          x(j, 1) = x(j, iatom)
  80    CONTINUE
      ENDIF
      k = ns(ipos)
      IF (NIG .EQ. 0) THEN
        CALL PLA269 (1)
        IF (K .GT. 0) THEN
          WRITE (LU7, 99999) STAA(k), km, CHAR(96 + IPOS)
        ELSE
          k = -k
          WRITE (LU7, 99999) STBB(k), km, CHAR(96 + IPOS)
        ENDIF
      ENDIF
      ii = 0
      nn = is(ipos)
      DO 90 i = 1, nspec
        IF (nn .EQ. is(i)) THEN
          ii = ii + 1
          nset(ii) = ns(i)
        ENDIF
   90 CONTINUE
      kset = ii
      IF (ii .GT. 0) THEN
        CALL PLA269 (1 + ii)
        WRITE (LU7, 99997)
        DO 100 j = 1, ii
          k = nset(j)
          IF (k .GT. 0) THEN
            WRITE (LU7, 99998) STAA(k)
          ELSE
            k = - k
            WRITE (LU7, 99998) STBB(k)
          ENDIF
  100   CONTINUE
      ENDIF
      RETURN
99999 FORMAT ('Special Position : ', A15, ' multiplicity ', I3,
     1'  Wyckoff letter:', A2)
99998 FORMAT (A15)
99997 FORMAT ('All Possible Special Positions for this Atom :')
99996 FORMAT ('General Position ', I3, A1)
      END
      SUBROUTINE PLA329 (pos, ifound, k)
      DIMENSION pos(3)
      DATA EPS /0.0001/, EPS1 /0.9999/
      SMALL = 0.0005
      K     = - K
      IF (K .LT. 7 .OR. K .EQ. 35 .OR. K .EQ. 36) THEN
        IF (ABS(POS(1) - POS(2)) .LE. SMALL) THEN
          IF (K .EQ. 36) GOTO 10
          IF (K .EQ. 35) THEN
            IF (ABS(POS(2) - POS(3)) .LT. SMALL) GOTO 10
          ELSE IF (K .EQ. 1) THEN
            IF (ABS(POS(3))          .LT. SMALL) GOTO 10
            IF (ABS(POS(3) - 1.0)    .LT. SMALL) GOTO 10
          ELSE IF (K .EQ. 2) THEN
            IF (ABS(POS(3) - 0.5)    .LT. SMALL) GOTO 10
          ELSE IF (K .EQ. 3) THEN
            IF (ABS(POS(3) - 0.25)   .LT. SMALL) GOTO 10
          ELSE IF (K .EQ. 4) THEN
            IF (ABS(POS(3) - 0.75)   .LT. SMALL) GOTO 10
          ELSE IF (K .EQ. 5) THEN
            IF (ABS(POS(3) - 0.375)  .LT. SMALL) GOTO 10
          ELSE IF (K .EQ. 6) THEN
            IF (ABS(POS(3) - 0.625)  .LT. SMALL) GOTO 10
          ENDIF
        ENDIF
      ELSE IF ((K .GT. 6 .AND. K .LT. 14) .OR. K .EQ. 37) THEN
        A = 1.0 - POS(2)
        IF (A .LT. EPS) A = A + 1.0
        IF (ABS(A - POS(1)) .LE. SMALL) THEN
          IF (K .EQ. 37) GO TO 10
          IF (K .EQ. 7) THEN
            IF (ABS(POS(3))          .LT. SMALL) GOTO 10
            IF (ABS(POS(3) - 1.0)    .LT. SMALL) GOTO 10
          ELSE IF (K .EQ. 8) THEN
            IF (ABS(POS(3) - 0.5)    .LT. SMALL) GOTO 10
          ELSE IF (K .EQ. 9) THEN
            IF (ABS(POS(3) - 0.25)   .LT. SMALL) GOTO 10
          ELSE IF (K .EQ. 10) THEN
            IF (ABS(POS(3) - 0.3333) .LT. SMALL) GOTO 10
          ELSE IF (K .EQ. 11) THEN
            IF (ABS(POS(3) - 0.6667) .LT. SMALL) GOTO 10
          ELSE IF (K .EQ. 12) THEN
            IF (ABS(POS(3) - 0.1667) .LT. SMALL) GOTO 10
          ELSE IF (K .EQ. 13) THEN
            IF (ABS(POS(3) - 0.8333) .LT. SMALL) GOTO 10
          ENDIF
        ENDIF
      ELSE IF (K .GT. 23 .AND. K .LT. 27) THEN
        IF (ABS(POS(2) - POS(3)) .LE. SMALL) THEN
          IF (K .EQ. 24) THEN
            IF (ABS(POS(1))          .LT. SMALL) GOTO 10
          ELSE IF (K .EQ. 25) THEN
            IF (ABS(POS(1) - 0.5)    .LT. SMALL) GOTO 10
          ELSE IF (K .EQ. 26) THEN
            IF (ABS(POS(1) - 0.25)   .LT. SMALL) GOTO 10
          ENDIF
        ENDIF
      ELSE IF (K .EQ. 27 .OR. K .EQ. 28) THEN
        A = 1.0 - POS(2)
        IF (A .LT. EPS) A = A + 1.0
        IF (ABS(A - POS(3)) .LE. SMALL) THEN
          IF (K .EQ. 27) THEN
            IF (ABS(POS(1))          .LT. SMALL) GOTO 10
          ELSE IF (K .EQ. 28) THEN
            IF (ABS(POS(1) - 0.25)   .LT. SMALL) GOTO 10
          ENDIF
        ENDIF
      ELSE IF ((K .GT. 13 .AND. K .LT. 17) .OR. K .EQ. 38) THEN
        A = POS(1) + 0.5
        IF (A .GT. EPS1) A = A - 1.0
        IF (ABS(A - POS(2)) .LE. SMALL) THEN
          IF (K .EQ. 38) GOTO 10
          IF (K .EQ. 14) THEN
            IF (ABS(POS(3) - 0.25)   .LT. SMALL) GOTO 10
          ELSE IF (K .EQ. 15) THEN
            IF (ABS(POS(3) - 0.5)    .LT. SMALL) GOTO 10
          ELSE IF (K .EQ. 16) THEN
            IF (ABS(POS(3))          .LT. SMALL) GOTO 10
            IF (ABS(POS(3) - 1.0)    .LT. SMALL) GOTO 10
          ENDIF
        ENDIF
      ELSE IF (K .EQ. 17) THEN
        A = 0.5 - POS(1)
        IF (A .LT. EPS) A = A + 1.0
        IF (ABS(A - POS(2)) .LT. SMALL .AND.
     1    ABS(POS(3) - 0.25) .LT.  SMALL) GOTO 10
      ELSE IF (K .EQ. 18 .OR. K .EQ. 19) THEN
        A = POS(1) + 0.25
        IF (A .GT. EPS1) A = A - 1.0
        IF (ABS(A - POS(2)) .LE. SMALL) THEN
          IF (K .EQ. 18) THEN
            IF (ABS(POS(3) - 0.125) .LT. SMALL) GOTO 10
          ELSE IF (K .EQ. 19) THEN
            IF (ABS(POS(3) - 0.875) .LT. SMALL) GOTO 10
          ENDIF
        ENDIF
      ELSE IF ((K .GT. 19 .AND. K .LT. 24) .OR. K .EQ. 39) THEN
        A = POS(1) + POS(1)
        IF (A .GT. EPS1) A = A - 1.0
        IF (ABS(A - POS(2)) .LE. SMALL) THEN
          IF (K .EQ. 39) GO TO 10
          IF (K .EQ. 20) THEN
            IF (ABS(POS(3))          .LT. SMALL) GOTO 10
            IF (ABS(POS(3) - 1.0)    .LT. SMALL) GOTO 10
          ELSE IF (K .EQ. 21) THEN
            IF (ABS(POS(3) - 0.5)    .LT. SMALL) GOTO 10
          ELSE IF (K .EQ. 22) THEN
            IF (ABS(POS(3) - 0.25)   .LT. SMALL) GOTO 10
          ELSE IF (K .EQ. 23) THEN
            IF (ABS(POS(3) - 0.75)   .LT. SMALL) GOTO 10
          ENDIF
        ENDIF
      ELSE IF (K .EQ. 29 .OR. K .EQ. 30) THEN
        IF (ABS(POS(1) - 0.25) .LE. SMALL) THEN
          IF (K .EQ. 30) THEN
            A = 0.5 - POS(2)
            IF (A .LT. EPS) A = A + 1.0
            IF (ABS(A - POS(3)) .LT. SMALL) GOTO 10
          ELSE IF (K .EQ. 29) THEN
            A = 0.5 + POS(2)
            IF (A .GT. EPS1) A = A - 1.0
            IF (ABS(A - POS(3)) .LT. SMALL) GOTO 10
          ENDIF
        ENDIF
      ELSE IF (K .EQ. 31 .OR. K .EQ. 32) THEN
        IF (ABS(POS(1) - 0.5) .LT. SMALL) THEN
          IF (K .EQ. 32) THEN
            A = 1.0 - POS(2)
            IF (A .LT. EPS) A = A + 1.0
            IF (ABS(POS(3) - A) .LT. SMALL) GOTO 10
          ELSE IF (K .EQ. 31) THEN
            A = 0.5 + POS(2)
            IF (A .GT. EPS1) A = A - 1.0
            IF (ABS(POS(3) - A) .LT. SMALL) GOTO 10
          ENDIF
        ENDIF
      ELSE IF (K .EQ. 33 .OR. K .EQ. 34) THEN
        IF (ABS(POS(1) - 0.125) .LT. SMALL) THEN
          IF (K .EQ. 34) THEN
            A = 0.25 - POS(2)
            IF (A .LT. EPS) A = A + 1.0
            IF (ABS(POS(3) - A) .LT. SMALL) GOTO 10
          ELSE IF (K .EQ. 33) THEN
            A = 0.25 + POS(2)
            IF (A .GT. EPS1) A = A - 1.0
            IF (ABS(POS(3) - A) .LT. SMALL) GOTO 10
          ENDIF
        ENDIF
      ENDIF
      RETURN
   10 IFOUND = 1
      RETURN
      END
      SUBROUTINE PLA330 (ia, np, *)
      PARAMETER (numat=150)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /STBL2/ SPECIA(3, 107)
      COMMON /posi/ x(3, 192), dist(192), kount
      COMMON /sp/ nspec, nw, ns(26), is(27), mult(15), nset(8), kset,
     1   mu, kord
      common /trip/ dmin, min, korder(192), iflag, xmi(3, numat),
     1 mul(numat), le(numat), nrset(numat), nnset(8, numat)
      COMMON /xpolar/ ipolar, kpol(3), lowlet
      DIMENSION mulset(8), pos(3)
      kord  = 0
      np    = 0
      e1    = 0.0001
      e2    = 0.0001
      e3    = 0.0001
      iflag = 0
      meq   = 0
      DO 10 I = 1, kount
        korder(I) = nspec + 1
   10 CONTINUE
      kset = nrset(ia)
      IF (KSET .GT. 0) THEN
        DO 80 I = 1, KOUNT
          DO 70 M = 1, KSET
            k = nnset(m, ia)
            IF (k .GT. 0) THEN
              DO 20 j = 1, 3
                IF (SPECIA(j, k) .GE. 0) THEN
                  IF (abs(x(j, i) - SPECIA(j, k)) .GT. 0.001) GOTO 70
                ENDIF
   20         CONTINUE
              DO 30 j = 1, nspec
                IF (ns(j) .EQ. k) THEN
                  korder(i) = j
                  GOTO 80
                ENDIF
   30         CONTINUE
            ELSE
              DO 40 j = 1, 3
                pos(j) = x(j, i)
   40         CONTINUE
              IFOUND = 0
              CALL PLA329 (pos, ifound, k)
              if (ifound .EQ. 0) GOTO 70
              DO 50 j = 1, nspec
                kk = - k
                if (kk .EQ. ns(j)) THEN
                  korder(i) = j
                  GOTO 80
                ENDIF
   50         CONTINUE
            ENDIF
            GOTO 310
   70     CONTINUE
          dist(i) = 100.0
          CALL PLA269 (1)
          WRITE (LU7, 99989) i, (x(j, i), j = 1, 3)
   80   CONTINUE
      ENDIF
      IF (ipolar .EQ. 1) THEN
        klow = 27
        DO 90 j = 1, kount
          IF (korder(j) .LT. klow) klow = korder(j)
   90   CONTINUE
        IF (klow .ne. lowlet) THEN
          CALL PLA269 (1)
          WRITE (LU7, 99988) x(1, 1), x(2, 1), x(3, 3)
          dmin = 100.0
          RETURN
        ENDIF
      ENDIF
      CALL PLA269 (3)
      WRITE (LU7, 99998)
      WRITE (LU7, 99997)
      DO 130 i = 1, kount
        IF (dist(i) .LE. 99.0) THEN
          IF (ipolar .EQ. 1) THEN
            DO 100 j = 1, 3
              k = kpol(j)
              IF (k .NE. 0) THEN
                IF (x(k, i) .ne. 0.0) GOTO 110
              ENDIF
  100       CONTINUE
            GOTO 120
  110       dist(i) = 100.0
            CALL PLA269 (3)
            WRITE (LU7, 99996) i, (x(j, i), j = 1, 3)
            GOTO 130
          ENDIF
  120     SUM     = x(1, i)**2 + x(2, i)**2 + x(3, i)**2
          dist(i) = sqrt(sum)
          kk      = korder(i)
          k1      = is(kk)
          CALL PLA269 (1)
          WRITE (LU7, 99995) i, (x(j, i), j = 1, 3), dist(i), mult(k1),
     1      CHAR(96 + kk)
        ENDIF
  130 CONTINUE
      dmin = 100.0
      DO 140 i = 1, kount
        if (dist(i) .LT. dmin) THEN
          dmin = dist(i)
          min  = i
        ENDIF
  140 CONTINUE
      IF (dmin .GE. 99.99) THEN
        CALL PLA269 (1)
        WRITE (LU7, 99987)
        iflag = 1
        RETURN 1
      ENDIF
      kk = 1
      mulset(1) = min
      e1        = 0.0001
      e2        = 0.0001
      e3        = 0.0001
      DO 150 I = 1, KOUNT
        IF (i .NE. MIN) THEN
          IF (abs(dist(i) - dmin) .LE. e1) THEN
            kk = kk + 1
            IF (kk .GT. 8) THEN
              CALL PLA269 (1)
              WRITE (LU7, 99991)
              GOTO 260
            ENDIF
            mulset(kk) = i
          ENDIF
        ENDIF
  150 CONTINUE
      IF (kk .EQ. 1) GOTO 290
      mx   = mulset(1)
      xmin = x(1, min)
      DO 180 k = 2, kk
        i = mulset(k)
        IF (abs(x(1, i) - xmin) .GE. e1) THEN
          IF (x(1, i) - xmin) 160, 170, 180
  160     xmin = x(1, i)
          meq  = 0
          mx   = i
          GOTO 180
        ENDIF
  170   meq = 1
        mx  = i
  180 CONTINUE
      min = mx
      IF (meq .NE. 0) THEN
        ymin = x(2, mx)
        meq  = 0
        my   = mx
        DO 210 k = 1, kk
          I = mulset(k)
          IF (I .NE. mx) THEN
            IF (abs(x(1, i) - x(1, mx)) .LE. e1) THEN
              IF (abs(x(2, i) - ymin) .GE. e2) THEN
                IF (x(2, i) - ymin) 190, 200, 210
  190           ymin = x(2, i)
                meq  = 0
                my   = i
                GOTO 210
              ENDIF
  200         IF (I .NE. my) THEN
                meq = 1
                my  = I
              ENDIF
            ENDIF
          ENDIF
  210   CONTINUE
        min = my
        IF (meq .NE. 0) THEN
          meq  = 0
          mz   = my
          zmin = x(3, my)
          DO 240 k = 1, kk
            i = mulset(k)
            IF (i .NE. my) THEN
              IF (abs(x(1, i) - x(1, mx)) .GT. e1 .or.
     1            abs(x(2, i) - x(2, my)) .GT. e2) GOTO 240
              IF (abs(x(3, i) - zmin) .LT. e3) GOTO 230
              IF (x(3, i) - zmin) 220, 230, 240
  220         zmin = x(3, i)
              meq = 0
              mz  = i
              GOTO 240
  230         IF (i .NE. mz) THEN
                meq = 1
                mz  = i
              ENDIF
            ENDIF
  240     CONTINUE
          IF (meq .EQ. 1) GOTO 280
          min = mz
        ENDIF
      ENDIF
  260 CALL PLA269 (2)
      WRITE (LU7, 99990) dmin
      DO 270 k = 1, kk
        i = mulset(k)
        CALL PLA269 (1)
        WRITE (LU7, 99993) i, (x(j, i), j = 1, 3)
  270 CONTINUE
      GOTO 290
  280 CALL PLA269 (1)
      WRITE (LU7, 99992)
  290 kord = korder(min)
      IF (kord .LE. nspec) np = ns(kord)
      IF (np .LT. 0) np = 107 - np
      k1 = is(kord)
      mu = mult(k1)
      CALL PLA269 (2)
      WRITE (LU7, 99999) min, (x(j, min), j = 1, 3), dmin, mu,
     1       CHAR(96 + KORD)
      DO 300 j = 1, 3
        xmi(j, ia) = x(j, min)
  300 CONTINUE
      mul(ia) = mu
      le(ia)  = kord
      RETURN
  310 WRITE (LU7, 99994) (x(j, i), j = 1, 3)
      iflag = 1
      RETURN 1
99999 FORMAT (/, 'Chosen :', I3, 5X, 3F9.5, 5X,
     1        F8.4, 8X, I3, '(', A1, ')')
99998 FORMAT (/, 'Permitted Positions :')
99997 FORMAT (22x, 'x', 8x, 'y', 8x, 'z', 12x, 'D')
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 PLA330: all coordinates equal: IMPOSSIBLE')
99991 FORMAT ('ERROR : more than 8 possibilities for equal "distance"',
     1 '(subroutine PLA330)')
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 PLA331 (natom, mkord, ii, *)
      PARAMETER (numat=150,ntot=1000)
c Called by main of S T I D Y
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /at/ iat, pos(3), ihex, fnum
      COMMON /STBL3/ STTEXT(21)
      COMMON /orgin/ nor, orgadd(3, 8), ntext, icoord
      COMMON /pol/ npol, xpol(3, ntot), xp(3, ntot), orga(3), smin,
     1 kkord(numat), nat(ntot)
      COMMON /posi/ x(3, 192), dist(192), kount
      COMMON /rot/ xrot(3, numat), nagain
      COMMON /sp/ n, nw, ns(26), is(27), mult(15), nset(8), kset,
     1  mu, kord
      COMMON /xpolar/ ipolar, kpol(3), lowlet
      CHARACTER STTEXT*17
      CALL GEN097 (NAT, 1, NTOT, 0)
      ismin = is(mkord)
      lowlet = 27
      DO 10 j = 1, 27
        IF (is(j) .EQ. ismin) THEN
          IF (j .LT. lowlet) lowlet = j
        ENDIF
   10 CONTINUE
      npol = 0
      DO 50 ia = 1, natom
        DO 20 j = 1, 3
          pos(j) = xrot(j, ia)
   20   CONTINUE
        CALL PLA326
        kor = kkord(ia)
        kk  = is(kor)
        IF (kk .EQ. ismin) THEN
          DO 40 j = 1, kount
            npol = npol + 1
            IF (npol .GT. ntot) GOTO 70
            nat(npol) = ia
            DO 30 k = 1, 3
              xp(k, npol) = x(k, j)
   30       CONTINUE
   40     CONTINUE
        ENDIF
   50 CONTINUE
      CALL PLA269 (4)
      WRITE (LU7, 99999)
      WRITE (LU7, 99998) (i, (xp(j, i), j = 1, 3), i = 1, npol)
      ik = ii - 1
      IF (ik .EQ. 0) ik = 1
      i1 = 3
      IF (ii .EQ. 2) i1 = 2
      DO 1 ior = 1, nor
        DO 60 j = 1, 3
          orga(j) = orgadd(j, ior)
   60   CONTINUE
        CALL PLA269 (4)
        WRITE (LU7, 99997) STTEXT(ntext), orga
        CALL PLA332 (i1, ik, natom, *80)
    1 CONTINUE
      RETURN
   70 WRITE (LU7, 99996)
   80 RETURN 1
99999 FORMAT (/, 'Coordinates of Atoms for Finding Origin : ', /,
     1        41('='))
99998 FORMAT (4(i4, 3f9.5, 3x))
99997 FORMAT (//, 'Origin Shift for Setting ', A, 3F9.5, /)
99996 FORMAT ('in PLA331 : DIMENSION of xpol is too small')
      END
      SUBROUTINE PLA332 (ii, ik, natom, *)
      PARAMETER (numat=150,ntot=1000,NELTS=16)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /at/ iat, pos(3), ihex, fnum
      COMMON /STBL3/ STTEXT(21)
      COMMON /matr/ ifmat, ifsh, ifplus, xmat(3, 3), plus(3), sh(3),
     1 nabc, nsh, nshtra, ifnig, xmsave(3, 3), shif(3), minsh
      COMMON /orgin/ nor, orgadd(3, 8), ntext, icoord
      COMMON /par/ gmin
      COMMON /pol/ npol, xpol(3, ntot), xp(3, ntot), orga(3), smin,
     1 kkord(numat), nat(ntot)
      COMMON /res/ atom1, atom2, foccu, intxt, code, elt
      COMMON /rot/ xrot(3, numat), nagain
      common/trip/ dmin, min, korder(192), iflag, xmin(3, numat),
     1 mul(numat), le(numat), nrset(numat), nnset(8, numat)
      COMMON /xpolar/ ipolar, kpol(3), lowlet
      DIMENSION xs(3, numat), xm(3, ntot), sadd(3, 50), zmin(3),
     1 org(3), nsp(numat), xx(3), nat2(ntot)
      CHARACTER atom1(numat)*2, atom2(numat)*4, foccu(numat)*5,
     1 STTEXT*17
      CHARACTER intxt*40, code*2, elt(NELTS)*2
      DO 10 i = 1, 3
        zmin(i) = orga(i)
        org(i)  = orga(i)
   10 CONTINUE
      DO 30 j = 1, ntot
        nat2(j) = 0
        DO 20 k = 1, 3
          xm(k, j) = 0.0
   20   CONTINUE
   30 CONTINUE
      REWIND LU60
      smin = 1000.0
      s  = 0.0
      ep = -0.000001
      DO 50 i = 1, npol
        DO 40 j = 1, 3
          xpol(j, i) = xp(j, i) - orga(j)
          IF (xpol(j, i) .LT. 0.0) xpol(j, i) = xpol(j, i) + 1.0
   40   CONTINUE
   50 CONTINUE
      knt = 0
      nr  = 0
      IF (IK .EQ. 1) THEN
        IF (ii .EQ. 2) THEN
          i1 = 2
        ELSE
          i1 = 3
        ENDIF
        i2 = 0
        i3 = 0
      ELSE IF (IK .EQ. 2) THEN
        i1 = 1
        i2 = 3
        i3 = 0
      ELSE IF (IK .EQ. 3) THEN
        i1 = 1
        i2 = 2
        i3 = 3
      ENDIF
      kpol(1) = i1
      kpol(2) = i2
      kpol(3) = i3
      kt      = 0
      DO 200 k = 1, npol
        CALL GEN074 (XX, 0.0, 1, 3)
        xx(i1) = xpol(i1, k)
        IF (i2 .GT. 0) xx(i2) = xpol(i2, k)
        IF (i3 .GT. 0) xx(i3) = xpol(i3, k)
        IF (k .NE. 1) THEN
          DO 80 kk = 1, kt
            DO 70 jj = 1, 3
              IF (xx(jj) .EQ. 0.0) THEN
                IF (jj .ne. i1 .AND. jj .ne. i2 .AND. j .ne. i3)
     1            GOTO 70
              ENDIF
              IF (abs(xx(jj) - xm(jj, kk)) .GT. 0.0001) GOTO 80
   70       CONTINUE
            IF (nat2(kk) .ne. nat(k)) GOTO 80
            GOTO 200
   80     CONTINUE
        ENDIF
        kt       = kt + 1
        nat2(kt) = nat(k)
        DO 90 j = 1, 3
          xm(j, kt) = xx(j)
   90   CONTINUE
        s = 0.0
        iia = nat(k)
        ipolar = 0
        DO 120 ia = 1, natom
          DO 100 j = 1, 3
            pos(j) = xrot(j, ia) - orga(j)
  100     CONTINUE
          DO 110 j = 1, 3
            IF (pos(j) .LT. ep) pos(j) = pos(j) + 1.0
  110     CONTINUE
          CALL PLA326
          CALL PLA330 (ia, np, *120)
          nsp(ia) = np
  120   CONTINUE
        DO 160 ia = 1, natom
          DO 130 j = 1, 3
            pos(j) = xrot(j, ia) - orga(j) - xx(j)
  130     CONTINUE
          DO 140 j = 1, 3
            IF (pos(j) .LT. ep) pos(j) = pos(j) + 1.0
  140     CONTINUE
          CALL PLA326
          ipolar = 0
          IF (ia .EQ. iia) ipolar = 1
          CALL PLA330 (ia, np, *150)
  150     s = s + dmin
  160   CONTINUE
        IF (s .GT. 99) THEN
          CALL PLA269 (1)
          WRITE (LU7, 99998) orga, xx
          GOTO 200
        ELSE
          CALL PLA269 (3)
          WRITE (LU7, 99999) orga, xx, s
        ENDIF
        WRITE (LU60) xx, s
        knt = knt + 1
        IF (s .LT. smin) THEN
          smin = s
          nr = knt
          DO 170 j = 1, 3
            zz = xx(j) + orga(j)
            IF (zz .GT. 0.99999) zz = zz - 1.0
            zmin(j) = zz
  170     CONTINUE
          DO 190 ia = 1, natom
            DO 180 j = 1, 3
              xs(j, ia) = xmin(j, ia)
  180       CONTINUE
  190     CONTINUE
        ENDIF
  200 CONTINUE
      IF (smin .GT. 99) THEN
        WRITE (LU7, 99997)  orga, xx
        RETURN
      ENDIF
      DO 210 j = 1, 3
        orga(j) = zmin(j)
  210 CONTINUE
      IF (ifsh .GT. 0 .or. ifplus .GT. 0) THEN
        DO 220 j = 1, 3
          orga(j) = orga(j) + plus(j)
  220   CONTINUE
      ENDIF
      WRITE (LU61, err = 330) smin, STTEXT(ntext), orga
      DO 230 ia = 1,natom
        WRITE (LU61, err = 330) nsp(ia), (xs(j, ia), j = 1, 3),
     1     mul(ia), le(ia), foccu(ia)
  230 CONTINUE
      CALL PLA327 (2, ior, natom, smin, xs, mul, le)
      IF (smin .LT. gmin) gmin = smin
      kt1 = 0
      IF (knt .NE. 0) THEN
        ss = 1.0025 * smin
        REWIND LU60
        kt = 0
        DO 250 i = 1, knt
          READ (LU60, end = 260) xx, s
          kt = kt + 1
          IF (kt .NE. nr) THEN
            IF (s .LT. ss) THEN
              kt1 = kt1 + 1
              DO 240 j = 1, 3
                zz = xx(j) + org(j)
                IF (zz .GT. 0.99999) zz = zz - 1.0
                sadd(j, kt1) = zz
  240         CONTINUE
            ENDIF
          ENDIF
  250   CONTINUE
      ENDIF
  260 CALL PLA269 (4)
      WRITE (LU7, 99996) STTEXT(ntext), smin, zmin
      IF (kt1 .GT. 0) THEN
        WRITE (LU7, 99995)
        WRITE (LU7, 99994) ((sadd(i, j), i = 1, 3), j = 1, kt1)
        DO 320 i = 1, kt1
          s = 0.0
          DO 290 ia = 1, natom
            DO 270 j = 1, 3
              pos(j) = xrot(j, ia) - sadd(j, i)
              IF (pos(j) .LT. ep) pos(j) = pos(j) + 1.0
  270       CONTINUE
            CALL PLA326
            ipolar = 0
            CALL PLA330 (ia, np, *280)
  280       s = s + dmin
  290     CONTINUE
          DO 300 j = 1, 3
            orga(j) = sadd(j, i)
  300     CONTINUE
          WRITE (LU61, err = 330) s, STTEXT(ntext), orga
          DO 310 ia = 1, natom
            WRITE (LU61, err = 330) nsp(ia), (xmin(j, ia), j = 1, 3),
     1             mul(ia), le(ia), foccu(ia)
  310     CONTINUE
          CALL PLA327 (2, ior, natom, smin, xmin, mul, le)
  320   CONTINUE
      ENDIF
      IF (NR .EQ. 0) WRITE (LU7, 99993)
      RETURN
  330 WRITE (LU7, 99992)
      RETURN 1
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 PLA332')
99992 FORMAT (//, 'ERROR  in PLA332 while writing on unit 10')
      END
      SUBROUTINE PLA333 (I)
      PARAMETER (numat=150)
      COMMON /ch/ xa(3, numat)
      COMMON /matr/ ifmat, ifsh, ifplus, xmat(3, 3), plus(3), sh(3),
     1 nabc, nsh, nshtra, ifnig, xmsave(3, 3), shif(3), minsh
      COMMON /rot/ xrot(3, numat), natom
      DIMENSION pl(3)
      DO 20 j = 1, 3
        pl(j) = 2 * plus(j)
   10   IF (pl(j) .GT. 0.99999) THEN
          pl(j) = pl(j) - 1.0
          GOTO 10
        ENDIF
   20 CONTINUE
      IF (I .GT. 17) THEN
        DO 30 j = 1, 3
          shif(j) = sh(j)
   30   CONTINUE
      ENDIF
      IF (I .EQ. 1 .OR. I .GT. 17) THEN
        DO 50 ia = 1, natom
          DO 40 j = 1, 3
            xrot(j, ia) = xa(j, ia)
   40     CONTINUE
   50   CONTINUE
      ELSE IF (I .EQ. 2) THEN
        DO 60 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)
   60   CONTINUE
      ELSE IF (I .EQ. 3) THEN
        DO 70 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)
   70   CONTINUE
      ELSE IF (I .EQ. 4) THEN
        shif(2) = 1.0 - sh(2)
        shif(3) = 1.0 - sh(3)
        DO 80 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)
   80   CONTINUE
      ELSE IF (I .EQ. 5) THEN
        shif(1) = sh(2)
        shif(2) = sh(1)
        shif(3) = 1.0 - sh(3)
        DO 90 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)
   90   CONTINUE
      ELSE IF (I .EQ. 6) THEN
        DO 100 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)
  100   CONTINUE
      ELSE IF (I .EQ. 7) THEN
        DO 110 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)
  110   CONTINUE
      ELSE IF (I .EQ. 8) THEN
        DO 120 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)
  120   CONTINUE
      ELSE IF (I .EQ. 9) THEN
        DO 130 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)
  130   CONTINUE
      ELSE IF (I .EQ. 10) THEN
        DO 150 ia = 1, natom
          DO 140 j = 1, 3
            xrot(j, ia) = 0.25 - xa(j, ia) + pl(j)
  140     CONTINUE
  150   CONTINUE
      ELSE IF (I .EQ. 11) THEN
        DO 170 ia = 1, natom
          DO 160 j = 1, 3
            xrot(j, ia) = 1.0 - xa(j, ia) + pl(j)
  160     CONTINUE
  170   CONTINUE
      ELSE IF (I .EQ. 12) THEN
        DO 190 ia = 1, natom
          DO 180 j = 1, 3, 2
            xrot(j, ia) = xa(j, ia)
  180     CONTINUE
          xrot(2, ia) = 1.0 - xa(2, ia) + pl(2)
  190   CONTINUE
      ELSE IF (I .EQ. 13) THEN
        DO 210 ia = 1, natom
          DO 200 j = 1, 2
            xrot(j, ia) = xa(j, ia)
  200     CONTINUE
          xrot(3, ia) = 1.0 - xa(3, ia) + pl(3)
  210   CONTINUE
      ELSE IF (I .EQ. 14) THEN
        DO 220 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)
  220   CONTINUE
      ELSE IF (I .EQ. 15) THEN
        DO 230 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)
  230   CONTINUE
      ELSE IF (I .EQ. 16) THEN
        DO 240 ia = 1, natom
          xrot(1, ia) = xa(2, ia)
          xrot(2, ia) = xa(1, ia)
          xrot(3, ia) = xa(3, ia)
  240   CONTINUE
      ELSE IF (I .EQ. 17) THEN
        DO 250 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)
  250   CONTINUE
      ENDIF
      RETURN
      END
      SUBROUTINE PLA334 (KEER, NN, II)
      PARAMETER (numat=150)
c called by MAIN of STIDY
c rotation/inversion of coordinate system
      COMMON /rot/ xrot(3, numat), natom
      COMMON /stng/ irot, ntio
      DIMENSION iar(4), nigar1(4), nigar2(4)
      data iar /6, 5, 3, 1/,
     1  nigar1 /19, 18, 5, 1/,
     2  nigar2 /21, 20, 15, 11/
      IF (nn .EQ. 0) THEN
        IF (irot .LT. 8) THEN
          IF (keer .EQ. 2) THEN
            II = 1
          ELSE
            II = irot
          ENDIF
        ELSE IF (irot .EQ. 18 .or. irot .EQ. 19) THEN
          II = irot
          IF (KEER .EQ. 2) ii = 1
        ELSE IF (irot .EQ. 20) THEN
          II = nigar1(keer)
        ELSE
         II = iar(keer)
        ENDIF
      ELSE
        IF (ntio .EQ. 1) THEN
          IF (irot .LT. 8) THEN
            IF (keer .EQ. 2) THEN
              II = 11
            ELSE
              II = 10 + irot
            ENDIF
          ELSE IF (irot .EQ. 18 .or. irot .EQ. 19) THEN
            II = irot + 2
            IF (keer .EQ. 2) II = 11
          ELSE IF (irot .EQ. 20) THEN
            II = nigar2(keer)
          ELSE
            II = iar(keer) + 10
          ENDIF
        ELSE IF (ntio .EQ. 2) THEN
          II = 8
          IF (keer .EQ. 2) II = 9
        ELSE IF (ntio .EQ. 3) THEN
          II = 10
          IF (keer .EQ. 2) II = 17
        ELSE IF (ntio .EQ. 4) THEN
          II = 14
        ENDIF
      ENDIF
      CALL PLA333 (II)
      DO 20 j = 1, natom
        DO 10 i = 1, 3
          IF (xrot(i, j) .GT. 0.99999) xrot(i, j) = xrot(i, j) - 1.0
          IF (xrot(i, j) .LT.     0.0) xrot(i, j) = xrot(i, j) + 1.0
   10   CONTINUE
   20 CONTINUE
      RETURN
      END
      SUBROUTINE PLA335 (natom, ii, ig, k, nr, newnr)
      PARAMETER (numat=150, nset=120)
      COMMON /ord/ x(3, numat), mul(numat), let(numat),
     1 horsum(numat, nset), sum(3, nset), sxy(nset), sxz(nset),
     2 syz(nset)
      DIMENSION nr(nset), newnr(nset), new(nset)
      CALL GEN097 (NEW,   1, NSET, 0)
      CALL GEN097 (NEWNR, 1, NSET, 0)
      kk = 1
      IF (II .NE. 2) THEN
        DO 70 I = 1, 3
          S = 1000000.0
          DO 30 j = 1, ig
            m = nr(j)
            IF (i .GT. 1) THEN
              DO 10 l = 1, kk
                IF (m .EQ. newnr(l)) GOTO 20
   10         CONTINUE
              GOTO 30
            ENDIF
   20       IF (s .GT. sum(i, m)) s = sum(i, m)
   30     CONTINUE
          k = 0
          DO 60 j = 1, ig
            l = nr(j)
            IF (I .GT. 1) THEN
              DO 40 m = 1, kk
                IF (l .EQ. newnr(m)) GOTO 50
   40         CONTINUE
              GOTO 60
            ENDIF
   50       IF (abs(sum(i, l) - s) .LT. 0.0001) THEN
              k = k + 1
              newnr(k) = l
            ENDIF
   60     CONTINUE
          IF (k .LE. 1) RETURN
          kk = k
   70   CONTINUE
      ELSE
        DO 140 i = 1, natom
          s = 1000000.0
          DO 100 j = 1, ig
            m = nr(j)
            IF (I .GT. 1) THEN
              DO 80 l = 1, kk
                IF (m .EQ. newnr(l)) GOTO 90
   80         CONTINUE
              GOTO 100
            ENDIF
   90       IF (s .GT. horsum(i, j)) s = horsum(i, j)
  100     CONTINUE
          k = 0
          DO 130 j = 1, ig
            l = nr(j)
            IF (i .GT. 1) THEN
              DO 110 m = 1, kk
                IF (j .EQ. new(m)) GOTO 120
  110         CONTINUE
              GOTO 130
            ENDIF
  120       IF (abs(horsum(i, j) - s) .LT. 0.0001) THEN
              k        = k + 1
              new(k)   = j
              newnr(k) = nr(j)
            ENDIF
  130     CONTINUE
          IF (k .LE. 1) RETURN
          kk = k
  140   CONTINUE
      ENDIF
      RETURN
      END
      SUBROUTINE PLA336 (ngr, ca, cb, cc, cal, cbe, cga)
      COMMON /cel/ a, b, c, al, be, ga, alf, bet, gam, cosa, cosb, cosg
      CHARACTER*8 ca, cb, cc
      CHARACTER*9 cal, cbe, cga
      WRITE (ca,  99999) a
      WRITE (cb,  99999) b
      WRITE (cc,  99999) c
      WRITE (cal, 99998) al
      WRITE (cbe, 99998) be
      WRITE (cga, 99998) ga
      IF (ngr .GE. 3 .AND. ngr .LE. 15) THEN
        cal = ' '
        cga = ' '
      ELSE IF (ngr .GE. 16 .AND. ngr .LE. 74) THEN
        cal = ' '
        cbe = ' '
        cga = ' '
      ELSE IF (ngr .GE. 75 .AND. ngr .LE. 142) THEN
        cb = ' '
        cal = ' '
        cbe = ' '
        cga = ' '
      ELSE IF (ngr .GE. 143 .AND. ngr .LE. 194) THEN
        cb = ' '
        cal = ' '
        cbe = ' '
        cga = '  120.   '
      ELSE IF (ngr .GE. 195) THEN
        cb = ' '
        cc = ' '
        cal = ' '
        cbe = ' '
        cga = ' '
      ENDIF
      RETURN
99999 FORMAT (F8.4)
99998 FORMAT (F9.3)
      END
      SUBROUTINE PLA337 (ipears, pmin, cpears, nelt, pear, cpear)
      PARAMETER (NELTS=16)
      CHARACTER cpears*10, cpear(NELTS)*7, aux1*6, aux*7
      DIMENSION pear(NELTS)
      cpears = ' '
      aux    = ' '
      aux1   = ' '
      WRITE (aux1, 99997) ipears
      k = 0
      DO 10 j = 1, 6
        IF (aux1(j:j) .NE. ' ') THEN
          k           = k + 1
          cpears(k:k) = aux1(j:j)
        ENDIF
   10 CONTINUE
      IF (pmin .NE. 0.0) THEN
        k           = k + 1
        cpears(k:k) = '-'
        WRITE (aux1, 99998) pmin
        DO 30 j = 1, 6
          IF (aux1(j:j) .NE. ' ') THEN
            k           = k + 1
            cpears(k:k) = aux1(j:j)
          ENDIF
   30   CONTINUE
      ENDIF
      DO 90 i = 1, nelt
        k        = 0
        cpear(i) = ' '
        WRITE (aux, 99999) pear(i)
        DO 40 j = 1, 7
          IF (aux(j:j) .NE. ' ') THEN
            IF (aux(j:j) .ne. '.') THEN
              k             = k + 1
              cpear(i)(k:k) = aux(j:j)
            ELSE
              k             = k + 1
              cpear(i)(k:k) = '.'
              GOTO 50
            ENDIF
          ENDIF
   40   CONTINUE
   50   DO 60 l = j + 1, 7
          IF (aux(l:l) .ne. '0') GOTO 70
   60   CONTINUE
        GOTO 90
   70   DO 80 l = j + 1, 7
          IF (aux(l:l) .EQ. ' ') GOTO 90
          k = k + 1
          cpear(i)(k:k) = aux(l:l)
   80   CONTINUE
   90 CONTINUE
      RETURN
99999 FORMAT (F7.3)
99998 FORMAT (F6.2)
99997 FORMAT (I6)
      END
      SUBROUTINE PLA338 (x1, x2, x3, nsp, coord)
      DIMENSION x(3), kspec(3, 146)
      CHARACTER*7 coord(3), koord(12)
      data koord/' 0     ',' 1/2   ',' 1/4   ',' 3/4   ',' 1/8   ',
     1          ' 3/8   ',' 5/8   ',' 7/8   ',' 1/3   ',' 2/3   ',
     2          ' 1/6   ',' 5/6   '/
      data kspec/
     1 3*2, 1,2,2, 2,1,2, 2,2,1, 2,1,1, 1,2,1, 1,1,2, 3*1, 3,3,2,
     2 3,3,1, 3,3,4, 3*3, 3,4,3, 4,3,3, 2,2,3, 1,2,3, 2,1,3, 1,1,3,
     3 3,3,2, 4,3,2, 4,3,1, 3,3,1, 3,4,1, 3,1,1, 3,1,2, 1,3,3, 1,3,4,
     4 3*5, 3,1,3, 5,5,7, 1,2,4, 3,4,2, 1,3,5, 1,3,7, 3,4,4, 4,3,4,
     5 1,4,5, 1,3,6, 9,10,1, 9,10,2, 10,9,1, 10,9,2, 9,10,3, 10,9,3,
     6 9,10,4, 3*4, 3*7, 3,2,1, 3*6, 3*8, 5,1,3, 7,1,3, 6,1,3, 8,1,3,
     7 1,4,3, 2,3,4, 8,5,5, 0,2,2, 0,2,1, 0,1,2, 0,1,1, 0,3,3, 0,1,3,
     8 0,3,4, 0,2,3, 0,3,2, 0,3,1, 0,5,5, 0,3,5, 0,4,3, 0,1,9, 0,1,12,
     9 0,1,10, 0,1,11, 2,0,2, 1,0,2, 2,0,1, 1,0,1, 2,0,3, 1,0,3, 3,0,3,
     * 3,0,1, 4,0,3, 3,0,2, 5,0,5, 2,2,0, 1,2,0, 2,1,0, 1,1,0, 3,3,0,
     a 1,3,0, 3,4,0, 3,2,0, 3,1,0, 5,5,0, 4,3,0, 9,10,0, 10,9,0, 0,0,2,
     b 0,0,1, 0,0,3, 0,2,0, 0,1,0, 0,3,0, 2,0,0, 1,0,0, 3,0,0,
     c 0,0,1, 0,0,2, 0,0,3, 0,0,4, 0,0,6, 0,0,7, 0,0,1, 0,0,2, 0,0,3,
     d 0,0,9, 0,0,10, 0,0,11, 0,0,12, 0,0,3, 0,0,2, 0,0,1, 0,0,3, 0,0,5,
     e 0,0,8, 0,0,1, 0,0,2, 0,0,3, 0,0,4, 1,0,0, 2,0,0, 3,0,0, 1,0,0,
     f 3,0,0, 3,0,0, 3,0,0, 2,0,0, 2,0,0, 5,0,0, 5,0,0, 15*0/
      x(1) = x1
      x(2) = x2
      x(3) = x3
      IF (nsp .GT. 0) THEN
        DO 10 i = 1, 3
          IF (kspec(i, nsp) .EQ. 0) THEN
            WRITE (coord(i), 99999) x(i)
          ELSE
            coord(i) = koord(kspec(i, nsp))
          ENDIF
   10   CONTINUE
      ELSE
        DO 20 i = 1, 3
          WRITE (coord(i), 99999) x(i)
          coord(i)(1:1) = ' '
   20   CONTINUE
      ENDIF
      RETURN
99999 FORMAT (F7.5)
      END
      SUBROUTINE PLA339 (natom, ig, ik, nelt, ax, text, o1, o2, o3,
     1                   nsp)
      PARAMETER (numat=150,nset=120,NELTS=16,ndif=30)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /STBL4/ ipol, r, ngr, iocfl, vol, nfl, volrat
      COMMON /bur/ nt, spgr
      COMMON /cel/ a, b, c, al, be, ga, alf, bet, gam, cosa, cosb, cosg
      COMMON /eltname/ finelt
      COMMON /num/ nel, newn, nr(ndif), maxnr(ndif)
      COMMON /ord/ x(3, numat), mul(numat), let(numat),
     1 horsum(numat, nset),sum(3, nset), sxy(nset), sxz(nset), syz(nset)
      COMMON /res/ atom1, atom2, foc, intxt, code, elt
      COMMON /sp/ nspec, ndummy(80)
      CHARACTER elt(NELTS)*2, atom1(numat)*2, atom2(numat)*4,
     1 foc(numat)*5
      CHARACTER*1 code(2), nt(16), wseq(108), spgr(10)
      CHARACTER newelt*9, aux*3, finelt(ndif)*2, ax*47, text*17,
     1 intxt*40
      CHARACTER coord(3)*7
      DIMENSION katom(numat), t(3, numat), ky(numat), kz(numat),
     1 nwyck(27), xx(3), nsp(numat), np(numat)
c offset for conversion number -> CHARACTER :
c ik is index in arrays sum,sxy,sxz,syz :
      kn     = 1
      IF (ig .LT. 0) kn = -ig
      nn     = 0
      eps    = 0.0001
      kounty = 0
      kountz = 0
      kty    = 0
      ktz    = 0
      nspos =  0
      CALL GEN097 (NR, 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)
      nel    = 0
      mx     = 1
      my     = 1
      mz     = 1
      maxord = nspec + 1
      DO 250 ii = 1, maxord
        k = maxord + 1 - ii
        kt = 0
        DO 20 i = 1, natom
          kk = let(i)
          IF (kk .EQ. k) THEN
            kt = kt + 1
            DO 10 j = 1, 3
              t(j, kt) = x(j, i)
   10       CONTINUE
            np(kt)    = nsp(i)
            nspos     = np(kt)
            katom(kt) = i
          ENDIF
   20   CONTINUE
        IF (kt .NE. 0) THEN
          kount = 0
   30     xmin  = 2.0
          meq   = 0
          DO 70 ix = 1, kt
            DO 40 j = 1, 3
              IF (t(j, ix) .GT. 9.0) GOTO 70
   40       CONTINUE
            IF (abs(t(1, ix) - xmin) .GE. eps) THEN
              IF (t(1, ix) - xmin) 50, 60, 70
   50         xmin = t(1,ix)
              mx   = ix
              meq  = 0
              GOTO 70
            ENDIF
   60       MEQ = 1
            MX  = ix
   70     CONTINUE
          igo = 1
          IF (meq .NE. 1) THEN
            l = katom(mx)
            CALL PLA340 (l)
            ipos = let(l)
            IF (ig .LE. 1) THEN
              xx(1) = t(1, mx)
              xx(2) = t(2, mx)
              xx(3) = t(3, mx)
              nspos = np(mx)
              ipr   = 1
            ELSE
              nn = nn + 1
              horsum(nn, ik) = t(1, mx) + t(2, mx) + t(3, mx)
              ipr = 0
            ENDIF
            kount    = kount + 1
            t(1, mx) = 10.0
            IF (kount .LT. kt) igo = 2
            GOTO 170
          ENDIF
          kty = 0
          DO 80 iy = 1, kt
            IF (abs(t(1, iy) - t(1, mx)) .LE. eps) THEN
              kty     = kty + 1
              ky(kty) = iy
            ENDIF
   80     CONTINUE
          kounty = 0
   90     ymin   = 2.0
          meq    = 0
          DO 120 j = 1, kty
            iy = ky(j)
            IF (abs(t(2, iy) - ymin) .GE. eps) THEN
              IF (t(2, iy) - ymin) 100, 110, 120
  100         ymin = t(2, iy)
              my   = iy
              meq  = 0
              GOTO 120
            ENDIF
  110       meq = 1
            my  = iy
  120     CONTINUE
          IF (meq .NE. 1) THEN
            l = katom(my)
            CALL PLA340 (l)
            ipos = let(l)
            IF (ig .LE. 1) THEN
              ipr   = 1
              xx(1) = t(1, my)
              xx(2) = t(2, my)
              xx(3) = t(3, my)
              nspos = np(my)
            ELSE
              ipr = 0
              nn  = nn + 1
              horsum(nn, ik) = t(1, my) + t(2, my) + t(3, my)
            ENDIF
            kount    = kount  + 1
            kounty   = kounty + 1
            t(2, my) = 10.0
            igo      = 1
            IF (kounty .LT. kty) THEN
              igo = 3
            ELSE IF (kount .LT. kt) THEN
              igo = 2
            ENDIF
            GOTO 170
          ENDIF
          ktz = 0
          DO 130 iz = 1, kt
            IF (abs(t(1, mx) - t(1, iz)) .LE. eps) THEN
              IF (abs(t(2, iz) - t(2, my)) .LE. eps) THEN
                ktz     = ktz + 1
                kz(ktz) = iz
              ENDIF
            ENDIF
  130     CONTINUE
          kountz = 0
  140     zmin   = 2.0
          meq    = 0
          DO 160 j = 1, ktz
            iz = kz(j)
            IF (abs(t(3, iz) - zmin) .GE. eps) THEN
              IF (t(3, iz) .LT. zmin) THEN
                zmin = t(3, iz)
                mz   = iz
                meq  = 0
              ENDIF
            ENDIF
  160     CONTINUE
          l = katom(mz)
          CALL PLA340 (l)
          ipos = let(l)
          IF (ig .LE. 1) THEN
            ipr   = 1
            xx(1) = t(1, mz)
            xx(2) = t(2, mz)
            xx(3) = t(3, mz)
            nspos = np(mz)
          ELSE
            ipr = 0
            nn  = nn + 1
            horsum(nn, ik) = t(1, mz) + t(2, mz) + t(3, mz)
          ENDIF
          kount    = kount + 1
          kounty   = kounty + 1
          kountz   = kountz + 1
          t(3, mz) = 10.0
          t(2, mz) = 10.0
          igo      = 1
          IF (kountz .LT. ktz) THEN
            igo = 4
          ELSE IF (kounty .LT. kty) THEN
            igo = 3
          ELSE IF (kount .LT. kt) THEN
            igo = 2
          ENDIF
  170     IF (ipr .EQ. 1) THEN
            newelt = ' '
            aux    = ' '
            nwyck(ipos) = nwyck(ipos) + 1
            IF (atom1(l)(1:1) .EQ. 'X') THEN
              newelt(1:2) = atom1(l)
              jj = 2
              IF (newelt(2:2) .EQ. ' ') jj = 1
              GOTO 210
            ENDIF
            DO 180 i = 1, nelt
              IF (atom1(l) .EQ. elt(i)) GOTO 190
  180       CONTINUE
c arrive here if error :
            WRITE (LU7, 99991) atom1(l), nelt
            newelt(1:2) = atom1(l)
            jj = 1
            GOTO 210
  190       k = 0
            DO 200 j = 1, i
              IF (elt(j)(1:1) .NE. 'X') k = k + 1
  200       CONTINUE
            k = k + 1
            newelt(k:k+1) = elt(i)
            jj = k + 1
            IF (newelt(k + 1:k + 1) .EQ. ' ') jj = k
  210       WRITE (aux, 99989) newn
            k = 0
            DO 220 j = 1, 3
              IF (aux(j:j) .NE. ' ') THEN
                k = k + 1
                aux(k:k) = aux(j:j)
              ENDIF
  220       CONTINUE
            IF (k .LT. 3) aux(k+1:3) = ' '
            newelt(jj + 1:jj + 3) = aux
            CALL PLA338 (xx(1), xx(2), xx(3), nspos, coord)
            DO 230 j = 1, 5
              IF (foc(l)(j:j) .EQ. '.') THEN
                READ (foc(l), 99988) ffoc
                foc(l) = ' '
                WRITE (foc(l)(1:4), 99987) ffoc
                GOTO 240
              ENDIF
  230       CONTINUE
  240       WRITE (LU63, 99993) newelt, mul(l), CHAR(96 + IPOS),
     1        coord, foc(l), atom2(l)
            WRITE (LU6,  99992) newelt, mul(l), CHAR(96 + IPOS),
     1        coord, foc(l), atom1(l), atom2(l)
          ENDIF
          GOTO (250, 30, 90, 140), igo
        ENDIF
  250 CONTINUE
      IF (ig .GT. 1) RETURN
      j = 0
      DO 270 i = 27, 1, -1
        IF (nwyck(i) .NE. 0) THEN
          j       = j + 1
          wseq(j) = CHAR(96 + I)
          n = nwyck(i)
          IF (n .GT. 1) THEN
            WRITE (aux, 99989) n
            DO 260 jj = 1, 3
              IF (aux(jj:jj) .NE. ' ') THEN
                j = j + 1
                wseq(j) = aux(jj:jj)
              ENDIF
  260       CONTINUE
          ENDIF
          j = j + 1
          wseq(j) = ' '
        ENDIF
  270 CONTINUE
      WRITE (LU6,  99990) wseq
      WRITE (LU63, 99994) ngr, SPGR, (WSEQ(k), k = 1, 47)
      DO 280 J = 48, 94
        IF (wseq(j) .ne. ' ') GOTO 290
  280 CONTINUE
      GOTO 300
  290 WRITE (LU63, 99995) (wseq(j), j = 48, 94)
  300 DO 310 J = 95, 108
        IF (wseq(j) .ne. ' ') GOTO 320
  310 CONTINUE
      GOTO 330
  320 WRITE (LU63, 99995) (wseq(j), j = 95, 108)
  330 CALL PLA343 (ax, text, o1, o2, o3)
c centre of gravity :
      cg = 0.0
      IF (vol .GT. 0.0001) THEN
        V = VOL**0.333333
        WRITE (LU6, 99996) VOL
        IF (VOLRAT .GT. 0.0) THEN
          CALL PLA269 (1)
          WRITE (LU7, 99997) volrat
        ENDIF
        cg = sqrt ((a * sum(1, kn))**2 + (b * sum(2, kn))**2
     1   + (c * sum(3, kn))**2 + 2.0 * (a * b * sxy(kn) * cosg
     2   + a * c * cosb * sxz(kn) + b * c * cosa*syz(kn))) / (natom * v)
      ENDIF
      WRITE (LU63, 99999) cg
      RETURN
99999 FORMAT ('CG', F8.4)
99997 FORMAT ('ratio volume Niggli-reduced cell/original cell : ',f5.2)
99996 FORMAT (/, 'Volume of Unit Cell : ', F10.4)
99995 FORMAT ('SPCGRP', 27x, 47A1)
99994 FORMAT('SPCGRP (', i3, ') ', 10A1, ' - ', 47A1)
99993 FORMAT ('ATOM', 3x, a9, 1x, i3, '(', A1, ')', 2x, 3(A7, 1X),
     1        A4, 16X, A4)
99992 FORMAT (A14, 1x, I3, '(', A1, ')', 2x, 3(A7, 1x), A4, 20x,
     1        A2, A4)
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)
      END
      SUBROUTINE PLA340 (l)
      PARAMETER (numat=150,NELTS=16,ndif=30)
      COMMON /num/ nel, newn, nr(ndif), maxnr(ndif)
      COMMON /res/ atom1, atom2, foccu, intxt, code, elt
      COMMON /eltname/ finelt
      CHARACTER finelt(ndif)*2, atom1(numat)*2, atom2(numat)*4,
     1 foccu(numat)*5, intxt*40, code*2, elt(NELTS)*2
      IF (nel .EQ. 0) THEN
        finelt(1) = atom1(l)
        nel   = 1
        newn  = 1
        nr(1) = 1
      ELSE
        i = 1
        DO 10 j = 1, nel
          i = j
          IF (atom1(l) .EQ. finelt(j)) THEN
            nr(i) = nr(i) + 1
            newn  = nr(i)
            GOTO 20
          ENDIF
   10   CONTINUE
        nel         = nel + 1
        newn        = 1
        finelt(nel) = atom1(l)
        nr(nel)     = 1
   20   IF (newn .GT. maxnr(i)) maxnr(i) = newn
      ENDIF
      RETURN
      END
      SUBROUTINE PLA341 (natom, ihex, ipears, pmin, pear, nelt)
      PARAMETER (numat=150,nset=120,NELTS=16)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /STBL4/ ipol, r, ngr, iocfl, vol, nfl, volrat
      COMMON /STBL1/ STAA, STBB, STCSH
      COMMON /bur/ nt, spgr
      COMMON /cel/ a, b, c, al, be, ga, alf, bet, gam, cosa, cosb, cosg
      COMMON /lab/ ax
      COMMON /matr/ ifmat, ifsh, ifplus, xmat(3, 3), plus(3), sh(3),
     1 nabc, nsh, nshtra, ifnig, xmsave(3, 3), shif(3), minsh
      COMMON /ord/ x(3, numat), mul(numat), let(numat),
     1 horsum(numat, nset), sum(3, nset), sxy(nset), sxz(nset),
     2 syz(nset)
      COMMON /par/ gmin
      COMMON /res/ atom1, atom2, foc, intxt, code, elt
      CHARACTER STAA(107)*11, STBB(39)*15, STCSH(17)*14
      CHARACTER elt(NELTS)*2,text*17,ax*47,spgr*10
      CHARACTER*1 nt(16), code(2), star
      CHARACTER atom1(numat)*2, atom2(numat)*4, foc(numat)*5
      CHARACTER cpears*10, cpear(NELTS)*7, data*73, intxt*40
      CHARACTER*8 ca, cb, cc
      CHARACTER*9 cal,cbe,cga
      DIMENSION org(3), nrfile(nset), orsave(3, nset), newnr(nset),
     1 kres(nset), pear(NELTS), keq(nset), sm(3), nsp(numat),
     2 nchoic(nset)
      IF (ifmat .EQ. 1) ax = '-a,-b,-c'
      kfl   = 0
      ig    = 0
      kount = 0
      nrres = 1
      CALL GEN074 (SXY, 0.0, 1, NSET)
      CALL GEN074 (SXZ, 0.0, 1, NSET)
      CALL GEN074 (SYZ, 0.0, 1, NSET)
      DO 20 i = 1, nset
c sums of all x-coordinates, y-coordinates and z-coordinates :
        DO 10 j = 1, 3
          sum(j, i) = 0.0
   10   CONTINUE
   20 CONTINUE
      DO 40 I = 1, numat
        DO 30 j = 1, nset
          horsum(i, j) = 0.0
   30   CONTINUE
   40 CONTINUE
      REWIND LU61
      CALL PLA269 (3)
      WRITE (LU7, 99987) gmin
      CALL PLA269 (0)
      CALL PLA269 (2)
      WRITE (LU7, 99986)
      IF (ipol .EQ. 0) THEN
        CALL PLA269 (4)
        WRITE (LU7, 99985)
      ENDIF
      CALL PLA337 (ipears, pmin, cpears, nelt, pear, cpear)
   50 READ (LU61, end = 100) gamma, text, org
      kount = kount + 1
      IF (gmin .GT. 0.0001) THEN
        fac = gamma / gmin
      ELSE
        IF (gamma .LT. 0.0001) THEN
          fac = 1.0
        ELSE
          fac = gamma
        ENDIF
      ENDIF
c
c count settings with gamma = gmin
      isum = 0
      IF (abs(fac - 1.0) .LE. 0.00001) THEN
        isum = 1
        ig   = ig + 1
        DO 60 i = 1, 3
          orsave(i, ig) = org(i)
   60   CONTINUE
        nrfile(ig) = kount
        kres(ig) = ig
      ENDIF
      IF (fac .GT. 1.00001 .AND. fac .LE. 1.0025) THEN
        kfl      = kfl + 1
        keq(kfl) = kount
      ENDIF
      CALL PLA269 (4)
      WRITE (LU7, 99984) text, org, gamma, fac
      WRITE (LU7, 99983) a, b, c, al, be, ga
      DO 80 i = 1, natom
        READ (LU61, end = 100) nsp(i), (x(j, i), j = 1, 3), mul(i),
     1        let(i), foc(i)
        IF (isum .EQ. 1) THEN
          DO 70 j = 1, 3
            sum(j, ig) = sum(j, ig) + x(j, i)
   70     CONTINUE
          sxy(ig) = sxy(ig) + x(1, i) * x(2, i)
          sxz(ig) = sxz(ig) + x(1, i) * x(3, i)
          syz(ig) = syz(ig) + x(2, i) * x(3, i)
        ENDIF
   80 CONTINUE
      DO 90 i = 1, natom
        k = let(i)
        CALL PLA269 (1)
        WRITE (LU7, 99993) atom1(i), atom2(i), (x(j, i), j = 1, 3),
     1         foc(i), mul(i), CHAR(96 + K)
   90 CONTINUE
      IF (isum .EQ. 1) THEN
        CALL PLA269 (3)
        WRITE (LU7, 99994) (sum(k, ig), k = 1, 3)
      ENDIF
      GOTO 50
  100 IF (kount .GT. nset) THEN
        CALL PLA269 (3)
        WRITE (LU7, 99992) kount, nset
      ENDIF
      CALL PLA269 (0)
      CALL PLA269 (3)
      WRITE (LU7, 99991) intxt
      WRITE (LU6, 99991) intxt
      IF (iocfl .EQ. 1) THEN
        CALL PLA269 (2)
        WRITE (LU7, 99990)
        WRITE (LU6, 99990)
      ENDIF
      IF (nfl .EQ. 1) THEN
        CALL PLA269 (4)
        WRITE (LU7, 99989)
      ENDIF
      IF (ifmat .EQ. 1) THEN
        WRITE (LU6,  99979)
        WRITE (LU63, 99978)
      ENDIF
      IF (ifsh .GT. 0) THEN
        WRITE (LU63, 99971)
        WRITE (LU6, 99972) sh
      ENDIF
      IF (ihex .EQ. 1) THEN
        WRITE (LU63, 99977)
        WRITE (LU6,  99976)
        CALL PLA269 (1)
        WRITE (LU7, 99995) a, a, c
      ENDIF
      star = ' '
      IF (ifmat .GT. 0 .or. ihex .EQ. 1 .or. ifnig .EQ. 2) THEN
        WRITE (LU6, 99980) ax
        star = '*'
      ENDIF
      IF (pmin .EQ. 0) THEN
        WRITE (LU6, 99970) code, ipears, (elt(i), pear(i), i = 1, nelt)
      ELSE
        WRITE (LU6, 99969) code, ipears, pmin, (elt(i),
     1                  pear(i), i = 1, nelt)
      ENDIF
      IF (nelt .LT. 5) THEN
        CALL GEN126 (ELT,   NELT + 1, 5)
        CALL GEN126 (CPEAR, NELT + 1, 5)
      ENDIF
      IF (ifmat .GT. 0 .or. ihex .EQ. 1 .or. ifnig .EQ. 2)
     1   WRITE (LU6, 99980) ax
      CALL PLA336 (ngr, ca, cb, cc, cal, cbe, cga)
      WRITE (LU63, 99988) ca, cb, cc, cal, cbe, cga, star
      WRITE (LU6, 99983) a, b, c, al, be, ga
      WRITE (LU63, 99968) code, cpears, (elt(i), cpear(i), i = 1, 5)
      IF (nelt .GT. 5)
     1  WRITE (LU63, 99967) (elt(i), cpear(i), i = 6, nelt)
      WRITE (LU6, 99966) spgr, ngr
      IF (ifplus .GT. 5) THEN
        CALL PLA269 (1)
        WRITE (LU7, 99996)
      ENDIF
      IF (IFPLUS .EQ. 1 .OR. IFPLUS .EQ. 3 .OR. IFPLUS .EQ. 5) THEN
        WRITE (LU6, 99974) STCSH(nshtra)
        IF (IFPLUS .EQ. 3) THEN
          WRITE (LU6, 99975) STCSH(nabc)
        ELSE IF (IFPLUS .EQ. 5) THEN
          WRITE (LU6, 99973) STCSH(nsh)
        ENDIF
      ELSE IF (IFPLUS .EQ. 2) THEN
        WRITE (LU6, 99975) STCSH(nabc)
      ELSE IF (IFPLUS .EQ. 4) THEN
        WRITE (LU6, 99973) STCSH(nsh)
      ENDIF
      IF (IG .GT. 0) THEN
        igg = ig
        IF (ig .GT. nset) igg = nset
        IF (igg .EQ. 1) THEN
          nrres    = 1
          kres(1)  = 1
          newnr(1) = ig
        ELSE
          CALL PLA335 (natom, 1, igg, nrres, kres, newnr)
          IF (nrres .EQ. 0) GOTO 270
        ENDIF
        REWIND LU61
        kount = 0
        ik    = 0
        DO 130 ii = 1, nrres
          k1 = newnr(ii)
          kk = nrfile(k1)
  110     READ (LU61, end = 140) gamma, text, org
          kount = kount + 1
          DO 120 i = 1, natom
            READ (LU61, end = 140) nsp(i), (x(j, i), j = 1, 3), mul(i),
     1                          let(i), foc(i)
  120     CONTINUE
          IF (kount .EQ. kk) THEN
            IF (nrres .EQ. 1) THEN
              CALL PLA269 (2)
              WRITE (LU7, 99998) text, (orsave(k, k1), k = 1, 3), gamma
              WRITE (LU63, 99997) gamma
            ENDIF
            ik = ik + 1
            CALL PLA339 (natom, nrres, ik, nelt, ax, text,
     1        orsave(1, k1), orsave(2, k1), orsave(3, k1), nsp)
            IF (nrres .EQ. 1) CALL PLA342
          ELSE
            GOTO 110
          ENDIF
  130   CONTINUE
  140   IF (nrres .NE. 1) THEN
          igg = ik
          CALL PLA335 (natom, 2, igg, nrres, newnr, nchoic)
          IF (nrres .EQ. 0) GOTO 270
          REWIND LU61
          k  = 0
          ik = 0
          DO 190 ii = 1, nrres
            k1    = nchoic(ii)
            kount = nrfile(k1)
  150       READ (LU61, end = 200) gamma, text, org
            k = k + 1
            DO 160 i = 1, natom
              READ (LU61, end = 200) nsp(i), (x(j, i), j = 1, 3),
     1              mul(i), let(i), foc(i)
  160       CONTINUE
            IF (k .EQ. kount) THEN
              IF (ik .GT. 0) THEN
                WRITE (LU63, 99981)
                WRITE (LU6,  99982)
              ENDIF
              WRITE (LU6,  99998) text, (orsave(l, k1), l = 1, 3),
     1          gamma
              WRITE (LU63, 99997) gamma
              ik = ik + 1
              CALL PLA339 (natom, -ii, ik, nelt, ax, text,
     1          orsave(1, k1), orsave(2, k1), orsave(3, k1), nsp)
              CALL PLA342
            ELSE
              GOTO 150
            ENDIF
  190     CONTINUE
        ENDIF
  200   IF (kfl .GT. 0) THEN
          REWIND LU61
          k  = 0
          kk = 0
          DO 250 I = 1, kfl
            WRITE (LU6,  99982)
            WRITE (LU63, 99981)
            kount = keq(i)
  210       READ (LU61, end = 260) gamma, text, org
            k = k + 1
            DO 220 j = 1, natom
              READ (LU61, end = 260) nsp(j), (x(l, j), l = 1, 3),
     1              mul(j), let(j), foc(j)
  220       CONTINUE
            IF (k .ne. kount) GOTO 210
            kk = kk + 1
            CALL GEN074 (SM, 0.0, 1, 3)
            DO 240 j = 1, natom
              DO 230 l = 1, 3
                sm(l) = sm(l) + x(l, j)
  230         CONTINUE
  240       CONTINUE
            WRITE (LU6,  99998) text, org, gamma
            WRITE (LU63, 99997) gamma
            CALL PLA339 (natom, 1, kk, nelt, ax, text, org(1), org(2),
     1        org(3), nsp)
            CALL PLA269 (3)
            WRITE (LU63, 99994) SM
            CALL PLA342
  250     CONTINUE
        ENDIF
  260   RETURN
  270   WRITE (LU7, 99999)
      ENDIF
      RETURN
99999 FORMAT ('ERROR in SUBROUTINE PLA335 ')
99998 FORMAT (/, 'Setting ', A, ' Origin (', 3f7.4, ')', 2X,
     1        'Gamma = ', f7.4, /)
99997 FORMAT ('gamma', f8.4)
99996 FORMAT ('SUBROUTINE PLA341 : 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 (A2, 1x, A4, 3x, 3F9.5, 5x, A5, 5x, I3, '(', A1, ')')
99992 FORMAT (/, 'WARNING ]]] ',/, I4, ' different settings;',
     1' only', I4, ' will be considered in printing results.')
99991 FORMAT ('Results for ', A40, /, 53('='), /)
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, 3A8, 1x, 3A9, 7x, A1)
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, /, 'Gamma/min(Gamma) = ', F6.4)
99983 FORMAT ('Cell parameters : ', 3F8.4, 3F9.3)
99982 FORMAT (//, 'OTHER Standardization with Similar Gamma :')
99981 FORMAT ('OTHER Standardization with Similar Gamma :')
99980 FORMAT (/, 'Axes changed to : ', A47)
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 : ', A14)
99974 FORMAT ('Extra origin shift, due to change of setting : ', A14)
99973 FORMAT ('Extra origin shift, due to cell reduction : ', a14)
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 : ', 2a1, i4, 2x, 10(a2, f5.1, 2x))
99969 FORMAT ('Pearson code : ', 2a1, i4, '(-', F6.2, ')', 2x,
     1         10(a2, f5.1, 2x))
99968 FORMAT ('PCODE', 2x, 2a1, a10, 4x, 5(a2, 1x, a7))
99967 FORMAT ('PCODE', 18x             , 5(a2, 1x, a7))
99966 FORMAT ('Space group symbol : ', A10, ' Number in IT : ', I3)
      END
      SUBROUTINE PLA342
      PARAMETER (ndif=30)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /eltname/ finelt(ndif)
      COMMON /num/ nel, newn, nr(ndif), maxnr(ndif)
      CHARACTER data*73, datas*73, params*15, rems(5)*73, pears*14,
     1 sp*17, def*73, ws*38, finelt*2, ch*2, kel(ndif)*2, nums*10
      data nums /'1234567890'/
      CALL GEN126 (KEL, 1, NDIF)
      kk = 0
      DO 10 i = 1, ndif
        IF (maxnr(i) .LE. 1) THEN
          kk = kk + 1
          kel(kk) = finelt(i)
        ENDIF
   10 CONTINUE
      ioth   = 0
      params = ' '
      datas  = ' '
      def    = ' '
      pears  = ' '
      sp     = ' '
      ws     = ' '
      nrrem  = 0
      CALL GEN126 (REMS, 1, 5)
      REWIND LU63
      READ (LU63, 99999, end = 30) data
      IF (data(1:3) .EQ. 'OTH') ioth = 1
   20 READ (LU63, 99999, end = 30) data
      IF (data(1:2) .EQ. 'CG') params(10:15) = data(5:10)
      IF (data(1:2) .EQ. 'ga') params(1:7) = data(7:13)
      IF (data(1:6) .EQ. 'SPCGRP') THEN
        datas = data
        sp    = data(8:24)
        ws    = data(27:64)
      ENDIF
      IF (data(1:5) .EQ. 'PCODE') pears = data(8:21)
      IF (data(1:6) .EQ. 'REMARK') THEN
        nrrem       = nrrem + 1
        rems(nrrem) = data
      ENDIF
      IF (data(1:6) .EQ. 'DEFINE') def = data
      GOTO 20
   30 IF (ioth .EQ. 0) THEN
        CALL PLA269 (3)
        WRITE (LU7, 99997) sp, ws, pears
        IF (datas(65:73) .ne.' ')  THEN
          CALL PLA269 (1)
          WRITE (LU7, 99996) datas(65:73)
        ENDIF
        WRITE (LU7, 99995)
      ENDIF
      REWIND LU63
   40 READ (LU63, 99999, end = 100) data
      IF (data(1:4) .EQ. 'DATA' .or. data(1:4) .EQ. 'OTHE') THEN
         data(59:73) = params
         IF (data(1:4) .EQ. 'OTHE') THEN
           CALL PLA269 (3)
           WRITE (LU7, 99998)
           WRITE (LU7, 99999) data
           WRITE (LU7, 99999) datas
         ELSE
           CALL PLA269 (1)
           WRITE (LU7, 99999) data
         ENDIF
      ELSE IF (data(1:5) .EQ. 'PCODE') THEN
        IF (ioth .EQ. 1) THEN
          CALL PLA269 (2)
          WRITE (LU7, 99999) datas
          WRITE (LU7, 99999) data
        ENDIF
      ELSE IF (data(1:2) .EQ. 'ga' .or. data(1:6) .EQ. 'SPCGRP' .or.
     1         data(1:3) .EQ. 'DEF') THEN
        GOTO 40
      ELSE IF (data(1:5) .EQ. 'OTHER') THEN
         GOTO 100
      ELSE IF (data(1:4) .EQ. 'ATOM') THEN
        IF (def .ne. ' ') THEN
          CALL PLA269 (1)
          WRITE (LU7, 99999) def
        ENDIF
        def = ' '
        IF (kk .GT. 0) THEN
          jj = 8
          DO 50 i = 8, 13
            IF (data(i:i) .NE. ' ') THEN
              ch = data(i:i+1)
              jj = i + 2
              GOTO 60
            ENDIF
   50     CONTINUE
   60     k = index(nums, ch(2:2))
          IF (k .GT. 0) THEN
            ch(2:2) = ' '
            jj = i + 1
          ENDIF
          DO 70 i = 1, kk
            IF (ch .EQ. kel(i)) THEN
              kel(i) = ' '
              data(jj:jj+2) = ' '
              GOTO 80
            ENDIF
   70     CONTINUE
        ENDIF
   80   CALL PLA269 (1)
        WRITE (LU7, 99999) data
        GOTO 40
      ELSE IF (data(1:2) .EQ. 'CG') THEN
        DO 90 i = 1, nrrem
          IF (rems(i) .ne. ' ')  THEN
            CALL PLA269 (1)
            WRITE (LU7, 99999) rems(i)
          ENDIF
   90   CONTINUE
        GOTO 100
      ELSE
        IF (data(1:6) .NE. 'REMARK')  THEN
           CALL PLA269 (1)
           WRITE (LU7, 99999) data
        ENDIF
      ENDIF
      GOTO 40
  100 REWIND LU63
      RETURN
99999 FORMAT (A73)
99998 FORMAT (1X)
99997 FORMAT (/, A17, ' - ', A38, 2x, A14)
99996 FORMAT (19x, A9)
99995 FORMAT (72('-'))
      END
      SUBROUTINE PLA343 (ax, text, o1, o2, o3)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /orgin/ nor, orgadd(3, 8), ntext, icoord
      CHARACTER chori(9)*3, ax*47, text*17, tratxt(69)*1, ortxt(31)*1,
     1 aux*6
      CHARACTER dum(69)*1
      DIMENSION or(3), ori(9)
      data ori/
     1  0.125, 0.25,0.375, 0.5, 0.625, 0.75, 0.875, 0.3333, 0.6667/
      data chori/
     1 '1/8', '1/4', '3/8', '1/2', '5/8', '3/4', '7/8', '1/3', '2/3'/
      aux = ' '
      CALL GEN126 (DUM,    1, 69)
      CALL GEN126 (TRATXT, 1, 69)
      CALL GEN126 (ORTXT,  1, 30)
      or(1) = o1
      or(2) = o2
      or(3) = o3
      lax = 47
      IF (ax .EQ. 'abc' .or. ax .EQ. 'a,b,c') THEN
        lax = 0
      ELSE
        nbl = 0
        DO 10 i = 1, 47
          IF (ax(i:i) .EQ. ' ') THEN
            nbl = nbl + 1
            IF (nbl .EQ. 2) THEN
              lax = i - 2
              GOTO 20
            ENDIF
          ENDIF
   10   CONTINUE
      ENDIF
   20 lxyz = 17
      IF (text .EQ. 'x,y,z') THEN
        lxyz = 0
      ELSE
        nbl = 0
        DO 30 i = 1, 17
          IF (text(i:i) .EQ. ' ') THEN
            nbl = nbl + 1
            IF (nbl .EQ. 2) THEN
              lxyz = i - 2
              GOTO 40
            ENDIF
          ENDIF
   30   CONTINUE
      ENDIF
   40 i1 = 1
      IF (lax .GT. 0) THEN
        DO 50 i = 1, lax
          tratxt(i1) = ax(i:i)
          i1 = i1 + 1
   50   CONTINUE
        CALL GEN126 (TRATXT, I1, I1 + 4)
        i1 = i1 + 5
      ENDIF
      IF (lxyz .GT. 0) THEN
        DO 60 i = 1, lxyz
          tratxt(i1) = text(i:i)
          i1 = i1 + 1
   60   CONTINUE
        CALL GEN126 (TRATXT, I1, I1 + 4)
        i1 = i1 + 5
      ENDIF
      i1 = i1 -1
      lori = 1
      IF (o1 .EQ. 0. .AND. o2 .EQ. 0. .AND. o3 .EQ. 0.) THEN
        IF (lax .EQ. 0 .AND. lxyz .EQ. 0) RETURN
        GOTO 130
      ELSE
        IF (lax .EQ. 0 .AND. lxyz .EQ. 0) THEN
          ortxt(lori) = 'O'
        ELSE
          ortxt(lori) = 'o'
        ENDIF
        lori          = lori + 1
        ortxt(lori)   = 'r'
        ortxt(lori+1) = 'i'
        ortxt(lori+2) = 'g'
        ortxt(lori+3) = 'i'
        ortxt(lori+4) = 'n'
        ortxt(lori+5) = ' '
        lori          = lori + 6
      ENDIF
      DO 120 keer = 1, 3
        IF (icoord .EQ. 1 .AND. keer .EQ. 3) GOTO 100
        IF (icoord .EQ. 2 .AND. keer .EQ. 2) GOTO 100
        IF (icoord .EQ. 3 .AND. keer .EQ. 1) GOTO 100
        IF (icoord .EQ. 3 .AND. keer .EQ. 3) GOTO 100
        IF (icoord .EQ. 4) GOTO 100
        IF (or(keer) .EQ. 0.0) THEN
          ortxt(lori)     = ' '
          ortxt(lori + 1) = '0'
          lori            = lori + 2
        ELSE
          DO 70 i = 1, 9
            IF (abs(or(keer) - ori(i)) .LE. 0.0001) GOTO 80
   70     CONTINUE
          GOTO 100
   80     ortxt(lori) = ' '
          lori        = lori + 1
          DO 90 j = 1, 3
            ortxt(lori) = chori(i)(j:j)
            lori = lori + 1
   90     CONTINUE
        ENDIF
        GOTO 120
  100   ortxt(lori) = ' '
        aux = ' '
        WRITE (aux, 99998) or(keer)
        DO 110 i = 1, 6
          lori = lori + 1
          ortxt(lori) = aux(i:i)
  110   CONTINUE
        lori = lori + 1
  120 CONTINUE
  130 IF (i1 .GT. 0) THEN
        WRITE (LU63, 99999) (tratxt(j), j = 1, i1),
     1    (ortxt(k), k = 1, lori), (dum(l), l = 1, 65 - i1 - lori)
      ELSE
        WRITE (LU63, 99999) (ortxt(k), k = 1, lori),
     1                      (dum(l), l = 1, 65 - lori)
      ENDIF
      RETURN
99999 FORMAT ('TRANS  ', 65A1)
99998 FORMAT (F6.5)
      END
      INTEGER FUNCTION FINDEXE (EXE, PAD, PROGRAM)
      COMMON /MSWDS/ DOS
      CHARACTER EXE*(*), PAD*(*), PROGRAM*(*)
      CHARACTER P*1024, FILE*256
      CHARACTER COMPONENT*80
      CHARACTER DELIM1*1, DELIM2*1, SUFFIX*4
      INTEGER I1, I2, L, LC
      LOGICAL E, DOS
      IF (DOS) THEN
        DELIM1 = CHAR (92)
        DELIM2 = CHAR (59)
        SUFFIX = '.exe'
      ELSE
        DELIM1 = CHAR (47)
        DELIM2 = CHAR (58)
        SUFFIX = ' '
      ENDIF
C * FIND OUT WHETHER 'PROGRAM' IS AVAILABLE
      L  = LEN (PROGRAM)
      LP = LEN (PAD)
      IS = 0
      NB = 1
      CALL GETENV (EXE, PAD)
      IF (PAD(1:1) .NE. ' ') THEN
        INQUIRE (FILE = PAD, EXIST = E)
        GOTO 40
      ENDIF
C * Get the executable search path from the environment
      CALL GETENV ('PATH', P)
      LH = LEN(P)
   10 IF (LH .GT. 0 .AND. ICHAR(P(LH:LH)) .EQ. ICHAR(' ')) THEN
        LH = LH - 1
        GOTO 10
      ENDIF
      IF (LH .LE. 0) GOTO 50
      I1 = 1
   20 I2 = I1
C * Look for separating ":" .OR. ";" character
   30 IF (ICHAR(P(I2:I2)) .NE. ICHAR(DELIM2) .AND. I2 .LE. LH) THEN
        I2 = I2 + 1
        GOTO 30
      ENDIF
      IF (I2 .EQ. 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
      ENDIF
C * Build file name, and see if it exists
      FILE = COMPONENT(1:LC)//DELIM1//PROGRAM(1:L)//SUFFIX
      INQUIRE (FILE = FILE, EXIST = E)
      IF (E) THEN
        PAD = FILE(1:LP)
        GOTO 40
      ENDIF
C * Next path component, if any
      I1 = I2 + 1
      IF (I2 .LE. LH) GOTO 20
      GOTO 50
   40 CALL GEN039 (1, PAD, 1, LP, NB, IS)
   50 FINDEXE = IS
      RETURN
      END
      REAL FUNCTION CPUTIM()
      DIMENSION TARRAY(2)
      TARRAY(1) = 0.0
      TARRAY(2) = 0.0
C     T = ELTIME (TARRAY)
      T = 0.0
      CPUTIM = T
      RETURN
      END
      BLOCK DATA PLATOD
      PARAMETER (NP4=9,NP9=118,NP10=16,NP22=256,NP24=176,NCS=50,
     1 NP31=30,NP34=509,NP35=110,NP37=175,NP40=380,NP46=15)
      COMMON /STID/ ISETS(73, 230)
      COMMON /MEN/ MENA(25, NP31), MENS(25, NP31), MENU(50, NP31),
     1             MNH(NP35)
      COMMON /CMEN/ OPTS(NP46, 7)
      COMMON /IMEN/ IOPT(NP46, 7)
      COMMON /NKEYS/ NCNT
      CHARACTER OPTS*10
      COMMON /DSPGR/ TYPE, NLAUE
      CHARACTER TYPE(NCS)*16, NLAUE(13)*5
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9),
     1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10),
     2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10),
     3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770)
      COMMON /LATICE/ TRNSX(3, 3, 128), ROT(3, 5, 5), TRDAT(3, 3, 8)
      COMMON /CIF/ CIFDIR
      CHARACTER CIFDIR(NP34)*36
      COMMON /FNAME/ KNM(8), KXT, KNM16
      COMMON /NAMES/ NAME(8), EXTENS, PROGNM, FNLU1, FNLU16, RDTYPE
      CHARACTER NAME*80, EXTENS*9, PROGNM*28, FNLU1*80, FNLU16*80,
     1          RDTYPE*7
      COMMON /ALL/ NN(12, 3), LO(12, 2), IE(12, 2)
      COMMON /BONDVAL/ VALENCE(1625)
      CHARACTER VALENCE*18
      COMMON /FSPGR/ CRI(11), PNZ(13, 10), STLS(10)
      COMMON /SABS/ TMC(7), RMF(5, 7), X(6)
      COMMON /ASETUP/ ID(6, 6, 2), IRANGE(12)
      COMMON /CHDAT/ CRD(NP37), LABP(16), COLR(NP10 + 1), BWCT(NP10 + 1)
      CHARACTER CRD*4, LABP*2, COLR*10, BWCT*10
      COMMON /PLA22/ LGR(12), XSYST(8), IBVL(8), LAT(7)
      CHARACTER LGR*5, XSYST*12, IBVL*1, LAT*1
      COMMON /CTRNS/ TRTYP
      CHARACTER TRTYP(8)*5
      COMMON /POINTGR/ PNTGR(32)
      CHARACTER PNTGR*5
      CHARACTER STAA(107)*11, STBB(39)*15, STTEXT(21)*17, STCSH(17)*14
      COMMON /STBL1/ STAA, STBB, STCSH
      COMMON /STBL2/ SPECIA(3, 107)
      COMMON /STBL3/ STTEXT
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /UNITC/ IUNCL(2, 12)
      COMMON /MSWDS/ DOS
      COMMON /XMENU/ MENX, CMEN
      CHARACTER MENX(NP31)*11, CMEN(NP40)*11
      COMMON /PAGENM/ PAGET, PAGEIND(25)
      CHARACTER PAGET*8, PAGEIND*8
      LOGICAL DOS
      DATA PAGET /'        '/
      DATA DOS /.FALSE./
      DATA IUNCL /1, 2, 1, 3, 1, 5, 3, 4, 2, 4, 2, 6, 5, 6, 4, 8,
     1           7, 8, 3, 7, 6, 8, 5, 7/
      DATA LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10, LU11,
     1     LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20, LU21,
     2     LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3     LU60, LU61, LU62, LU63, LU64, LU65 /
     4      1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17,
     5     18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31,
     6     60, 61, 62, 63, 64, 65 /
      DATA DTYPE /'SPF  ', 'RES  ', 'CIF  ', 'FDAT ', 'PDB  ', 'C3D  '/
      DATA RMF /
     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/
      DATA IRANGE /10, 20, 50, 100, 200, 500, 1000, 2000, 5000, 10000,
     1         20000, 50000/
      DATA ID/ 0, 0, 0, 1, 2, 4,   0,-1, 0, 0, 2, 6,   0,-1, 1,-1, 1, 6,
     1         1,-1, 1, 0, 2, 1,   1, 0, 1, 1, 2, 3,   0, 1, 1, 1, 1, 3,
     2        -1, 1, 0, 1, 1, 4,  -1, 0,-1, 1, 2, 5,  -1, 0, 0, 0, 1, 5,
     3         0, 0, 1, 0, 1, 1,   1, 0, 1, 1, 2, 2,   0, 1, 1, 1, 1, 2/
      DATA LGR /'   -1', '  2/m', '  mmm', '  4/m', '4/mmm', '   -3',
     1          '  -3m', '  6/m', '6/mmm', '  m-3', ' m-3m', '     '/
      DATA XSYST /'   Triclinic', '  Monoclinic', 'Orthorhombic',
     1            '  Tetragonal', '    Trigonal', '   Hexagonal',
     2            '       Cubic', '            '/
      DATA IBVL /'a', 'm', 'o', 't', 'r', 'h', 'c', ' '/
      DATA LAT  / 'P', 'A', 'B', 'C', 'F', 'I', 'R'/
      DATA NN/ 2, 2, 2, 2, 7, 7, 7, 7, 2, 2, 3, 2, 3, 3, 4, 5, 3, 3, 5,
     2         4, 3, 3, 4, 4, 5, 4, 6, 6, 4, 5, 6, 6, 4, 5, 5, 5/
      DATA LO/ 1, 2, 5, 3, 1, 4, 6, 8, 7, 2, 5, 3, 2, 5, 3, 1, 4, 6,
     1         8, 7, 4, 6, 8, 7/
      DATA (PNTGR(I), I = 1, 32) /
     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 '/
      DATA (CRI(I), I = 1, 11)
     1     /1.0, 2.5, 1.5, 5.0, 2.5, 10.0, 10.0, 20.0, 50.0, 100.0, 5.0/
      DATA (PNZ(13, I), I = 1, 10) / 24.81, 34.53, 41.87, 47.38,
     1      52.05, 56.14, 59.72, 62.89, 65.72, 68.33/
      DATA (STLS(I), I = 1, 10) / 0.3016, 0.3800, 0.4350, 0.4787,
     1      0.5157, 0.5480, 0.5768, 0.6031, 0.6274, 0.6497/
      DATA LINE, (NAME(I), I = 1, 8), EXTENS
     1 /'       ', 'platon', 'mogli', 'atom', 'shelx', 'omega',
     2  'csd', 'shelxl', 'spgr', 'spf'/
      DATA (KNM(I), I = 1, 8) / 6, 5, 4, 5, 5, 3, 6, 4/
      DATA JTP /'--', 'LN', 'AN', 'TR', 'AK', 'AE', 'HL', '  '/
      DATA IEN /0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
      DATA IDOAC /
     1 3, 4, 5, 6, 7, 8, 9, 38, 84, 110, 10, 2, 0, 0, 0, 0/
      DATA JACL /17, 1, 2, 4, 3, 5, 6, 7, 8, 0, 0, 0, 0,
     1 0, 0, 0/
      DATA IBCL /17,  3,  6,  2,  5,  4,  1,  7,  8,  9,  0,  0, 0, 0,
     1 0, 0/
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 *                                                                  *
C *       H     C     O     N    CL     S    BR     P     I    CU    *
C *      NI    AC    AG    AL    AM    AR    AS    AT    AU     B    *
C *      BA    BE    BI    BK    CA    CD    CE    CF    CM    CO    *
C *      CR    CS     D    DY    ER    ES    EU     F    FE    FM    *
C *      FR    GA    GD    GE    HE    HF    HG    HO    IN    IR    *
C *       K    KR    LA    LI    LU    LR    MD    MG    MN    MO    *
C *      NA    NB    ND    NE    NO    NP    OS    PA    PB    PD    *
C *      PM    PO    PR    PT    PU    RA    RB    RE    RH    RN    *
C *      RU    SB    SC    SE    SI    SM    SN    SR    TA    TB    *
C *      TC    TE    TH    TI    TL    TM     U     V     W    XE    *
C *       Y    YB    ZN    ZR   (RS)  (CG)  (ZA)  (ZB)  (ZC)   OW    *
C *       Q     X    HW     Z    OR    OA    OB    OC                *
C ********************************************************************
      DATA 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/
C * COVALENT RADII
      DATA REL /
     1 0.35, 0.68, 0.68, 0.68, 0.99, 1.04, 1.21, 1.05, 1.40, 1.52,
     2 1.50, 1.88, 1.59, 1.35, 1.51, 0.00, 1.21, 0.00, 1.50, 0.83,
     3 1.34, 0.35, 1.54, 0.00, 0.99, 1.69, 1.83, 0.00, 0.00, 1.23,
     4 1.35, 1.67, 0.23, 1.75, 1.73, 0.00, 1.99, 0.64, 1.35, 0.00,
     5 0.00, 1.22, 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, 0.00, 0.00, 1.10, 1.35, 1.47,
     7 0.97, 1.48, 1.81, 0.00, 0.00, 1.55, 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.46, 1.12, 1.43, 1.76,
     * 1.35, 1.49, 1.79, 1.47, 1.64, 1.72, 1.58, 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, 1.00, 0.23, 1.00, 0.00, 0.00, 0.00, 0.00/
C * VAN DER WAALS RADII - A.BONDI, J.CHEM.PHYS.(1964),68,441-451.
C * NEGATIVE ENTRIES WERE ESTIMATED AS COVALENT RADIUS + 0.8 ANG.
      DATA VDWR /
     1 1.20, 1.70, 1.52, 1.55, 1.75, 1.80, 1.85, 1.80, 1.98,-2.32,
     2-2.30,-2.68,-2.39,-2.15,-2.31, 1.88, 1.85, 0.00,-2.30,-1.63,
     3-2.14,-1.15,-2.34, 0.00,-1.79,-2.49,-2.63, 0.00, 0.00,-2.03,
     4-2.15,-2.47, 1.20,-2.55,-2.53, 0.00,-2.79, 1.47,-2.14, 0.00,
     5 0.00,-2.02,-2.59,-1.97, 1.40,-2.37,-2.50,-2.54,-2.43,-2.12,
     6-2.13, 2.02,-2.67,-2.05,-2.52, 0.00, 0.00,-1.90,-2.15,-2.27,
     7-1.77,-2.28,-2.61, 1.54, 0.00,-2.35,-2.17,-2.41,-2.34,-2.30,
     8-2.60,-2.48,-2.62,-2.30,-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.26,-1.92,-2.23,-2.56,
     *-2.15, 2.06,-2.59,-2.27,-2.35,-2.52,-2.38,-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/
C * ATOM NUMBERS
      DATA 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/
C * ELEMENT CHARACTERISTICS   (NEGATIVE = NONMETAL)
C * 2 = LANTHANIDE, 3 = ACTINIDE, 4 = TRANSITION, 5 = ALKALI
C * 6 = ALKALI EARTH, 7 = HALOGEN
      DATA 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/
C * ATOMIC WEIGHTS (C12-IUPAC 1989) - HANDBOOK FOR PHYSICS & CHEMISTRY
C * UPDATED (IUPAC 1993) FROM Inorg. Chim. Acta 217 (1994) 217-218
      DATA (ATWT(I), I = 1, 60) /
     1   1.00794,    12.011,   15.9994, 14.00674,   35.4527,   32.066,
     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/
      DATA (ATWT(I), I = 61, NP9) /
     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,    239.05, 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/
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 * CU/MO/AG
      DATA (AMR(I, 3), I = 1, 50) /
     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/
      DATA (AMR(I, 3), I = 51, NP9) /
     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/
      DATA (AMR(I, 2), I = 1, 50) /
     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/
      DATA (AMR(I, 2), I = 51, NP9) /
     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/
      DATA (AMR(I, 1), I = 1, 50) /
     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/
      DATA (AMR(I, 1), I = 51, NP9)/
     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/
C * NEUTRON SCATTERING LENGTHS Int. Tables C, 4.4.4.1
      DATA RNSCL /
     1 -3.739,   6.646, 5.803,   9.36,  9.577,  2.847,  6.795,  5.13,
     2   5.28,   7.718,  10.3,    0.0,  5.922,  3.449,    0.0, 1.909,
     3   6.58,     0.0,  7.63,   5.30,   5.06,   7.79, 8.5307,   0.0,
     4   4.90,     5.1,  4.84,    0.0,    0.0,   2.50,  3.635,  5.42,
     5  6.671,    16.9,  8.03,    0.0,   6.73,  5.654,   9.54,   0.0,
     6    0.0,  7.2879,   9.5, 8.1929,   3.26,   7.77, 12.692,  8.08,
     7  4.065,    10.6,  3.71,   7.80,   8.24,  -1.90,   7.21,   0.0,
     8    0.0,   5.375, -3.73,   6.95,   3.63,  7.054,   7.69, 4.547,
     9    0.0,     0.0,  11.0,    0.0, 9.4017,   5.91,    0.0,   0.0,
     *    0.0,    9.60,   0.0,    0.0,   7.08,    9.2,   5.88,   0.0,
     1   7.21,    5.57, 12.29,  7.970,  4.149,    4.2, 6.2257,  7.02,
     2   6.91,    7.38,   0.0,   5.80,  10.63, -3.438,  8.776,   0.0,
     3  8.417, -0.3824,  4.77,   4.85,   7.75,  12.41,  5.689,  7.16,
     4    0.0,     0.0,   0.0,    0.0,    0.0,  5.803,    0.0,   0.0,
     5 -3.739,     0.0,   0.0,    0.0,    0.0,    0.0/
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 * ELEMENT  H     C     O     N     CL    S
      DATA (SFAC(I), I = 1, 90) /
     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,
     1   2.310000, 20.843920,  1.020000, 10.207510,  1.588600,
     2   0.568700,  0.865000, 51.651249,  0.215600,  0.018100,
     3   0.009100,  0.003300,  0.001600,  0.001500,  0.000900,
     1   3.048500, 13.277110,  2.286800,  5.701110,  1.546300,
     2   0.323900,  0.867000, 32.908939,  0.250800,  0.049200,
     3   0.032200,  0.010600,  0.006000,  0.005600,  0.003600,
     1  12.212610,  0.005700,  3.132200,  9.893310,  2.012500,
     2  28.997540,  1.166300,  0.582600,-11.529010,  0.031100,
     3   0.018000,  0.006100,  0.003300,  0.003000,  0.001900,
     1  11.460410,  0.010400,  7.196410,  1.166200,  6.255610,
     2  18.519421,  1.645500, 47.778461, -9.557410,  0.363900,
     3   0.701800,  0.148400,  0.158500,  0.099800,  0.098400,
     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.124600,  0.123400,  0.082600,  0.076300/
C * ELEMENT  BR    P     I     CU    NI    AC
      DATA (SFAC(I), I = 91, 180) /
     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.290100,  2.459500,  0.181100,  1.645200,
     1   6.434510,  1.906700,  4.179100, 27.157040,  1.780000,
     2   0.526000,  1.490800, 68.164574,  1.114900,  0.295500,
     3   0.433500,  0.102300,  0.094200,  0.066700,  0.058000,
     1  20.147221,  4.347000, 18.994921,  0.381400,  7.513810,
     2  27.766041,  2.273500, 66.877670,  4.071200, -0.325700,
     3   6.836200, -0.474200,  1.811900, -0.891900,  1.186800,
     1  13.338010,  3.582800,  7.167610,  0.247000,  5.615810,
     2  11.396610,  1.673500, 64.812668,  1.191000, -1.964600,
     3   0.588800,  0.320100,  1.265100,  0.324000,  0.825700,
     1  12.837610,  3.878500,  7.292010,  0.256500,  4.443800,
     2  12.176310,  2.380000, 66.342163,  1.034100, -3.002900,
     3   0.509100,  0.339300,  1.112400,  0.314700,  0.723200,
     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, -6.849400,  8.517800, -3.278400,  9.450200/
C * ELEMENT  AG    AL    AM    AR    AS    AT
      DATA (SFAC(I), I = 181, 270) /
     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.897100,  1.101500, -1.647300,  0.716700,
     1   6.420210,  3.038700,  1.900200,  0.742600,  1.593600,
     2  31.547239,  1.964600, 85.088676,  1.115100,  0.213000,
     3   0.245500,  0.064500,  0.051400,  0.040600,  0.031300,
     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.000000,  0.000000,
     1   7.484510,  0.907200,  6.772310, 14.840710,  0.653900,
     2  43.898350,  1.644200, 33.392929,  1.444500,  0.384300,
     3   0.871700,  0.174300,  0.200300,  0.119100,  0.124900,
     1  16.672319,  2.634500,  6.070110,  0.264700,  3.431300,
     2  12.947910,  4.277900, 47.797260,  2.531000, -0.930000,
     3   1.005100,  0.049900,  2.005800,  0.275800,  1.331400,
     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, -7.912200,  9.977700, -1.803900,  7.950900/
C * ELEMENT  AU    B     BA    BE    BI    BK
      DATA (SFAC(I), I = 271, 360) /
     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, -2.013300,  8.802200, -0.763800,  5.997800,
     1   2.054500, 23.218519,  1.332600,  1.021000,  1.097900,
     2  60.349869,  0.706800,  0.140300, -0.193200,  0.009000,
     3   0.003900,  0.001300,  0.000700,  0.000400,  0.000400,
     1  20.336121,  3.216000, 19.297029,  0.275600, 10.888010,
     2  20.207319,  2.695900,167.20219 ,  2.773100, -1.045600,
     3   8.461700, -0.324400,  2.281900, -0.694000,  1.500400,
     1   1.591900, 43.642750,  1.127800,  1.862300,  0.539100,
     2 103.48310 ,  0.702900,  0.542000,  0.038500,  0.003800,
     3   0.001400,  0.000500,  0.000200,  0.000100,  0.000100,
     1  33.368938,  0.704000, 12.951010,  2.923800, 16.587721,
     2   8.793710,  6.469210, 48.009350, 13.578210, -4.011100,
     3   8.931000, -4.107700, 10.256600, -1.349400,  7.256600,
     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.000000,  0.000000/
C * ELEMENT  CA    CD    CE    CF    CM    CO
      DATA (SFAC(I), I = 361, 450) /
     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.226200,  0.306400,  0.161100,  0.192600,
     1  19.221420,  0.594600, 17.644421,  6.908910,  4.461000,
     2  24.700840,  1.602900, 87.482567,  5.069410,  0.118500,
     3   4.653300, -0.807500,  1.202400, -1.439600,  0.783200,
     1  21.167110,  2.812190, 19.769520,  0.226840, 11.851310,
     2  17.608320,  3.330490,127.11310 ,  1.862640, -1.848200,
     3   9.659600, -0.248600,  2.633100, -0.589000,  1.735800,
     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.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.000000,  0.000000,
     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.349400,  0.972100,  0.305000,  0.629600/
C * ELEMENT  CR    CS    D     DY    ER   ES
      DATA (SFAC(I), I = 451, 540) /
     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.320900,  0.623600,  0.249600,  0.399200,
     1  20.389219,  3.569000, 19.106220,  0.310700, 10.662010,
     2  24.387939,  1.495300,213.90421 ,  3.335200, -0.745700,
     3   7.905200, -0.368000,  2.119200, -0.752700,  1.391600,
     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,
     1  26.507030,  2.180200, 17.638321,  0.202170, 14.559620,
     2  12.189910,  2.965770,111.87410 ,  4.297280, -9.804600,
     3   9.847700, -0.189200,  4.409800, -0.330200,  2.940400,
     1  27.656340,  2.073560, 16.428530,  0.223550, 14.977910,
     2  11.360410,  2.982330,105.70310 ,  5.920470, -9.436700,
     3   3.938000, -0.258600,  4.957600, -0.309100,  3.315800,
     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.000000,  0.000000/
C * ELEMENT  EU    F     FE    FM    FR   GA
      DATA (SFAC(I), I = 541, 630) /
     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, -0.157800,  3.668200, -0.397700,  2.435100,
     1   3.539200, 10.282510,  2.641200,  4.294400,  1.517000,
     2   0.261500,  1.024300, 26.147631,  0.277600,  0.072700,
     3   0.053400,  0.017100,  0.010300,  0.009600,  0.006100,
     1  11.769510,  4.761110,  7.357310,  0.307200,  3.522200,
     2  15.353510,  2.304500, 76.880577,  1.036900, -1.133600,
     3   3.197400,  0.346300,  0.844400,  0.288600,  0.544800,
     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.000000,  0.000000,
     1  35.929932,  0.646450, 23.054720,  4.176190, 12.143910,
     2  23.105221,  2.112530,150.64510 , 13.724710, -3.968900,
     3  10.803800, -7.222400,  7.784700, -2.412900,  8.683900,
     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,  0.230700,  1.608300,  0.317900,  1.058900/
C * ELEMENT  GD    GE    HE    HF    HG   HO
      DATA (SFAC(I), I = 631, 720) /
     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, -0.165300,  3.903500, -0.374100,  2.595400,
     1  16.081619,  2.850900,  6.374710,  0.251600,  3.706800,
     2  11.446810,  3.683000, 54.762562,  2.131300, -1.088500,
     3   0.885500,  0.154700,  1.800100,  0.301600,  1.190300,
     1   0.873400,  9.103710,  0.630900,  3.356800,  0.311200,
     2  22.927629,  0.178000,  0.982100,  0.006400,  0.000000,
     3   0.000000,  0.000000,  0.000000,  0.000000,  0.000000,
     1  29.144039,  1.832620, 15.172610,  9.599910, 14.758610,
     2   0.275120,  4.300130, 72.029083,  8.581550, -6.179400,
     3   4.977600, -0.583000,  6.185200, -0.354800,  4.164300,
     1  20.680920,  0.545000, 19.041719,  8.448410, 21.657520,
     2   1.572900,  5.967610, 38.324631, 12.608910, -4.292300,
     3   7.684900, -2.389400,  9.226600, -0.880100,  6.298900,
     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, -0.217500,  4.678300, -0.316800,  3.124100/
C * ELEMENT  IN    IR    K     KR    LA   LI
      DATA (SFAC(I), I = 721, 810) /
     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.727600,  1.310000, -1.284300,  0.854200,
     1  27.304930,  1.592790, 16.729610,  8.865540, 15.611520,
     2   0.417920,  5.833780, 45.001141, 11.472210, -4.771000,
     3   6.566700, -1.444200,  7.988700, -0.597700,  5.426900,
     1   8.218610, 12.794910,  7.439810,  0.774800,  1.051900,
     2 213.18720 ,  0.865900, 41.684158,  1.422800,  0.386800,
     3   1.065700,  0.200900,  0.249400,  0.139900,  0.156200,
     1  17.355511,  1.938400,  6.728610, 16.562321,  5.549310,
     2   0.226100,  3.537500, 39.397228,  2.825000, -0.565700,
     3   1.438500, -0.557400,  2.707900,  0.106700,  1.819200,
     1  20.578020,  2.948170, 19.599010,  0.244480, 11.372710,
     2  18.772610,  3.287190,133.12410 ,  2.146780, -1.409400,
     3   9.037600, -0.287100,  2.452300, -0.641100,  1.614800,
     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.000300,  0.000100, -0.000400,  0.000000/
C * ELEMENT  LU    LR    MD    MG    MN   MO
      DATA (SFAC(I), I = 811, 900) /
     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, -0.472000,  5.858400, -0.329900,  3.937700,
     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.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.000000,  0.000000,
     1   5.420410,  2.827500,  2.173500, 79.261177,  1.226900,
     2   0.380800,  2.307300,  7.193710,  0.858400,  0.171900,
     3   0.177100,  0.048600,  0.036300,  0.029800,  0.022000,
     1  11.281910,  5.340910,  7.357310,  0.343200,  3.019300,
     2  17.867420,  2.244100, 83.754379,  1.089600, -0.529900,
     3   2.805200,  0.336800,  0.728300,  0.270400,  0.468100,
     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, -1.683200,  0.685700, -1.270300,  3.097800/
C * ELEMENT  NA    NB    ND    NE    NO    NP
      DATA (SFAC(I), I = 901, 990) /
     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.036200,  0.024900,  0.021800,  0.015000,
     1  17.614229,  1.188650, 12.014410, 11.766010,  4.041830,
     2   0.204790,  3.533460, 69.795761,  3.755910, -0.112100,
     3   2.482600, -2.072700,  0.621500, -0.828200,  2.840400,
     1  22.684521,  2.662480, 19.684719,  0.210630, 12.774010,
     2  15.885020,  2.851370,137.90311 ,  1.984860, -3.180700,
     3  10.907900, -0.194300,  3.017900, -0.501200,  1.995000,
     1   3.955300,  8.404210,  3.112500,  3.426200,  1.454600,
     2   0.230600,  1.125100, 21.718410,  0.351500,  0.101900,
     3   0.083300,  0.025900,  0.016400,  0.015200,  0.009800,
     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.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,-11.493700,  4.149300, -6.999500,  9.587600/
C * ELEMENT  OS    PA    PB    PD    PM    PO
      DATA (SFAC(I), I = 991, 1080) /
     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, -1.216500,  7.603000, -0.528000,  5.155800,
     1  35.884739,  0.547750, 23.294821,  3.415190, 14.189110,
     2  16.923519,  4.172870,105.25110 , 13.428710, -4.247300,
     3  12.868100, -8.033400,  9.280700, -4.606700, 10.241300,
     1  31.061741,  0.690200, 13.063710,  2.357600, 18.442020,
     2   8.618010,  5.969610, 47.257950, 13.411810, -4.075300,
     3   8.506000, -3.394400, 10.111100, -1.167600,  6.928700,
     1  19.331921,  0.698660, 15.501720,  7.989300,  5.295370,
     2  25.205231,  0.605840, 76.898682,  5.265930,  0.121500,
     3   3.933700, -0.998800,  1.007200, -1.955600,  0.654600,
     1  23.340521,  2.562700, 19.609529,  0.202090, 13.123510,
     2  15.100910,  2.875160,132.72110 ,  2.028760, -4.059800,
     3  11.552300, -0.175300,  3.224900, -0.462600,  2.134700,
     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, -5.121000, 11.049600, -1.561300,  7.598600/
C * ELEMENT  PR    PT    PU    RA    RB    RE
      DATA (SFAC(I), I = 1081, 1170) /
     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.218000,  2.821400, -0.542400,  1.862400,
     1  27.005939,  1.512930, 17.763920,  8.811750, 15.713120,
     2   0.424590,  5.783710, 38.610340, 11.688310, -4.593200,
     3   6.926400, -1.703300,  8.390500, -0.681200,  5.708100,
     1  36.525440,  0.499380, 23.808319,  3.263710, 16.770720,
     2  14.945510,  3.479470,105.98010 , 13.381210, -4.656300,
     3  14.372900, -9.410000,  4.305600,-13.590500,  6.946800,
     1  35.763031,  0.616340, 22.906420,  3.871350, 12.473910,
     2  19.988720,  3.210970,142.32510 , 13.621110, -4.008800,
     3  11.296900, -6.770400,  8.143500, -2.808100,  9.061400,
     1  17.178419,  1.788800,  9.643510, 17.315121,  5.139900,
     2   0.274800,  1.529200,164.93420 ,  3.487300, -0.468800,
     3   1.607900, -0.939300,  2.967600,  0.006800,  2.002500,
     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, -1.018500,  7.231000, -0.469300,  4.894400/
C * ELEMENT  RH    RN    RU    SB    SC    SE
      DATA (SFAC(I), I = 1171, 1260) /
     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, -1.117800,  0.918700, -2.528000,  0.596400,
     1  35.563141,  0.663100, 21.281620,  4.069100,  8.003710,
     2  14.042210,  7.443310, 44.247341, 13.690510, -3.948700,
     3  10.318100, -8.065900, 10.458000, -2.084700,  8.311200,
     1  19.267429,  0.808520, 12.918210,  8.434680,  4.863370,
     2  24.799740,  1.567560, 94.292892,  5.378750,  0.055200,
     3   3.296000, -1.259400,  0.836300, -5.363000,  3.650600,
     1  19.641821,  5.303400, 19.045521,  0.460700,  5.037110,
     2  27.907440,  2.682700, 75.282578,  4.590910, -0.056200,
     3   5.894600, -0.586600,  1.546100, -1.054700,  1.010400,
     1   9.189010,  9.021310,  7.367910,  0.572900,  1.640900,
     2 136.10809 ,  1.468000, 51.353149,  1.332900,  0.311900,
     3   1.533100,  0.251900,  0.371600,  0.182900,  0.234800,
     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, -0.092900,  2.225900,  0.236700,  1.483100/
C * ELEMENT  SI    SM    SN    SR    TA    TB
      DATA (SFAC(I), I = 1261, 1350) /
     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.081700,  0.070400,  0.052200,  0.043100,
     1  24.004240,  2.472740, 19.425831,  0.196450, 13.439610,
     2  14.399610,  2.896040,128.00710 ,  2.209630, -5.323600,
     3  12.217800, -0.163800,  3.441800, -0.428700,  2.281500,
     1  19.188919,  5.830310, 19.100519,  0.503100,  4.458500,
     2  26.890930,  2.466300, 83.957176,  4.782110,  0.025900,
     3   5.459100, -0.653700,  1.424600, -1.158700,  0.929900,
     1  17.566311,  1.556400,  9.818410, 14.098810,  5.422000,
     2   0.166400,  2.669400,132.37610 ,  2.506400, -0.352800,
     3   1.820000, -1.530700,  3.249800, -0.117200,  2.202500,
     1  29.202440,  1.773330, 15.229310,  9.370470, 14.513510,
     2   0.295980,  4.764920, 63.364471,  9.243550, -5.795900,
     3   5.271800, -0.705200,  6.522700, -0.383100,  4.399200,
     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, -0.172300,  4.153700, -0.349600,  2.765400/
C * ELEMENT  TC    TE    TH    TI    TL    TM
      DATA (SFAC(I), I = 1351, 1440) /
     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, -1.439000,  0.759300, -2.008700,  3.349000,
     1  19.964420,  4.817420, 19.013821,  0.420890,  6.144880,
     2  28.528440,  2.523900, 70.840363,  4.352000, -0.175900,
     3   6.353100, -0.530800,  1.675100, -0.971000,  1.096000,
     1  35.564529,  0.563360, 23.421921,  3.462040, 12.747310,
     2  17.830919,  4.807040, 99.172302, 13.431410, -4.149100,
     3  12.329600, -7.240000,  8.897900, -3.853300,  9.840300,
     1   9.759510,  7.850810,  7.355810,  0.500000,  1.699100,
     2  35.633831,  1.902100,116.10510 ,  1.280700,  0.219100,
     3   1.806900,  0.277600,  0.445700,  0.206000,  0.283000,
     1  27.544630,  0.655150, 19.158421,  8.707520, 15.538020,
     2   1.963470,  5.525940, 45.814960, 13.174610, -4.162700,
     3   8.090000, -2.835800,  9.668800, -1.011700,  6.609000,
     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, -0.313900,  5.248300, -0.308400,  3.515500/
C * ELEMENT  U     V     W     XE    Y     YB
      DATA (SFAC(I), I = 1441, 1530) /
     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, -9.676700,  9.664600, -5.722500, 10.642800,
     1  10.297110,  6.865710,  7.351110,  0.438500,  2.070300,
     2  26.893829,  2.057100,102.47810 ,  1.219900,  0.068700,
     3   2.109700,  0.300500,  0.529400,  0.227600,  0.337600,
     1  29.081829,  1.720290, 15.430010,  9.225910, 14.432710,
     2   0.321700,  5.119830, 57.056061,  9.887510, -5.473400,
     3   5.577400, -0.849000,  6.872200, -0.420100,  4.643000,
     1  20.293320,  3.928200, 19.029819,  0.344000,  8.976710,
     2  26.465940,  1.990000, 64.265869,  3.711800, -0.517900,
     3   7.350000, -0.420500,  1.957800, -0.820000,  1.283800,
     1  17.776020,  1.402900, 10.294610, 12.800610,  5.726300,
     2   0.125600,  3.265880,104.35410 ,  1.912130, -0.267000,
     3   2.024400, -2.796200,  3.566700, -0.287900,  2.409900,
     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, -0.385000,  5.548600, -0.315700,  3.722900/
C * ELEMENT  ZN    ZR   (RS)   (CG)  (ZA)  (ZB)
      DATA (SFAC(I), I = 1531, 1620) /
     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,  0.283900,  1.430100,  0.324200,  0.937500,
     1  17.876530,  1.276180, 10.948010, 11.916010,  5.417330,
     2   0.117620,  3.657210, 87.662781,  2.069290, -0.186200,
     3   2.244900, -2.967300,  0.559700, -0.536400,  2.614100,
     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.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.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.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.000000,  0.000000/
C * ELEMENT  (ZC)  OW    Q     X     HW
      DATA (SFAC(I), I = 1621, 1695) /
     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.000000,  0.000000,
     1   3.048500, 13.277110,  2.286800,  5.701110,  1.546300,
     2   0.323900,  0.867000, 32.908939,  0.250800,  0.049200,
     3   0.032200,  0.010600,  0.006000,  0.005600,  0.003600,
     1   2.310000, 20.843920,  1.020000, 10.207510,  1.588600,
     2   0.568700,  0.865000, 51.651249,  0.215600,  0.018100,
     3   0.009100,  0.003300,  0.001600,  0.001500,  0.000900,
     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.000000,  0.000000,
     4   0.493000, 10.510910,  0.322910, 26.125731,  0.140190,
     5   3.142360,  0.040810, 57.799770,  0.003040,  0.000000,
     6   0.000000,  0.000000,  0.000000,  0.000000,  0.000000/
C * ELEMENT Z  (OR) (OA) (OB) (OC)
      DATA (SFAC(I), I = 1696, 1770) /
     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.000000,  0.000000,
     4   0.000000,  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.000000,  0.000000,
     8   0.000000,  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.000000,  0.000000,
     2   0.000000,  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.000000,  0.000000/
      DATA (VALENCE(I), I = 1, 60)/
     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'/
      DATA (VALENCE(I), I = 61, 120)/
     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 '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'/
      DATA (VALENCE(I), I = 121, 180)/
     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'/
      DATA (VALENCE(I), I = 181, 240)/
     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',
     * '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'/
      DATA (VALENCE(I), I = 241, 300)/
     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.65 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'/
      DATA (VALENCE(I), I = 301, 360)/
     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 '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'/
      DATA (VALENCE(I), I = 361, 420)/
     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',
     * 'Er3O -2 2.0100.37b', 'Er3O -2 1.9790.37a', 'Er3S -2 2.52 0.37e'/
      DATA (VALENCE(I), I = 421, 480)/
     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 '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'/
      DATA (VALENCE(I), I = 481, 540)/
     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 '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'/
      DATA (VALENCE(I), I = 541, 600)/
     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'/
      DATA (VALENCE(I), I = 601, 660)/
     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 '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'/
      DATA (VALENCE(I), I = 661, 720)/
     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'/
      DATA (VALENCE(I), I = 721, 780)/
     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 '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', 'Mn2O -2 1.7900.37a',
     * 'Mn2O -2 1.7650.37j', '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'/
      DATA (VALENCE(I), I = 781, 840)/
     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 '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 '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'/
      DATA (VALENCE(I), I = 841, 900)/
     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'/
      DATA (VALENCE(I), I = 901, 960)/
     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 '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'/
      DATA (VALENCE(I), I = 961, 1020)/
     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'/
      DATA (VALENCE(I), I = 1021, 1080)/
     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 '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'/
      DATA (VALENCE(I), I = 1081, 1140)/
     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'/
      DATA (VALENCE(I), I = 1141, 1200)/
     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 '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'/
      DATA (VALENCE(I), I = 1201, 1260)/
     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 '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'/
      DATA (VALENCE(I), I = 1261, 1320)/
     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'/
      DATA (VALENCE(I), I = 1321, 1380)/
     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 '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'/
      DATA (VALENCE(I), I = 1381, 1440)/
     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'/
      DATA (VALENCE(I), I = 1441, 1500)/
     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'/
      DATA (VALENCE(I), I = 1501, 1560)/
     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 5S -2 2.25 0.37e',
     * 'V 5F -1 1.70 0.37e', 'V 5Cl-1 2.16 0.37b', 'V 9O -2 1.81 0.34o',
     1 'V 9Br-1 2.30 0.37b', 'V 9I -1 2.51 0.37b', 'V 9S -2 2.23 0.37b',
     2 'V 9Se-2 2.33 0.37b', 'V 9Te-2 2.57 0.37b', 'V 9N -3 1.86 0.37b',
     3 'V 9P -3 2.31 0.37b', 'V 9As-3 2.39 0.37b', 'V 9H -1 1.58 0.37b',
     4 'W 5O -2 1.89 0.37e', 'W 6O -2 1.9170.37a', 'W 6O -2 1.9160.41x',
     5 'W 6O -2 1.9210.37b', 'W 6F -1 1.83 0.37b', 'W 6Cl-1 2.27 0.37b',
     6 'W 9Br-1 2.45 0.37b', 'W 9I -1 2.66 0.37b', 'W 9S -2 2.39 0.37b',
     7 'W 9Se-2 2.51 0.37b', 'W 9Te-2 2.71 0.37b', 'W 9N -3 2.06 0.37b',
     8 'W 9P -3 2.46 0.37b', 'W 9As-3 2.54 0.37b', 'W 9H -1 1.76 0.37b',
     9 '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', 'Xe8O -2 1.94 0.37e'/
      DATA (VALENCE(I), I = 1561, 1620)/
     1 'Y 3O -2 2.0190.37a', 'Y 3O -2 2.0140.37b', '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', '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'/
      DATA (VALENCE(I), I = 1621, 1625)/
     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'/
C * KEYWORDS (PLATON)
      DATA (ISWS(I), I = 1, 151) /
     1         'TITL', 'MESS', 'REM ', 'ANGS', 'ROUN', 'FIT ', 'LSPL',
     2 'RING', 'NOMO', 'PSID', 'DOAC', 'LINE', 'ENDS', 'PLOT', 'YES ',
     3 'NO  ', 'CALC', 'END ', 'INCL', 'EXCL', 'STOP', 'HELP', 'SAVE',
     4 'UIJ ', 'SUIJ', 'U   ', 'ATOM', 'LIST', 'CELL', 'CESD', 'SYMM',
     5 'SPGR', 'LATT', 'DIST', 'ANGL', 'TORS', 'HBON', 'BIJ ', 'SBIJ',
     6 'B   ', 'TRNS', 'FVAR', 'PARE', 'QUIT', 'SET ', 'AFIX', 'SFAC',
     7 'UNIT', 'WGHT', 'VIEW', 'BOX ', 'EXIT', 'BOND', 'ZERR', 'GEOM',
     8 'L   ', 'FMAP', 'INFO', 'TABL', 'RADI', 'BLOC', 'MENU', 'OMIT',
     9 'GRID', 'DFIX', 'JOIN', 'DETA', 'DEFI', 'HKLF', 'RADN', 'TRMX',
     * 'PART', 'INOR', 'ORGA', 'RTAB', 'SIMU', 'ENTR', 'ELLI', 'ORMA',
     1 'EXTI', 'SETU', 'EXOR', 'ABSG', 'FACE', 'ABST', 'ABSX', 'LEPA',
     2 'ASYM', 'ABSP', 'ABSS', 'CONT', 'REST', 'VALI', 'EXPT', 'PLUT',
     3 'MOLE', 'PLAN', 'TWIN', 'SPEC', 'MERG', 'SUMP', 'RESI', 'SHEL',
     4 'MORE', 'TIME', 'CGLS', 'ACTA', 'DAMP', 'DISP', 'SLIM', 'SIZE',
     5 'EQIV', 'EXYZ', 'EADP', 'BOND', 'FREE', 'BIND', 'SAME', 'CONF',
     6 'MPLA', 'FLAT', 'CHIV', 'DELU', 'ISOR', 'SADI', 'ANIS', 'CONN',
     7 'HFIX', 'LAUE', 'BUMP', 'TEMP', 'DEFS', 'ABSC', 'SWAT', 'EMPI',
     8 'LAMI', 'HOPE', 'DMAT', 'SKIP', 'WPDB', 'BASF', 'MOVE', 'FRAG',
     9 'FEND', 'HALL', 'HTAB', 'MULA', 'HKLT', 'XTAL', 'HINC', 'HEXC'/
      DATA (ISWS(I), I = 152, NP24) /
     1 'FILE', 'RENA', 'SYST', 'DELR', 'EXP1', 'ARU ', 'VARI', 'FCF2',
     2 'PORT', 'POWD', 'FSUM', 'SCAL', 'CRYS', 'ROTM', 'CAVI', 'SHXA',
     3 'DELE', 'COLO', 'RESE', 'SCAT', 'STID', 'BIJV', '    ', '    ',
     4 '    '/
      DATA (ISWS(I), I = NP24 + 1, NP22) /
     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', 'MOGL',
     4 'EUCL', 'FIVE', 'ALL ', 'TOLP', 'TOLR', 'NOTH', 'VOID', 'PROB',
     5 'PSTE', 'LIST', 'EXPA', 'DIST', 'TOLE', 'MISS', 'SOLV', 'TOLM',
     6 'NODI', 'BOND', 'ANGL', 'TORS', 'CSD ', 'SQUE', 'SAR ', 'FCF ',
     7 'DIFA', 'NEWS', 'NOCH', 'PDB ', 'HINC', 'NONS', 'NONA', 'MAXD',
     8 'WLSP', 'FCAL', 'ADDS', 'DELA', 'NOSO', 'DISO', 'GENE', 'EXPE',
     9 'MAXR', 'MOLS', 'RENU', 'PLOT', 'RDF ', 'GRID', 'F3D ', 'NOSF',
     * '    ', '    ', '    ', '    ', '    ', '    ', '    ', '    '/
      DATA (((TRNSX (I, J, K), I = 1, 3), J = 1, 3), K = 1, 15)/
     1  1,   0,   0,   0,   1,   0,   0,   0,   1,
     2  1,   0,   0,   0,   1,   0.5, 0,   0,   0.5,
     3  0.5, 0,   0,   0,   1,   0,   0.5, 0,   1,
     4  1,   0.5, 0,   0,   0.5, 0,   0,   0,   1,
     5  0.5, 0.5, 0,   0,   0.5, 0.5, 0.5, 0,   0.5,
     6  1,   0,   0.5, 0,   1,   0.5, 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,   1, 0, 1,   0, 0, 0, 0,-1,
     * -1,   0, 0, 0,   0, 1, 0, 1, 0,
     1  0,   0, 0, 0,   0, 0, 0, 0, 0,
     2  0,   0, 0, 0,   0, 0, 0, 0, 0,
     3  1,   0, 0, 0,   1, 0, 0, 0, 1,
     4  1,   0, 0, 0,   1, 0, 0, 0, 1,
     5  1,   0, 0, 0,   1, 0, 0, 0, 1,
     6  1,   0, 1, 0,   1, 1, 0, 0, 1/
C * SUPERLAT1:
      DATA ((TRNSX(I, J, 16), I = 1, 3), J = 1, 3)/
     1  1, 0, 0, 0, 1, 0, 0, 0, 1/
C * SUPERLAT2: SANTORO & MIGHELL, ACTA CRYST (1972),A28,284-287
      DATA (((TRNSX(I, J, K), J = 1, 3), I = 1, 3), K = 17, 23)/
     1  2.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, 2.0, 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, 2.0,
     4  2.0, 0.0, 0.0, 1.0, 1.0, 0.0, 0.0, 0.0, 1.0,
     5  2.0, 0.0, 0.0, 0.0, 1.0, 0.0, 1.0, 0.0, 1.0,
     6  1.0, 0.0, 0.0, 0.0, 1.0, 1.0, 0.0, 0.0, 2.0,
     7  1.0, 1.0, 0.0, 0.0, 1.0, 1.0, 1.0, 0.0, 1.0/
C * SUPERLAT3:
      DATA (((TRNSX(I, J, K), J = 1, 3), I = 1, 3), K = 24, 36)/
     1  3.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, 3.0, 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, 3.0,
     4  1.0,-1.0, 0.0, 2.0, 1.0, 0.0, 0.0, 0.0, 1.0,
     5  1.0, 1.0, 0.0,-2.0, 1.0, 0.0, 0.0, 0.0, 1.0,
     6 -1.0, 0.0, 1.0, 2.0, 0.0, 1.0, 0.0, 1.0, 0.0,
     7  1.0, 0.0, 1.0, 2.0, 0.0,-1.0, 0.0, 1.0, 0.0,
     8  0.0, 1.0,-1.0, 0.0, 2.0, 1.0, 1.0, 0.0, 0.0,
     9  0.0, 1.0, 1.0, 0.0,-2.0, 1.0, 1.0, 0.0, 0.0,
     *  2.0, 1.0, 1.0, 1.0, 1.0, 0.0, 0.0, 2.0, 1.0,
     1  1.0, 2.0, 1.0,-1.0,-1.0, 0.0, 2.0, 0.0, 1.0,
     2  1.0, 1.0, 2.0, 1.0, 0.0, 1.0, 2.0, 1.0, 0.0,
     3  1.0, 1.0, 1.0, 1.0, 2.0, 0.0, 0.0, 2.0, 1.0/
C * SUPERLAT4:
      DATA (((TRNSX(I, J, K), J = 1, 3), I = 1, 3), K = 37, 54)/
     1  4.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, 4.0, 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, 4.0,
     4  4.0, 0.0, 0.0, 3.0, 1.0, 0.0, 0.0, 0.0, 1.0,
     5  4.0, 0.0, 0.0, 1.0, 1.0, 0.0, 0.0, 0.0, 1.0,
     6  4.0, 0.0, 0.0, 0.0, 1.0, 0.0, 3.0, 0.0, 1.0,
     7  4.0, 0.0, 0.0, 0.0, 1.0, 0.0, 1.0, 0.0, 1.0,
     8  1.0, 0.0, 0.0, 0.0, 1.0, 3.0, 0.0, 0.0, 4.0,
     9  1.0, 0.0, 0.0, 0.0, 1.0, 1.0, 0.0, 0.0, 4.0,
     *  4.0, 0.0, 0.0, 2.0, 1.0, 0.0, 0.0, 0.0, 1.0,
     1  4.0, 0.0, 0.0, 0.0, 1.0, 0.0, 2.0, 0.0, 1.0,
     2  1.0, 0.0, 0.0, 0.0, 2.0, 1.0, 0.0, 0.0, 2.0,
     3  2.0, 0.0, 0.0, 1.0, 2.0, 0.0, 0.0, 0.0, 1.0,
     4  2.0, 0.0, 0.0, 0.0, 1.0, 0.0, 1.0, 0.0, 2.0,
     5  1.0, 0.0, 0.0, 0.0, 1.0, 2.0, 0.0, 0.0, 4.0,
     6  2.0, 2.0, 0.0, 0.0, 1.0, 1.0, 1.0, 0.0, 1.0,
     7  1.0, 1.0, 0.0, 0.0, 1.0, 1.0, 2.0, 0.0, 2.0,
     8  1.0, 1.0, 0.0, 0.0, 2.0, 2.0, 1.0, 0.0, 1.0/
      DATA (((TRNSX(I, J, K), J = 1, 3), I = 1, 3), K = 55, 71)/
     1  1.0, 2.0, 1.0, 1.0, 1.0, 2.0, 2.0, 1.0, 1.0,
     2  3.0, 1.0, 0.0, 1.0, 1.0, 1.0, 2.0, 0.0, 1.0,
     3  4.0, 0.0, 0.0, 1.0, 1.0, 0.0, 2.0, 0.0, 1.0,
     4  2.0, 1.0, 0.0, 1.0, 1.0, 1.0, 3.0, 0.0, 1.0,
     5  4.0, 0.0, 0.0, 2.0, 1.0, 0.0, 1.0, 0.0, 1.0,
     6  1.0, 1.0, 1.0, 0.0, 1.0, 3.0, 1.0, 0.0, 2.0,
     7  2.0, 0.0, 0.0, 0.0, 1.0, 1.0, 1.0, 0.0, 2.0,
     8  2.0, 1.0, 0.0, 0.0, 1.0, 1.0, 2.0, 0.0, 1.0,
     9  1.0, 2.0, 0.0, 0.0, 2.0, 1.0, 1.0, 0.0, 1.0,
     *  1.0, 1.0, 0.0, 0.0, 1.0, 2.0, 1.0, 0.0, 2.0,
     1  2.0, 0.0, 0.0, 0.0, 2.0, 0.0, 0.0, 0.0, 1.0,
     2  2.0, 0.0, 0.0, 0.0, 1.0, 0.0, 0.0, 0.0, 2.0,
     3  1.0, 0.0, 0.0, 0.0, 2.0, 0.0, 0.0, 0.0, 2.0,
     4  2.0, 0.0, 0.0, 0.0, 1.0, 1.0, 0.0, 0.0, 2.0,
     5  2.0, 0.0, 0.0, 0.0, 2.0, 0.0, 1.0, 0.0, 1.0,
     6  2.0, 0.0, 0.0, 1.0, 1.0, 0.0, 0.0, 0.0, 2.0,
     7  2.0, 0.0, 0.0, 1.0, 1.0, 1.0, 0.0, 0.0, 2.0/
C * SUBLAT1:
      DATA ((TRNSX(I, J, 72), J = 1, 3), I = 1, 3)/
     1  1.0, 0.0, 0.0, 0.0, 1.0, 0.0, 0.0, 0.0, 1.0/
C * SUBLAT2:
      DATA (((TRNSX(I, J, K), J = 1, 3), I = 1, 3), K = 73, 79)/
     1  0.5, 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.5, 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.5,
     4  0.5,-0.5, 0.0, 0.0, 1.0, 0.0, 0.0, 0.0, 1.0,
     5  0.5, 0.0,-0.5, 0.0, 1.0, 0.0, 0.0, 0.0, 1.0,
     6  1.0, 0.0, 0.0, 0.0, 1.0, 0.0, 0.0,-0.5, 0.5,
     7  0.5, 0.5,-0.5,-0.5, 0.5, 0.5, 0.5,-0.5, 0.5/
C * SUBLAT3:
      DATA (((TRNSX(I, J, K), J = 1, 3), I = 1, 3), K = 80, 92)/
     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.66667, 0.0, 0.33333, 0.33333, 0.0, 0.0, 0.0, 1.0,
     5 0.33333, 0.66667, 0.0, -0.33333, 0.33333, 0.0, 0.0, 0.0, 1.0,
     6-0.33333, 0.0, 0.66667, 0.33333, 0.0, 0.33333, 0.0, 1.0, 0.0,
     7 0.33333, 0.0, 0.66667, 0.33333, 0.0, -0.33333, 0.0, 1.0, 0.0,
     8 0.0, 0.33333, -0.66667, 0.0, 0.33333, 0.33333, 1.0, 0.0, 0.0,
     9 0.0, 0.33333, 0.66667, 0.0, -0.33333, 0.33333, 1.0, 0.0, 0.0,
     * 0.33333, -0.33333, 0.66667, 0.33333, 0.66667,-1.33333,-0.33333,
     1 0.33333, 0.33333,
     3-0.33333, 0.33333, 0.66667,-0.66667,-0.33333, 1.33333, 0.33333,
     4-0.33333, 0.33333,
     5 -0.33333, 0.66667, 0.33333, 0.66667,-1.33333, 0.33333, 0.33333,
     6 0.33333,-0.33333,
     7 0.66667,-0.33333, 0.66667, 0.33333, 0.33333, -0.66667,-0.66667,
     8 0.33333, 0.33333/
C * SUBLAT4:
      DATA (((TRNSX(I, J, K), J = 1, 3), I = 1, 3), K = 93, 110)/
     1 0.25,  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.25,  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.25,
     4 0.25,-0.75,  0.0,  0.0,  1.0,  0.0,  0.0,  0.0,  1.0,
     5 0.25,-0.25,  0.0,  0.0,  1.0,  0.0,  0.0,  0.0,  1.0,
     6 0.25,  0.0,-0.75,  0.0,  1.0,  0.0,  0.0,  0.0,  1.0,
     7 0.25,  0.0,-0.25,  0.0,  1.0,  0.0,  0.0,  0.0,  1.0,
     8  1.0,  0.0,  0.0,  0.0,  1.0,  0.0,  0.0,-0.75, 0.25,
     9  1.0,  0.0,  0.0,  0.0,  1.0,  0.0,  0.0,-0.25, 0.25,
     * 0.25, -0.5,  0.0,  0.0,  1.0,  0.0,  0.0,  0.0,  1.0,
     1 0.25,  0.0, -0.5,  0.0,  1.0,  0.0,  0.0,  0.0,  1.0,
     2  1.0,  0.0,  0.0,  0.0,  0.5,  0.0,  0.0,-0.25,  0.5,
     3  0.5,-0.25,  0.0,  0.0,  0.5,  0.0,  0.0,  0.0,  1.0,
     4  0.5,  0.0,-0.25,  0.0,  1.0,  0.0,  0.0,  0.0,  0.5,
     5  1.0,  0.0,  0.0,  0.0,  1.0,  0.0,  0.0, -0.5, 0.25,
     6 0.25, 0.25,-0.25, -0.5,  0.5,  0.5,  0.5, -0.5,  0.5,
     7  0.5,  0.5, -0.5, -0.5,  0.5,-0.25, -0.5,  0.5, 0.25,
     8  0.5,  0.5, -0.5,-0.25, 0.25, 0.25,  0.5, -0.5,  0.5/
      DATA (((TRNSX(I, J, K), J = 1, 3), I = 1, 3), K = 111, 128)/
     1-0.25, 0.75,-0.25,-0.25,-0.25, 0.75, 0.75,-0.25,-0.25,
     2 0.25, 0.25, -0.5,-0.25, 0.75,  0.5, 0.25,-0.75,  0.5,
     3 0.25,-0.25, -0.5,  0.0,  1.0,  0.0,  0.0,  0.0,  1.0,
     4 0.25,  0.5,-0.75,-0.25,  0.5, 0.75, 0.25, -0.5, 0.25,
     5 0.25, -0.5,-0.25,  0.0,  1.0,  0.0,  0.0,  0.0,  1.0,
     6  0.5, 0.75,-0.25, -0.5, 0.25, 0.25,  0.5,-0.75, 0.25,
     7  0.5, 0.25,-0.25,  0.0,  1.0,  0.0,  0.0, -0.5,  0.5,
     8 0.25,  0.5, -0.5,-0.25,  0.5,  0.5, 0.25, -0.5,  0.5,
     9  0.5, 0.25, -0.5, -0.5, 0.25,  0.5,  0.5,-0.25,  0.5,
     *  0.5, -0.5,  0.5,  0.5,  0.5, -0.5,-0.25, 0.25, 0.25,
     1  0.5,  0.0,  0.0,  0.0,  0.5,  0.0,  0.0,  0.0,  1.0,
     2  0.5,  0.0,  0.0,  0.0,  1.0,  0.0,  0.0,  0.0,  0.5,
     3  1.0,  0.0,  0.0,  0.0,  0.5,  0.0,  0.0,  0.0,  0.5,
     4  0.5,  0.0,  0.0,  0.0,  1.0,  0.0,  0.0, -0.5,  0.5,
     5  0.5,  0.0, -0.5,  0.0,  0.5,  0.0,  0.0,  0.0,  1.0,
     6  0.5, -0.5,  0.0,  0.0,  1.0,  0.0,  0.0,  0.0,  0.5,
     7  0.5, -0.5,  0.0,  0.0,  1.0,  0.0,  0.0, -0.5,  0.5,
     8  0.5,  0.0,  0.0,  0.0,  0.5,  0.0,  0.0,  0.0,  0.5/
      DATA ROT/
     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/
      DATA (CIFDIR(I), I = 1, 18) /
     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       ',
     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           '/
      DATA (CIFDIR(I), I = 19, 36) /
     1 '_atom_site_fract_x                  ',
     2 '_atom_site_fract_y                  ',
     3 '_atom_site_fract_z                  ',
     4 '_atom_site_label                    ',
     5 '_atom_site_label_component_0        ',
     6 '_atom_site_label_component_1        ',
     7 '_atom_site_label_component_2        ',
     8 '_atom_site_label_component_3        ',
     9 '_atom_site_label_component_4        ',
     * '_atom_site_label_component_5        ',
     1 '_atom_site_label_component_6        ',
     2 '_atom_site_occupancy                ',
     3 '_atom_site_refinement_flags         ',
     4 '_atom_site_restraints               ',
     5 '_atom_site_symmetry_multiplicity    ',
     6 '_atom_site_thermal_displace_type    ',
     7 '_atom_site_type_symbol              ',
     8 '_atom_site_U_iso_or_equiv           '/
      DATA (CIFDIR(I), I = 37, 54) /
     1 '_atom_site_Wyckoff_symbol           ',
     2 '_atom_sites_Cartn_tran_matrix_11    ',
     3 '_atom_sites_Cartn_tran_matrix_12    ',
     4 '_atom_sites_Cartn_tran_matrix_13    ',
     5 '_atom_sites_Cartn_tran_matrix_21    ',
     6 '_atom_sites_Cartn_tran_matrix_22    ',
     7 '_atom_sites_Cartn_tran_matrix_23    ',
     8 '_atom_sites_Cartn_tran_matrix_31    ',
     9 '_atom_sites_Cartn_tran_matrix_32    ',
     * '_atom_sites_Cartn_tran_matrix_33    ',
     1 '_atom_sites_Cartn_transform_axes    ',
     2 '_atom_sites_solution_primary        ',
     3 '_atom_sites_solution_secondary      ',
     4 '_atom_sites_solution_hydrogens      ',
     5 '_atom_type_analytical_mass_%        ',
     6 '_atom_type_description              ',
     7 '_atom_type_number_in_cell           ',
     8 '_atom_type_oxidation_number         '/
      DATA (CIFDIR(I), I = 55, 72) /
     1 '_atom_type_radius_bond              ',
     2 '_atom_type_radius_contact           ',
     3 '_atom_type_scat_Cromer_Mann_a1      ',
     4 '_atom_type_scat_Cromer_Mann_a2      ',
     5 '_atom_type_scat_Cromer_Mann_a3      ',
     6 '_atom_type_scat_Cromer_Mann_a4      ',
     7 '_atom_type_scat_Cromer_Mann_b1      ',
     8 '_atom_type_scat_Cromer_Mann_b2      ',
     9 '_atom_type_scat_Cromer_Mann_b3      ',
     * '_atom_type_scat_Cromer_Mann_b4      ',
     1 '_atom_type_scat_Cromer_Mann_c       ',
     2 '_atom_type_scat_dispersion_imag     ',
     3 '_atom_type_scat_dispersion_real     ',
     4 '_atom_type_scat_source              ',
     5 '_atom_type_scat_versus_stol_list    ',
     6 '_atom_type_symbol                   ',
     7 '_audit_creation_date                ',
     8 '_audit_creation_method              '/
      DATA (CIFDIR(I), I = 73, 90) /
     1 '_audit_update_record                ',
     2 '_cell_angle_alpha                   ',
     3 '_cell_angle_beta                    ',
     4 '_cell_angle_gamma                   ',
     5 '_cell_formula_units_Z               ',
     6 '_cell_length_a                      ',
     7 '_cell_length_b                      ',
     8 '_cell_length_c                      ',
     9 '_cell_measurement_pressure          ',
     * '_cell_measurement_radiation         ',
     1 '_cell_measurement_refln_index_h     ',
     2 '_cell_measurement_refln_index_k     ',
     3 '_cell_measurement_refln_index_l     ',
     4 '_cell_measurement_refln_theta       ',
     5 '_cell_measurement_reflns_used       ',
     6 '_cell_measurement_temperature       ',
     7 '_cell_measurement_theta_max         ',
     8 '_cell_measurement_theta_min         '/
      DATA (CIFDIR(I), I = 91, 108) /
     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              ',
     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        '/
      DATA (CIFDIR(I), I = 109, 126) /
     1 '_chemical_formula_sum               ',
     2 '_chemical_formula_weight            ',
     3 '_chemical_formula_weight_meas       ',
     4 '_chemical_melting_point             ',
     5 '_chemical_name_common               ',
     6 '_chemical_name_mineral              ',
     7 '_chemical_name_structure_type       ',
     8 '_chemical_name_systematic           ',
     9 '_computing_cell_refinement          ',
     * '_computing_data_collection          ',
     1 '_computing_data_reduction           ',
     2 '_computing_molecular_graphics       ',
     3 '_computing_publication_material     ',
     4 '_computing_structure_refinement     ',
     5 '_computing_structure_solution       ',
     6 '_database_code_CAS                  ',
     7 '_database_code_CSD                  ',
     8 '_database_code_ICSD                 '/
      DATA (CIFDIR(I), I = 127, 144) /
     1 '_database_code_MDF                  ',
     2 '_database_code_NBS                  ',
     3 '_database_code_PDF                  ',
     4 '_database_journal_ASTM              ',
     5 '_database_journal_CSD               ',
     6 '_diffrn_ambient_pressure            ',
     7 '_diffrn_ambient_temperature         ',
     8 '_diffrn_attenuator_code             ',
     9 '_diffrn_attenuator_scale            ',
     * '_diffrn_measurement_device          ',
     1 '_diffrn_measurement_method          ',
     2 '_diffrn_orient_matrix_type          ',
     3 '_diffrn_orient_matrix_UB_11         ',
     4 '_diffrn_orient_matrix_UB_12         ',
     5 '_diffrn_orient_matrix_UB_13         ',
     6 '_diffrn_orient_matrix_UB_21         ',
     7 '_diffrn_orient_matrix_UB_22         ',
     8 '_diffrn_orient_matrix_UB_23         '/
      DATA (CIFDIR(I), I = 145, 162) /
     1 '_diffrn_orient_matrix_UB_31         ',
     2 '_diffrn_orient_matrix_UB_32         ',
     3 '_diffrn_orient_matrix_UB_33         ',
     4 '_diffrn_orient_refln_angle_chi      ',
     5 '_diffrn_orient_refln_angle_kappa    ',
     6 '_diffrn_orient_refln_angle_phi      ',
     7 '_diffrn_orient_refln_angle_psi      ',
     8 '_diffrn_orient_refln_index_h        ',
     9 '_diffrn_orient_refln_index_k        ',
     * '_diffrn_orient_refln_index_l        ',
     1 '_diffrn_radiation_detector          ',
     2 '_diffrn_radiation_detector_dtime    ',
     3 '_diffrn_radiation_filter_edge       ',
     4 '_diffrn_radiation_inhomogeneity     ',
     5 '_diffrn_radiation_monochromator     ',
     6 '_diffrn_radiation_polarisn_norm     ',
     7 '_diffrn_radiation_polarisn_ratio    ',
     8 '_diffrn_radiation_source            '/
      DATA (CIFDIR(I), I = 163, 180) /
     1 '_diffrn_radiation_type              ',
     2 '_diffrn_radiation_wavelength        ',
     3 '_diffrn_radiation_wavelength_id     ',
     4 '_diffrn_radiation_wavelength_wt     ',
     5 '_diffrn_refln_angle_chi             ',
     6 '_diffrn_refln_angle_kappa           ',
     7 '_diffrn_refln_angle_omega           ',
     8 '_diffrn_refln_angle_phi             ',
     9 '_diffrn_refln_angle_psi             ',
     * '_diffrn_refln_angle_theta           ',
     1 '_diffrn_refln_attenuator_code       ',
     2 '_diffrn_refln_counts_bg_1           ',
     3 '_diffrn_refln_counts_bg_2           ',
     4 '_diffrn_refln_counts_net            ',
     5 '_diffrn_refln_counts_peak           ',
     6 '_diffrn_refln_counts_total          ',
     7 '_diffrn_refln_crystal_id            ',
     8 '_diffrn_refln_detect_slit_horiz     '/
      DATA (CIFDIR(I), I = 181, 198) /
     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      ',
     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          '/
      DATA (CIFDIR(I), I = 199, 216) /
     1 '_diffrn_reflns_limit_h_min          ',
     2 '_diffrn_reflns_limit_k_max          ',
     3 '_diffrn_reflns_limit_k_min          ',
     4 '_diffrn_reflns_limit_l_max          ',
     5 '_diffrn_reflns_limit_l_min          ',
     6 '_diffrn_reflns_number               ',
     7 '_diffrn_reflns_reduction_process    ',
     8 '_diffrn_reflns_theta_max            ',
     9 '_diffrn_reflns_theta_min            ',
     * '_diffrn_reflns_trans_matrix_11      ',
     1 '_diffrn_reflns_trans_matrix_12      ',
     2 '_diffrn_reflns_trans_matrix_13      ',
     3 '_diffrn_reflns_trans_matrix_21      ',
     4 '_diffrn_reflns_trans_matrix_22      ',
     5 '_diffrn_reflns_trans_matrix_23      ',
     6 '_diffrn_reflns_trans_matrix_31      ',
     7 '_diffrn_reflns_trans_matrix_32      ',
     8 '_diffrn_reflns_trans_matrix_33      '/
      DATA (CIFDIR(I), I = 217, 234) /
     1 '_diffrn_scale_group_code            ',
     2 '_diffrn_scale_group_net             ',
     3 '_diffrn_special_details             ',
     4 '_diffrn_standard_refln_code         ',
     5 '_diffrn_standard_refln_index_h      ',
     6 '_diffrn_standard_refln_index_k      ',
     7 '_diffrn_standard_refln_index_l      ',
     8 '_diffrn_standards_decay_%           ',
     9 '_diffrn_standards_interval_count    ',
     * '_diffrn_standards_interval_time     ',
     1 '_diffrn_standards_number            ',
     2 '_diffrn_standards_scale_sigma       ',
     3 '_exptl_absorpt_coefficient_mu       ',
     4 '_exptl_absorpt_correction_T_max     ',
     5 '_exptl_absorpt_correction_T_min     ',
     6 '_exptl_absorpt_correction_type      ',
     7 '_exptl_absorpt_process_details      ',
     8 '_exptl_crystal_colour               '/
      DATA (CIFDIR(I), I = 235, 252) /
     1 '_exptl_crystal_density_diffrn       ',
     2 '_exptl_crystal_density_meas         ',
     3 '_exptl_crystal_density_meas_temp    ',
     4 '_exptl_crystal_density_method       ',
     5 '_exptl_crystal_description          ',
     6 '_exptl_crystal_F_000                ',
     7 '_exptl_crystal_face_diffr_chi       ',
     8 '_exptl_crystal_face_diffr_kappa     ',
     9 '_exptl_crystal_face_diffr_phi       ',
     * '_exptl_crystal_face_diffr_psi       ',
     1 '_exptl_crystal_face_index_h         ',
     2 '_exptl_crystal_face_index_k         ',
     3 '_exptl_crystal_face_index_l         ',
     4 '_exptl_crystal_face_perp_dist       ',
     5 '_exptl_crystal_id                   ',
     6 '_exptl_crystal_preparation          ',
     7 '_exptl_crystal_size_max             ',
     8 '_exptl_crystal_size_mid             '/
      DATA (CIFDIR(I), I = 253, 270) /
     1 '_exptl_crystal_size_min             ',
     2 '_exptl_crystal_size_rad             ',
     3 '_exptl_crystals_number              ',
     4 '_exptl_special_details              ',
     5 '_geom_angle                         ',
     6 '_geom_angle_atom_site_label_1       ',
     7 '_geom_angle_atom_site_label_2       ',
     8 '_geom_angle_atom_site_label_3       ',
     9 '_geom_angle_publ_flag               ',
     * '_geom_angle_site_symmetry_1         ',
     1 '_geom_angle_site_symmetry_2         ',
     2 '_geom_angle_site_symmetry_3         ',
     3 '_geom_bond_atom_site_label_1        ',
     4 '_geom_bond_atom_site_label_2        ',
     5 '_geom_bond_distance                 ',
     6 '_geom_bond_publ_flag                ',
     7 '_geom_bond_site_symmetry_1          ',
     8 '_geom_bond_site_symmetry_2          '/
      DATA (CIFDIR(I), I = 271, 288) /
     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     ',
     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                 '/
      DATA (CIFDIR(I), I = 289, 306) /
     1 '_journal_coden_Cambridge            ',
     2 '_journal_coeditor_address           ',
     3 '_journal_coeditor_code              ',
     4 '_journal_coeditor_email             ',
     5 '_journal_coeditor_fax               ',
     6 '_journal_coeditor_name              ',
     7 '_journal_coeditor_notes             ',
     8 '_journal_coeditor_phone             ',
     9 '_journal_date_accepted              ',
     * '_journal_date_from_coeditor         ',
     1 '_journal_date_to_coeditor           ',
     2 '_journal_date_printers_final        ',
     3 '_journal_date_printers_first        ',
     4 '_journal_date_proofs_in             ',
     5 '_journal_date_proofs_out            ',
     6 '_journal_date_recd_copyright        ',
     7 '_journal_date_recd_electronic       ',
     8 '_journal_date_recd_hard_copy        '/
      DATA (CIFDIR(I), I = 307, 324) /
     1 '_journal_issue                      ',
     2 '_journal_name_full                  ',
     3 '_journal_page_first                 ',
     4 '_journal_page_last                  ',
     5 '_journal_suppl_publ_number          ',
     6 '_journal_suppl_publ_pages           ',
     7 '_journal_techeditor_address         ',
     8 '_journal_techeditor_code            ',
     9 '_journal_techeditor_email           ',
     * '_journal_techeditor_fax             ',
     1 '_journal_techeditor_name            ',
     2 '_journal_techeditor_notes           ',
     3 '_journal_techeditor_phone           ',
     4 '_journal_volume                     ',
     5 '_journal_year                       ',
     6 '_publ_author_address                ',
     7 '_publ_author_name                   ',
     8 '_publ_contact_author                '/
      DATA (CIFDIR(I), I = 325, 342) /
     1 '_publ_contact_author_email          ',
     2 '_publ_contact_author_fax            ',
     3 '_publ_contact_author_phone          ',
     4 '_publ_contact_letter                ',
     5 '_publ_manuscript_creation           ',
     6 '_publ_manuscript_incl_extra_item    ',
     7 '_publ_manuscript_incl_extra_info    ',
     8 '_publ_manuscript_incl_extra_defn    ',
     9 '_publ_manuscript_processed          ',
     * '_publ_manuscript_text               ',
     1 '_publ_requested_coeditor_name       ',
     2 '_publ_requested_journal             ',
     3 '_publ_section_title                 ',
     4 '_publ_section_abstract              ',
     5 '_publ_section_comment               ',
     6 '_publ_section_introduction          ',
     7 '_publ_section_experimental          ',
     8 '_publ_section_discussion            '/
      DATA (CIFDIR(I), I = 343, 360) /
     1 '_publ_section_acknowledgements      ',
     2 '_publ_section_references            ',
     3 '_publ_section_figure_captions       ',
     4 '_publ_section_table_legends         ',
     5 '_refine_diff_density_max            ',
     6 '_refine_diff_density_min            ',
     7 '_refine_ls_abs_structure_details    ',
     8 '_refine_ls_abs_structure_Flack      ',
     9 '_refine_ls_abs_structure_Rogers     ',
     * '_refine_ls_extinction_coef          ',
     1 '_refine_ls_extinction_expression    ',
     2 '_refine_ls_extinction_method        ',
     3 '_refine_ls_goodness_of_fit_all      ',
     4 '_refine_ls_goodness_of_fit_obs      ',
     5 '_refine_ls_hydrogen_treatment       ',
     6 '_refine_ls_matrix_type              ',
     7 '_refine_ls_number_constraints       ',
     8 '_refine_ls_number_parameters        '/
      DATA (CIFDIR(I), I = 361, 378) /
     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         ',
     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                   '/
      DATA (CIFDIR(I), I = 379, 396) /
     1 '_refln_F_calc                       ',
     2 '_refln_F_meas                       ',
     3 '_refln_F_sigma                      ',
     4 '_refln_F_squared_calc               ',
     5 '_refln_F-squared_meas               ',
     6 '_refln_F_squared_sigma              ',
     7 '_refln_index_h                      ',
     8 '_refln_index_k                      ',
     9 '_refln_index_l                      ',
     * '_refln_intensity_calc               ',
     1 '_refln_intensity_meas               ',
     2 '_refln_intensity_sigma              ',
     3 '_refln_mean_path_length_tbar        ',
     4 '_refln_observed_status              ',
     5 '_refln_phase_calc                   ',
     6 '_refln_phase_meas                   ',
     7 '_refln_refinement_status            ',
     8 '_refln_scale_group_code             '/
      DATA (CIFDIR(I), I = 397, 414) /
     1 '_refln_sint/lambda                  ',
     2 '_refln_symmetry_epsilon             ',
     3 '_refln_symmetry_multiplicity        ',
     4 '_refln_wavelength                   ',
     5 '_refln_wavelength_id                ',
     6 '_reflns_d_resolution_high           ',
     7 '_reflns_d_resolution_low            ',
     8 '_reflns_limit_h_max                 ',
     9 '_reflns_limit_h_min                 ',
     * '_reflns_limit_k_max                 ',
     1 '_reflns_limit_k_min                 ',
     2 '_reflns_limit_l_max                 ',
     3 '_reflns_limit_l_min                 ',
     4 '_reflns_number_total                ',
     5 '_reflns_number_observed             ',
     6 '_reflns_observed_criterion          ',
     7 '_reflns_scale_group_code            ',
     8 '_reflns_scale_meas_F                '/
      DATA (CIFDIR(I), I = 415, 422) /
     1 '_reflns_scale_meas_F_squared        ',
     2 '_reflns_scale_meas_intensity        ',
     3 '_reflns_special_details             ',
     4 '_symmetry_cell_setting              ',
     5 '_symmetry_equiv_pos_as_xyz          ',
     6 '_symmetry_Int_Tables_number         ',
     7 '_symmetry_space_group_name_Hall     ',
     8 '_symmetry_space_group_name_H-M      '/
      DATA (CIFDIR(I), I = 423, 440) /
     1 '_atom_site_B_iso_or_equiv           ',
     2 '_publ_section_exptl_prep            ',
     3 '_publ_section_exptl_refinement      ',
     4 '_geom_hbond_atom_site_label_D       ',
     5 '_geom_hbond_atom_site_label_H       ',
     6 '_geom_hbond_atom_site_label_A       ',
     7 '_geom_hbond_distance_DH             ',
     8 '_geom_hbond_distance_HA             ',
     9 '_geom_hbond_distance_DA             ',
     * '_geom_hbond_angle_DHA               ',
     1 '_geom_hbond_site_symmetry_A         ',
     2 '_geom_hbond_publ_flag               ',
     3 '_journal_coden_Cambridge            ',
     4 '_publ_requested_category            ',
     5 '_publ_contact_author_name           ',
     6 '_publ_contact_author_address        ',
     7 '_publ_section_title_footnote        ',
     8 '_publ_section_synopsis              '/
      DATA (CIFDIR(I), I = 441, 458) /
     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        ',
     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 '/
      DATA (CIFDIR(I), I = 459, 476) /
     1 '_diffrn_measured_fraction_theta_full',
     2 '_refine_ls_wR_factor_gt             ',
     3 '_refine_ls_shift/su_mean            ',
     4 '_refine_diff_density_rms            ',
     5 '_diffrn_detector_area_resol_mean    ',
     6 '_database_code_CSD                  ',
     7 '_iucr_compatibility_tag             ',
     8 '_geom_hbond_site_symmetry_D         ',
     9 '_geom_hbond_site_symmetry_H         ',
     * '_journal_paper_category             ',
     1 '_publ_author_footnote               ',
     2 '_geom_extra_table_head_a            ',
     3 '_geom_extra_tablea_col_1            ',
     4 '_geom_extra_tablea_col_2            ',
     5 '_geom_extra_tablea_col_3            ',
     6 '_geom_extra_tablea_col_4            ',
     7 '_geom_extra_tablea_col_5            ',
     8 '_geom_extra_tablea_col_6            '/
      DATA (CIFDIR(I), I = 477, 494) /
     1 '_vrn_publ_code                      ',
     2 '_chemical_absolute_configuration    ',
     3 '_refln_nonius_diffracted_cos_cstar  ',
     4 '_symmetry_equiv_pos_site_id         ',
     5 '_diffrn_radiation_probe             ',
     6 '_chemical_formula_iupac             ',
     7 '_space_group_crystal_system         ',
     8 '_space_group_id                     ',
     9 '_space_group_IT_number              ',
     * '_space_group_name_Hall              ',
     1 '_space_group_name_H-M               ',
     2 '_space_group_name_H-M_alt           ',
     3 '_space_group_symop_id               ',
     4 '_space_group_symop_operation_xyz    ',
     5 '_space_group_symop_sg_id            ',
     6 '_diffrn_source                      ',
     7 '_diffrn_detector                    ',
     8 '_diffrn_detector_dtime              '/
      DATA (CIFDIR(I), I = 495, NP34) /
     1 '_diffrn_standards_decay_corr_max    ',
     2 '_diffrn_standards_decay_corr_min    ',
     3 '_diffrn_reflns_av_uneti/neti        ',
     4 '_exptl_absorpt_factor_mur           ',
     5 '_exptl_absorpt_correction_t_ave     ',
     6 '_audit_conform_dict_name            ',
     7 '_audit_conform_dict_version         ',
     8 '_audit_conform_dict_location        ',
     9 '_platon_squeeze_void_nr             ',
     * '_platon_squeeze_void_average_x      ',
     1 '_platon_squeeze_void_average_y      ',
     2 '_platon_squeeze_void_average_z      ',
     3 '_platon_squeeze_void_volume         ',
     4 '_platon_squeeze_void_count_electrons',
     5 '_platon_squeeze_details             '/
      DATA SPECIA/3*.5,0.,3*.5,0.,3*.5,0.,.5,3*0.,.5,3*0.,.5,3*0.,2*.25,
     1.5,2*.25,0.,2*.25,.75,4*.25,.75,.25,.75,2*.25,2*.5,.25,0.,.5,.25,
     2.5,0.,.25,2*0.,3*.25,.5,.75,.25,.5,.75,.25,0.,2*.25,0.,.25,.75,0.,
     3.25,2*0.,.25,0.,.5,0.,2*.25,0.,.25,.75,3*.125,.25,0.,.25,2*.125,
     4.625,0.,.5,.75,.25,.75,.5,0.,.25,.125,0.,.25,.625,.25,3*.75,.25,
     5.75,0.,.75,.125,0.,.25,.375,.33333,.66667,0.,.33333,.66667,.5,
     6.66667,.33333,0.,.66667,.33333,.5,.33333,.66667,.25,.66667,.33333,
     7.25,.33333,.66667,4*.75,3*.625,.25,.5,0.,3*.375,3*.875,.125,0.,.25
     8,.625,0.,.25,.375,0.,.25,.875,0.,.25,0.,.75,.25,.5,.25,.75,.875,
     92*.125,-1.,2*.5,-1.,.5,0.,-1.,0.,.5,-1.,2*0.,-1.,2*.25,-1.,0.,.25,
     A-1.,.25,.75,-1.,.5,.25,-1.,.25,.5,-1.,.25,0.,-1.,2*.125,-1.,.25,
     B.125,-1.,.75,.25,-1.,0.,.33333,-1.,0.,.83333,-1.,0.,.66667,-1.,0.,
     C.16667,.5,-1.,.5,0.,-1.,2*.5,-1.,2*0.,-1.,0.,.5,-1.,.25,0.,-1.,
     D2*.25,-1.,2*.25,-1.,0.,.75,-1.,2*.25,-1.,.5,.125,-1.,.125,2*.5,-1.
     E,0.,.5,-1.,.5,0.,-1.,2*0.,-1.,2*.25,-1.,0.,.25,-1.,.25,.75,-1.,.25
     F,.5,-1.,.25,0.,-1.,2*.125,-1.,.75,.25,-1.,.33333,.66667,-1.,.66667
     G,.33333,-1.,2*-1.,.5,2*-1.,0.,2*-1.,.25,-1.,.5,2*-1.,0.,2*-1.,.25,
     H-1.,.5,2*-1.,0.,2*-1.,.25,2*-1./
      DATA (STAA(I), I = 1, 107)/
     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  '/
      DATA (STBB(I), I = 1, 39)/
     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          ',
     I 'x -x z         ', 'x 1/2+x z      ', 'x 2x z         '/
      DATA 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'/
      DATA STTEXT/
     1 'x,y,z',      '-x,y,-z',  '-x,-y,z',           'x,-y,-z',
     2 'y,x,-z',     '-y,-x,-z', '1/4-y,1/4-x,1/4-z', '-x,1/2-y,-z',
     3 '-y,1/2-x,z', '1/4-x,1/4-y,1/4-z', '-x,-y,-z', 'x,-y,z',
     4 'x,y,-z',     '-x,1/2-y,1/4-z',    '-y,-x,z',  'y,x,z',
     5 '1/4+y,1/4+x,1/4+z', 'x,-z,y', '-z,y,x', '-x,z,-y', 'z,-y,-x'/
      DATA (ISETS(I,  1), I = 1, 7)/
     1   1,  1,  1,  0,  1,  0,  1/
      DATA (ISETS(I,  2), I = 1, 24)/
     1   1,  1,  0,  8,  2,  0,  8,  7,  6,  5,  4,  3,  2,  1,  1,  1,
     2   1,  1,  1,  1,  1,  1,  1,  2/
      DATA (ISETS(I,  3), I = 1, 16)/
     1   2,  1,  1,  4,  2,  0, 78, 76, 77, 75,  1,  1,  1,  1,  1,  2/
      DATA (ISETS(I,  4), I = 1, 7)/
     1   2,  1,  1,  0,  1,  0,  2/
      DATA (ISETS(I,  5), I = 1, 12)/
     1   3,  1,  1,  2,  2,  0, 78, 76,  1,  1,  2,  4/
      DATA (ISETS(I,  6), I = 1, 12)/
     1   2,  1,  1,  2,  2,  0,103,102,  1,  1,  1,  2/
      DATA (ISETS(I,  7), I = 1, 7)/
     1   4,  1,  1,  0,  1,  0,  2/
      DATA (ISETS(I,  8), I = 1, 10)/
     1   3,  1,  1,  1,  2,  0,103,  1,  2,  4/
      DATA (ISETS(I,  9), I = 1, 7)/
     1   5,  1,  1,  0,  1,  0,  4/
      DATA (ISETS(I, 10), I = 1, 38)/
     1   2,  1,  0, 14,  4,  0,  8,  6,  7,  5,  4,  2,  3,  1, 78, 77,
     2  76, 75,103,102,  1,  1,  1,  1,  1,  1,  1,  1,  2,  2,  2,  2,
     3   3,  3,  1,  2,  2,  4/
      DATA (ISETS(I, 11), I = 1, 19)/
     1   2,  1,  0,  5,  3,  0,  8,  5,  7,  3,104,  1,  1,  1,  1,  2,
     2   2,  2,  4/
      DATA (ISETS(I, 12), I = 1, 29)/
     1   3,  1,  0,  9,  5,  0,  8,  6,  7,  2, 10,  9, 78, 76,103,  1,
     2   1,  1,  1,  2,  2,  3,  3,  4,  2,  4,  4,  4,  8/
      DATA (ISETS(I, 13), I = 1, 21)/
     1   4,  1,  0,  6,  3,  0,  8,  4,  6,  5, 80, 79,  1,  1,  1,  1,
     2   2,  2,  2,  2,  4/
      DATA (ISETS(I, 14), I = 1, 16)/
     1   4,  1,  0,  4,  2,  0,  8,  5,  7,  3,  1,  1,  1,  1,  2,  4/
      DATA (ISETS(I, 15), I = 1, 20)/
     1   6,  1,  0,  5,  4,  0,  8,  6, 10,  9, 80,  1,  1,  2,  2,  3,
     2   4,  4,  4,  8/
      DATA (ISETS(I, 16), I = 1, 51)/
     1   7,  1,  1, 20,  5,  0,  8,  5,  6,  7,  4,  3,  2,  1, 61, 60,
     2  59, 58, 78, 76, 77, 75, 89, 88, 87, 86,  1,  1,  1,  1,  1,  1,
     3   1,  1,  2,  2,  2,  2,  3,  3,  3,  3,  4,  4,  4,  4,  1,  2,
     4   2,  2,  4/
      DATA (ISETS(I, 17), I = 1, 17)/
     1   9,  1,  1,  4,  3,  0, 61, 59, 80, 79,  1,  1,  2,  2,  2,  2,
     2   4/
      DATA (ISETS(I, 18), I = 1, 12)/
     1   8,  1,  1,  2,  2,  0, 89, 87,  1,  1,  2,  4/
      DATA (ISETS(I, 19), I = 1, 7)/
     1  10,  1,  1,  0,  1,  0,  4/
      DATA (ISETS(I, 20), I = 1, 13)/
     1   9,  1,  1,  2,  3,  0, 61, 80,  1,  2,  4,  4,  8/
      DATA (ISETS(I, 21), I = 1, 34)/
     1   8,  1,  1, 11,  6,  0,  8,  6,  3,  7, 61, 60, 78, 76, 89, 87,
     2  90,  1,  1,  1,  1,  2,  2,  3,  3,  4,  4,  5,  2,  4,  4,  4,
     3   4,  8/
      DATA (ISETS(I, 22), I = 1, 31)/
     1   7,  1,  1, 10,  5,  0,  8,  7, 12, 11, 61, 78, 89, 90, 81, 62,
     2   1,  1,  1,  1,  2,  3,  4,  4,  3,  2,  4,  8,  8,  8, 16/
      DATA (ISETS(I, 23), I = 1, 31)/
     1   7,  1,  1, 10,  5,  0,  8,  5,  7,  6, 61, 60, 78, 77, 89, 87,
     2   1,  1,  1,  1,  2,  2,  3,  3,  4,  4,  2,  4,  4,  4,  8/
      DATA (ISETS(I, 24), I = 1, 16)/
     1  10,  1,  1,  3,  4,  0, 63, 82, 91,  1,  2,  3,  4,  4,  4,  8/
      DATA (ISETS(I, 25), I = 1, 26)/
     1   8,  1,  1,  8,  4,  0, 89, 87, 88, 86,103,102,106,105,  1,  1,
     2   1,  1,  2,  2,  3,  3,  1,  2,  2,  4/
      DATA (ISETS(I, 26), I = 1, 12)/
     1   0,  1,  1,  2,  2,  0,106,105,  1,  1,  2,  4/
      DATA (ISETS(I, 27), I = 1, 16)/
     1   8,  1,  1,  4,  2,  0, 89, 87, 88, 86,  1,  1,  1,  1,  2,  4/
      DATA (ISETS(I, 28), I = 1, 15)/
     1   0,  1,  1,  3,  3,  0, 89, 87,107,  1,  1,  2,  2,  2,  4/
      DATA (ISETS(I, 29), I = 1, 7)/
     1   0,  1,  1,  0,  1,  0,  4/
      DATA (ISETS(I, 30), I = 1, 12)/
     1   0,  1,  1,  2,  2,  0, 89, 88,  1,  1,  2,  4/
      DATA (ISETS(I, 31), I = 1, 10)/
     1   0,  1,  1,  1,  2,  0,106,  1,  2,  4/
      DATA (ISETS(I, 32), I = 1, 12)/
     1   8,  1,  1,  2,  2,  0, 89, 87,  1,  1,  2,  4/
      DATA (ISETS(I, 33), I = 1, 7)/
     1   0,  1,  1,  0,  1,  0,  4/
      DATA (ISETS(I, 34), I = 1, 12)/
     1   8,  1,  1,  2,  2,  0, 89, 87,  1,  1,  2,  4/
      DATA (ISETS(I, 35), I = 1, 21)/
     1   8,  1,  1,  5,  5,  0, 89, 87, 90,103,106,  1,  1,  2,  3,  4,
     2   2,  4,  4,  4,  8/
      DATA (ISETS(I, 36), I = 1, 10)/
     1   0,  1,  1,  1,  2,  0,106,  1,  4,  8/
      DATA (ISETS(I, 37), I = 1, 15)/
     1   8,  1,  1,  3,  3,  0, 89, 87, 90,  1,  1,  2,  4,  4,  8/
      DATA (ISETS(I, 38), I = 1, 20)/
     1   0,  1,  1,  5,  4,  0, 89, 88,103,106,105,  1,  1,  2,  3,  3,
     2   2,  4,  4,  8/
      DATA (ISETS(I, 39), I = 1, 15)/
     1   0,  1,  1,  3,  3,  0, 89, 88,104,  1,  1,  2,  4,  4,  8/
      DATA (ISETS(I, 40), I = 1, 13)/
     1   0,  1,  1,  2,  3,  0, 89,107,  1,  2,  4,  4,  8/
      DATA (ISETS(I, 41), I = 1, 10)/
     1   0,  1,  1,  1,  2,  0, 89,  1,  4,  8/
      DATA (ISETS(I, 42), I = 1, 19)/
     1   8,  1,  1,  4,  5,  0, 89, 90,106,103,  1,  2,  3,  4,  4,  8,
     2   8,  8, 16/
      DATA (ISETS(I, 43), I = 1, 10)/
     1  11,  1,  3,  1,  2,  0, 89,  1,  8, 16/
      DATA (ISETS(I, 44), I = 1, 18)/
     1   8,  1,  1,  4,  4,  0, 89, 87,103,106,  1,  1,  2,  3,  2,  4,
     2   4,  8/
      DATA (ISETS(I, 45), I = 1, 12)/
     1   8,  1,  1,  2,  2,  0, 89, 87,  1,  1,  4,  8/
      DATA (ISETS(I, 46), I = 1, 13)/
     1   0,  1,  1,  2,  3,  0, 89,107,  1,  2,  4,  4,  8/
      DATA (ISETS(I, 47), I = 1, 66)/
     1   7,  1,  0, 26,  8,  0,  8,  5,  7,  3,  6,  4,  2,  1, 61, 60,
     2  59, 58, 78, 76, 77, 75, 89, 87, 88, 86,106,105,103,102,100, 99,
     3   1,  1,  1,  1,  1,  1,  1,  1,  2,  2,  2,  2,  3,  3,  3,  3,
     4   4,  4,  4,  4,  5,  5,  6,  6,  7,  7,  1,  2,  2,  2,  4,  4,
     5   4,  8/
      DATA (ISETS(I, 48), I = 1, 36)/
     1  -7,  1,  0, 12,  6,  1, 12, 14, 11, 13,  1,  8, 62, 64, 81, 83,
     2  90, 92,  1,  1,  1,  1,  2,  2,  3,  3,  4,  4,  5,  5,  2,  4,
     3   4,  4,  4,  8/
      DATA (ISETS(I, 49), I = 1, 47)/
     1   8,  1,  0, 17,  7,  0,  8,  4,  6,  5, 18, 17, 16, 15, 63, 65,
     2  80, 79, 89, 86, 87, 88,100,  1,  1,  1,  1,  2,  2,  2,  2,  3,
     3   3,  4,  4,  5,  5,  5,  5,  6,  2,  2,  4,  4,  4,  4,  8/
      DATA (ISETS(I, 50), I = 1, 36)/
     1  -8,  1,  0, 12,  6,  2, 22, 21, 20, 19,  8,  7, 67, 66, 82, 84,
     2  90, 92,  1,  1,  1,  1,  2,  2,  3,  3,  4,  4,  5,  5,  2,  4,
     3   4,  4,  4,  8/
      DATA (ISETS(I, 51), I = 1, 34)/
     1   0,  1,  0, 11,  6,  0,  8,  6,  7,  2, 94, 93, 78, 76,103,102,
     2 107,  1,  1,  1,  1,  2,  2,  3,  3,  4,  4,  5,  2,  2,  4,  4,
     3   4,  8/
      DATA (ISETS(I, 52), I = 1, 18)/
     1   0,  1,  0,  4,  4,  0,  8,  7, 94, 62,  1,  1,  2,  3,  4,  4,
     2   4,  8/
      DATA (ISETS(I, 53), I = 1, 27)/
     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/
      DATA (ISETS(I, 54), I = 1, 20)/
     1   0,  1,  0,  5,  4,  0,  8,  6, 80, 94, 93,  1,  1,  2,  3,  3,
     2   4,  4,  4,  8/
      DATA (ISETS(I, 55), I = 1, 26)/
     1   8,  1,  0,  8,  4,  0,  8,  7,  6,  2, 89, 87,100, 99,  1,  1,
     2   1,  1,  2,  2,  3,  3,  2,  4,  4,  8/
      DATA (ISETS(I, 56), I = 1, 17)/
     1   8,  1,  0,  4,  3,  0,  8,  7, 90, 92,  1,  1,  2,  2,  4,  4,
     2   8/
      DATA (ISETS(I, 57), I = 1, 18)/
     1   0,  1,  0,  4,  4,  0,  8,  5, 67,101,  1,  1,  2,  3,  4,  4,
     2   4,  8/
      DATA (ISETS(I, 58), I = 1, 24)/
     1   8,  1,  0,  7,  4,  0,  8,  7,  6,  2, 89, 87,100,  1,  1,  1,
     2   1,  2,  2,  3,  2,  4,  4,  8/
      DATA (ISETS(I, 59), I = 1, 23)/
     1  -8,  1,  0,  6,  5,  2, 90, 92,  8,  7,107,104,  1,  1,  2,  2,
     2   3,  4,  2,  4,  4,  4,  8/
      DATA (ISETS(I, 60), I = 1, 15)/
     1   0,  1,  0,  3,  3,  0,  8,  6, 80,  1,  1,  2,  4,  4,  8/
      DATA (ISETS(I, 61), I = 1, 12)/
     1  14,  1,  0,  2,  2,  0,  8,  7,  1,  1,  4,  8/
      DATA (ISETS(I, 62), I = 1, 15)/
     1   0,  1,  0,  3,  3,  0,  8,  7,104,  1,  1,  2,  4,  4,  8/
      DATA (ISETS(I, 63), I = 1, 27)/
     1   0,  1,  0,  7,  7,  0,  8,  6, 80, 22, 61,106,101,  1,  1,  2,
     2   3,  4,  5,  6,  4,  4,  8,  8,  8,  8, 16/
      DATA (ISETS(I, 64), I = 1, 24)/
     1   0,  1,  0,  6,  6,  0,  8,  5, 22, 61, 81,106,  1,  1,  2,  3,
     2   4,  5,  4,  8,  8,  8,  8, 16/
      DATA (ISETS(I, 65), I = 1, 50)/
     1   8,  1,  0, 17, 10,  0,  8,  5,  3,  7, 22, 19, 61, 60, 78, 76,
     2  89, 87, 90,106,103,100, 99,  1,  1,  1,  1,  2,  2,  3,  3,  4,
     3   4,  5,  5,  6,  7,  8,  9,  9,  2,  4,  4,  4,  4,  8,  8,  8,
     4   8, 16/
      DATA (ISETS(I, 66), I = 1, 39)/
     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/
      DATA (ISETS(I, 67), I = 1, 44)/
     1  12,  1,  0, 14, 10,  0, 24, 25,  8,  7, 22, 19, 91, 61, 60, 82,
     2  84, 94,106,104,  1,  1,  2,  2,  3,  3,  4,  5,  5,  6,  6,  7,
     3   8,  9,  4,  4,  4,  4,  8,  8,  8,  8,  8, 16/
      DATA (ISETS(I, 68), I = 1, 30)/
     1 -12,  1,  0,  8,  8,  3, 26, 27, 23,  8, 62, 80, 91, 94,  1,  1,
     2   2,  3,  4,  5,  6,  7,  4,  8,  8,  8,  8,  8,  8, 16/
      DATA (ISETS(I, 69), I = 1, 51)/
     1   7,  1,  0, 15, 15,  0,  8,  7, 26, 29, 22, 12, 61, 78, 89, 90,
     2  81, 62,106,103,100,  1,  1,  2,  3,  4,  5,  6,  7,  8,  9, 10,
     3  11, 12, 13, 14,  4,  8,  8,  8,  8,  8,  8,  8, 16, 16, 16, 16,
     4  16, 16, 32/
      DATA (ISETS(I, 70), I = 1, 26)/
     1 -13,  1,  0,  7,  6, 10, 28, 30,  8,  1, 68, 85, 95,  1,  1,  2,
     2   2,  3,  4,  5,  8, 16, 16, 16, 16, 32/
      DATA (ISETS(I, 71), I = 1, 43)/
     1   7,  1,  0, 14,  9,  0,  8,  2,  4,  3, 61, 59, 78, 76, 89, 88,
     2  12,106,103,100,  1,  1,  1,  1,  2,  2,  3,  3,  4,  4,  5,  6,
     3   7,  8,  2,  4,  4,  4,  8,  8,  8,  8, 16/
      DATA (ISETS(I, 72), I = 1, 34)/
     1   8,  1,  0, 10,  8,  0, 18, 17,  8,  5, 12, 63, 80, 89, 87,100,
     2   1,  1,  2,  2,  3,  4,  5,  6,  6,  7,  4,  4,  8,  8,  8,  8,
     3   8, 16/
      DATA (ISETS(I, 73), I = 1, 22)/
     1  10,  1,  0,  5,  6,  0,  8, 12, 63, 82, 91,  1,  2,  3,  4,  5,
     2   8,  8,  8,  8,  8, 16/
      DATA (ISETS(I, 74), I = 1, 32)/
     1  11,  1,  0,  9,  8,  0,  8,  7, 12, 11, 91, 61, 81,106,104,  1,
     2   1,  2,  2,  3,  4,  5,  6,  7,  4,  4,  4,  8,  8,  8,  8, 16/
      DATA (ISETS(I, 75), I = 1, 15)/
     1   0,  2,  1,  3,  3,  0, 89, 86, 87,  1,  1,  2,  1,  2,  4/
      DATA (ISETS(I, 76), I = 1, 7)/
     1   0,  2,  0,  0,  1,  0,  4/
      DATA (ISETS(I, 77), I = 1, 15)/
     1   0,  2,  1,  3,  3,  0, 89, 86, 87,  1,  1,  2,  2,  2,  4/
      DATA (ISETS(I, 78), I = 1, 7)/
     1  20,  2,  0,  0,  1,  0,  4/
      DATA (ISETS(I, 79), I = 1, 13)/
     1   0,  2,  1,  2,  3,  0, 89, 87,  1,  2,  2,  4,  8/
      DATA (ISETS(I, 80), I = 1, 10)/
     1   0,  5,  2,  1,  2,  0, 89,  1,  4,  8/
      DATA (ISETS(I, 81), I = 1, 24)/
     1   0,  6,  1,  7,  4,  0,  8,  7,  4,  1, 89, 86, 87,  1,  1,  1,
     2   1,  2,  2,  3,  1,  2,  2,  4/
      DATA (ISETS(I, 82), I = 1, 21)/
     1   0,  6,  1,  6,  3,  0,  8,  7, 16, 31, 89, 87,  1,  1,  1,  1,
     2   2,  2,  2,  4,  8/
      DATA (ISETS(I, 83), I = 1, 34)/
     1   0,  2,  0, 11,  6,  0,  8,  7,  4,  1,  6,  2, 89, 86, 87,100,
     2  99,  1,  1,  1,  1,  2,  2,  3,  3,  4,  5,  5,  1,  2,  2,  4,
     3   4,  8/
      DATA (ISETS(I, 84), I = 1, 33)/
     1   0,  2,  0, 10,  7,  0,  8,  4,  6,  2, 18, 15, 89, 86, 87,100,
     2   1,  1,  2,  2,  3,  3,  4,  4,  5,  6,  2,  2,  2,  4,  4,  4,
     3   8/
      DATA (ISETS(I, 85), I = 1, 23)/
     1  15,  5,  0,  6,  5,  4, 23, 32, 90,  8,  7, 92,  1,  1,  2,  3,
     2   3,  4,  2,  2,  4,  4,  8/
      DATA (ISETS(I, 86), I = 1, 23)/
     1  15,  5,  0,  6,  5,  5, 12, 11,  8,  7, 96, 90,  1,  1,  2,  2,
     2   3,  4,  2,  4,  4,  4,  8/
      DATA (ISETS(I, 87), I = 1, 30)/
     1   0,  2,  0,  8,  8,  0,  8,  7,  6, 16, 89, 12, 87,100,  1,  1,
     2   2,  3,  4,  5,  6,  7,  2,  4,  4,  4,  8,  8,  8, 16/
      DATA (ISETS(I, 88), I = 1, 20)/
     1  15,  4,  0,  5,  4,  9, 33, 34,  8,  7, 91,  1,  1,  2,  2,  3,
     2   4,  8,  8, 16/
      DATA (ISETS(I, 89), I = 1, 43)/
     1   0,  1,  1, 15,  7,  0,  8,  7,  4,  1,  5,  3, 89, 86, 87, -1,
     2  -2, 61, 58, 60, 59,  1,  1,  1,  1,  2,  2,  3,  3,  4,  5,  5,
     3   6,  6,  6,  6,  1,  2,  2,  4,  4,  4,  8/
      DATA (ISETS(I, 90), I = 1, 23)/
     1   0,  1,  1,  6,  5,  0,  8,  7, 87, 89, -1, -2,  1,  1,  2,  3,
     2   4,  4,  2,  2,  4,  4,  8/
      DATA (ISETS(I, 91), I = 1, 15)/
     1   0,  1,  0,  3,  3,  0, 78, 77, -5,  1,  1,  2,  4,  4,  8/
      DATA (ISETS(I, 92), I = 1, 10)/
     1   0,  1,  0,  1,  2,  0, -1,  1,  4,  8/
      DATA (ISETS(I, 93), I = 1, 44)/
     1   0,  1,  1, 15,  8,  0,  8,  4,  6,  2, 18, 15, 89, 86, 87, 61,
     2  58, 60, 59, -3, -4,  1,  1,  2,  2,  3,  3,  4,  4,  5,  6,  6,
     3   6,  6,  7,  7,  2,  2,  2,  4,  4,  4,  4,  8/
      DATA (ISETS(I, 94), I = 1, 23)/
     1   0,  1,  1,  6,  5,  0,  8,  7, 89, 87, -1, -2,  1,  1,  2,  3,
     2   4,  4,  2,  4,  4,  4,  8/
      DATA (ISETS(I, 95), I = 1, 15)/
     1  20,  1,  0,  3,  3,  0, 78, 77, -6,  1,  1,  2,  4,  4,  8/
      DATA (ISETS(I, 96), I = 1, 10)/
     1  20,  1,  0,  1,  2,  0, -1,  1,  4,  8/
      DATA (ISETS(I, 97), I = 1, 35)/
     1   0,  1,  1, 10,  9,  0,  8,  7,  6, 16, 89, 87, -1, 61, 60,-14,
     2   1,  1,  2,  3,  4,  5,  6,  7,  7,  8,  2,  4,  4,  4,  8,  8,
     3   8,  8, 16/
      DATA (ISETS(I, 98), I = 1, 23)/
     1   0,  1,  4,  6,  5,  0,  8,  7, 89, -1, -7, 69,  1,  1,  2,  3,
     2   3,  4,  4,  8,  8,  8, 16/
      DATA (ISETS(I, 99), I = 1, 23)/
     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/
      DATA (ISETS(I, 100), I = 1, 16)/
     1   0,  1,  1,  3,  4,  0, 89, 88,-38,  1,  2,  3,  2,  2,  4,  8/
      DATA (ISETS(I, 101), I = 1, 18)/
     1   0,  1,  1,  4,  4,  0, 89, 86, 87,-36,  1,  1,  2,  3,  2,  4,
     2   4,  8/
      DATA (ISETS(I, 102), I = 1, 16)/
     1   0,  1,  1,  3,  4,  0, 89, 87,-36,  1,  2,  3,  2,  4,  4,  8/
      DATA (ISETS(I, 103), I = 1, 15)/
     1   0,  1,  1,  3,  3,  0, 89, 86, 87,  1,  1,  2,  2,  4,  8/
      DATA (ISETS(I, 104), I = 1, 13)/
     1   0,  1,  1,  2,  3,  0, 89, 87,  1,  2,  2,  4,  8/
      DATA (ISETS(I, 105), I = 1, 20)/
     1   0,  1,  1,  5,  4,  0, 89, 86, 87,103,102,  1,  1,  2,  3,  3,
     2   2,  2,  4,  8/
      DATA (ISETS(I, 106), I = 1, 13)/
     1   0,  1,  1,  2,  3,  0, 89, 87,  1,  2,  4,  4,  8/
      DATA (ISETS(I, 107), I = 1, 19)/
     1   0,  1,  1,  4,  5,  0, 89, 87,-36,103,  1,  2,  3,  4,  2,  4,
     2   8,  8, 16/
      DATA (ISETS(I, 108), I = 1, 16)/
     1   0,  1,  1,  3,  4,  0, 89, 88,-38,  1,  2,  3,  4,  4,  8, 16/
      DATA (ISETS(I, 109), I = 1, 13)/
     1   0,  1,  2,  2,  3,  0, 89,106,  1,  2,  4,  8, 16/
      DATA (ISETS(I, 110), I = 1, 10)/
     1   0,  1,  2,  1,  2,  0, 89,  1,  8, 16/
      DATA (ISETS(I, 111), I = 1, 41)/
     1   0,  1,  1, 14,  7,  0,  8,  1,  7,  4,  5,  3, 89, 86, 61, 58,
     2  60, 59, 87,-36,  1,  1,  1,  1,  2,  2,  3,  3,  4,  4,  4,  4,
     3   5,  6,  1,  2,  2,  4,  4,  4,  8/
      DATA (ISETS(I, 112), I = 1, 39)/
     1   0,  1,  1, 13,  7,  0, 18, 17, 15, 16,  8,  4, 63, 79, 65, 80,
     2  89, 86, 87,  1,  2,  1,  2,  3,  3,  4,  4,  4,  4,  5,  5,  6,
     3   2,  2,  2,  4,  4,  4,  8/
      DATA (ISETS(I, 113), I = 1, 21)/
     1   0,  1,  1,  5,  5,  0,  8,  7, 87, 89,-38,  1,  1,  2,  3,  4,
     2   2,  2,  4,  4,  8/
      DATA (ISETS(I, 114), I = 1, 18)/
     1   0,  1,  1,  4,  4,  0,  8,  7, 89, 87,  1,  1,  2,  3,  2,  4,
     2   4,  8/
      DATA (ISETS(I, 115), I = 1, 34)/
     1   0,  1,  1, 11,  6,  0,  8,  4,  1,  7, 89, 86, 87, -1, -2,103,
     2 102,  1,  1,  1,  1,  2,  2,  3,  4,  4,  5,  5,  1,  2,  2,  4,
     3   4,  8/
      DATA (ISETS(I, 116), I = 1, 30)/
     1   0,  1,  1,  9,  6,  0, 18, 15,  8,  4, -3, -4, 89, 86, 87,  1,
     2   1,  2,  2,  3,  3,  4,  4,  5,  2,  2,  4,  4,  4,  8/
      DATA (ISETS(I, 117), I = 1, 28)/
     1   0,  1,  1,  8,  6,  0,  8,  7,  6,  2, 89, 87,-16,-15,  1,  1,
     2   2,  2,  3,  4,  5,  5,  2,  2,  4,  4,  4,  8/
      DATA (ISETS(I, 118), I = 1, 28)/
     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/
      DATA (ISETS(I, 119), I = 1, 29)/
     1   0,  1,  1,  9,  5,  0,  8,  7, 16, 31, 89, 87, -1,-14,103,  1,
     2   1,  1,  1,  2,  2,  3,  3,  4,  2,  4,  8,  8, 16/
      DATA (ISETS(I, 120), I = 1, 27)/
     1   0,  1,  1,  8,  5,  0, 18,  8, 16,  6, -3, 89, 87,-16,  1,  2,
     2   2,  1,  3,  4,  4,  3,  4,  4,  8,  8, 16/
      DATA (ISETS(I, 121), I = 1, 32)/
     1   0,  1,  1,  9,  8,  0,  8,  7,  6, 16, 89, 61, 60, 87,-36,  1,
     2   1,  2,  3,  4,  5,  5,  6,  7,  2,  4,  4,  4,  8,  8,  8, 16/
      DATA (ISETS(I, 122), I = 1, 18)/
     1   0,  1,  4,  4,  4,  0,  8,  7, 89, 69,  1,  1,  2,  3,  4,  8,
     2   8, 16/
      DATA (ISETS(I, 123), I = 1, 56)/
     1   0,  1,  0, 20, 10,  0,  8,  7,  4,  1,  2,  6, 89, 86, 87, -1,
     2  -2, 61, 60, 59, 58,100, 99,-36,103,102,  1,  1,  1,  1,  2,  2,
     3   3,  3,  4,  5,  5,  6,  6,  6,  6,  7,  7,  8,  9,  9,  1,  2,
     4   2,  4,  4,  4,  8,  8,  8, 16/
      DATA (ISETS(I, 124), I = 1, 42)/
     1   0,  1,  0, 13, 10,  0, 18,  8, 15,  4,  6, 16, 89, 86, 87, -3,
     2  63, 65,100,  1,  2,  1,  2,  3,  4,  5,  5,  6,  7,  8,  8,  9,
     3   2,  2,  4,  4,  4,  8,  8,  8,  8, 16/
      DATA (ISETS(I, 125), I = 1, 41)/
     1  15,  1,  0, 13,  9,  6, 22, 19, 21, 20,  8,  7, 90, 96, -1, -2,
     2  67, 66,-37,  1,  1,  2,  2,  3,  3,  4,  5,  6,  6,  7,  7,  8,
     3   2,  2,  4,  4,  4,  8,  8,  8, 16/
      DATA (ISETS(I, 126), I = 1, 35)/
     1  15,  1,  0, 10,  9,  5, 12, 11, 35, 23, 90,  8, 92, -3, 62, 70,
     2   1,  1,  2,  3,  4,  5,  6,  7,  8,  8,  2,  4,  4,  4,  8,  8,
     3   8,  8, 16/
      DATA (ISETS(I, 127), I = 1, 36)/
     1   0,  1,  0, 11,  8,  0,  8,  7,  2,  6, 89, 87,-16,-15,100, 99,
     2 -38,  1,  1,  2,  2,  3,  4,  5,  5,  6,  6,  7,  2,  2,  4,  4,
     3   4,  8,  8, 16/
      DATA (ISETS(I, 128), I = 1, 30)/
     1   0,  1,  0,  8,  8,  0,  8,  7,  6, 16, 89, 87,-14,100,  1,  1,
     2   2,  3,  4,  5,  6,  7,  2,  4,  4,  4,  8,  8,  8, 16/
      DATA (ISETS(I, 129), I = 1, 34)/
     1  15,  1,  0, 10,  8,  4, 21, 20, 90,  8,  7, 96, -7, -8,107,-36,
     2   1,  1,  2,  3,  3,  4,  5,  5,  6,  7,  2,  2,  4,  4,  8,  8,
     3   8, 16/
      DATA (ISETS(I, 130), I = 1, 25)/
     1  15,  1,  0,  6,  7,  4, 14, 21, 90,  8, 96, -9,  1,  2,  3,  4,
     2   5,  6,  4,  4,  4,  8,  8,  8, 16/
      DATA (ISETS(I, 131), I = 1, 50)/
     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/
      DATA (ISETS(I, 132), I = 1, 47)/
     1   0,  1,  0, 15, 11,  0,  8, 18,  4, 15, 16,  6, 89, 86, -1, -2,
     2  87, 63, 65,100,-36,  1,  2,  1,  2,  3,  4,  5,  5,  6,  6,  7,
     3   8,  8,  9, 10,  2,  2,  4,  4,  4,  4,  8,  8,  8,  8, 16/
      DATA (ISETS(I, 133), I = 1, 36)/
     1  15,  1,  0, 10, 10,  7, 22, 21, 12, 36,  8, 90, 96, 67, 66, -3,
     2   1,  2,  3,  4,  5,  6,  7,  8,  8,  9,  4,  4,  4,  4,  8,  8,
     3   8,  8,  8, 16/
      DATA (ISETS(I, 134), I = 1, 42)/
     1  15,  1,  0, 13, 10,  7, 13, 14, 12, 22,  7,  8, 96, 90, 64, 62,
     2  -1, -2,-37,  1,  1,  2,  3,  4,  4,  5,  6,  7,  7,  8,  8,  9,
     3   2,  4,  4,  4,  4,  8,  8,  8,  8, 16/
      DATA (ISETS(I, 135), I = 1, 31)/
     1   0,  1,  0,  8,  9,  0,  8, 18,  6, 16, 89, 87,-14,100,  1,  2,
     2   3,  4,  5,  6,  7,  8,  4,  4,  4,  4,  8,  8,  8,  8, 16/
      DATA (ISETS(I, 136), I = 1, 35)/
     1   0,  1,  0, 10,  9,  0,  8,  7,  6, 16, 89, -1, -7, 87,100,-36,
     2   1,  1,  2,  3,  4,  5,  5,  6,  7,  8,  2,  4,  4,  4,  4,  8,
     3   8,  8, 16/
      DATA (ISETS(I, 137), I = 1, 27)/
     1  15,  1,  0,  7,  7,  7, 36, 14, 96, 90,  8, -9,107,  1,  1,  2,
     2   3,  4,  5,  6,  2,  4,  4,  8,  8,  8, 16/
      DATA (ISETS(I, 138), I = 1, 32)/
     1  15,  1,  0,  9,  8,  7, 21, 36,  7,  8, 90, 96, -8, -7,-36,  1,
     2   2,  3,  3,  4,  5,  6,  6,  7,  4,  4,  4,  4,  8,  8,  8, 16/
      DATA (ISETS(I, 139), I = 1, 47)/
     1   0,  1,  0, 14, 13,  0,  8,  7,  6, 16, 89, 12, 87, -1, 61, 59,
     2 -14,100,-36,106,  1,  1,  2,  3,  4,  5,  6,  7,  8,  8,  9, 10,
     3  11, 12,  2,  4,  4,  4,  8,  8,  8,  8, 16, 16, 16, 16, 32/
      DATA (ISETS(I, 140), I = 1, 43)/
     1   0,  1,  0, 12, 13,  0, 18, 16,  8,  6, 12, 89, 87,-16, -3, 63,
     2 100,-38,  1,  2,  3,  4,  5,  6,  7,  8,  9, 10, 11, 12,  4,  4,
     3   4,  4,  8,  8,  8,  8, 16, 16, 16, 16, 32/
      DATA (ISETS(I, 141), I = 1, 29)/
     1  15,  1,  0,  8,  7,  8, 37, 38,  8,  7, 91, 61,-19,106,  1,  1,
     2   2,  2,  3,  4,  5,  6,  4,  8,  8, 16, 16, 16, 32/
      DATA (ISETS(I, 142), I = 1, 25)/
     1  15,  1,  0,  6,  7,  8, 38, 33,  8, 91, 63,-18,  1,  2,  3,  4,
     2   5,  6,  8,  8, 16, 16, 16, 16, 32/
      DATA (ISETS(I, 143), I = 1, 14)/
     1   0,  8,  1,  3,  2,  0, 89, 97, 98,  1,  1,  1,  1,  3/
      DATA (ISETS(I, 144), I = 1, 7)/
     1   0,  8,  0,  0,  1,  0,  3/
      DATA (ISETS(I, 145), I = 1, 7)/
     1  20,  8,  0,  0,  1,  0,  3/
      DATA (ISETS(I, 146), I = 1, 10)/
     1  16,  5,  1,  1,  2,  0, 89,  1,  3,  9/
      DATA (ISETS(I, 147), I = 1, 23)/
     1   0,  8,  0,  6,  5,  0,  8,  7, 89, 97,  5,  3,  1,  1,  2,  3,
     2   4,  4,  1,  2,  2,  3,  6/
      DATA (ISETS(I, 148), I = 1, 20)/
     1  16,  5,  0,  5,  4,  0,  8,  7, 89,  3,  5,  1,  1,  2,  3,  3,
     2   3,  6,  9, 18/
      DATA (ISETS(I, 149), I = 1, 32)/
     1   0,  3,  1, 11,  4,  0,  8,  7, 39, 40, 41, 42, 89, 97, 98, -7,
     2  -8,  1,  1,  1,  1,  1,  1,  2,  2,  2,  3,  3,  1,  2,  3,  6/
      DATA (ISETS(I, 150), I = 1, 23)/
     1   0,  3,  1,  6,  5,  0,  8,  7, 89, 97, 61, 60,  1,  1,  2,  3,
     2   4,  4,  1,  2,  2,  3,  6/
      DATA (ISETS(I, 151), I = 1, 12)/
     1   0,  3,  0,  2,  2,  0,-10,-13,  1,  1,  3,  6/
      DATA (ISETS(I, 152), I = 1, 12)/
     1   0,  3,  0,  2,  2,  0, 71, 72,  1,  1,  3,  6/
      DATA (ISETS(I, 153), I = 1, 12)/
     1  20,  3,  0,  2,  2,  0,-11,-12,  1,  1,  3,  6/
      DATA (ISETS(I, 154), I = 1, 12)/
     1  20,  3,  0,  2,  2,  0, 74, 73,  1,  1,  3,  6/
      DATA (ISETS(I, 155), I = 1, 20)/
     1  16,  1,  1,  5,  4,  0,  8,  7, 89, 61, 60,  1,  1,  2,  3,  3,
     2   3,  6,  9, 18/
      DATA (ISETS(I, 156), I = 1, 17)/
     1   0,  3,  1,  4,  3,  0, 89, 97, 98,-37,  1,  1,  1,  2,  1,  3,
     2   6/
      DATA (ISETS(I, 157), I = 1, 16)/
     1   0,  3,  1,  3,  4,  0, 89, 97,103,  1,  2,  3,  1,  2,  3,  6/
      DATA (ISETS(I, 158), I = 1, 14)/
     1   0,  3,  1,  3,  2,  0, 89, 97, 98,  1,  1,  1,  2,  6/
      DATA (ISETS(I, 159), I = 1, 13)/
     1   0,  3,  1,  2,  3,  0, 89, 97,  1,  2,  2,  2,  6/
      DATA (ISETS(I, 160), I = 1, 13)/
     1  16,  1,  1,  2,  3,  0, 89,-37,  1,  2,  3,  9, 18/
      DATA (ISETS(I, 161), I = 1, 10)/
     1  16,  1,  1,  1,  2,  0, 89,  1,  6, 18/
      DATA (ISETS(I, 162), I = 1, 36)/
     1   0,  3,  0, 11,  8,  0,  8,  7, 39, 40, 89,  5,  3, 97, -7, -8,
     2 103,  1,  1,  2,  2,  3,  4,  4,  5,  6,  6,  7,  1,  2,  2,  3,
     3   4,  6,  6, 12/
      DATA (ISETS(I, 163), I = 1, 30)/
     1   0,  3,  0,  8,  8,  0, 18,  8, 43, 44, 89, 97,  5, -9,  1,  2,
     2   3,  3,  4,  5,  6,  7,  2,  2,  2,  4,  4,  6,  6, 12/
      DATA (ISETS(I, 164), I = 1, 31)/
     1   0,  3,  0,  9,  7,  0,  8,  7, 89, 97,  5,  3, 61, 60,-37,  1,
     2   1,  2,  3,  4,  4,  5,  5,  6,  1,  2,  2,  3,  6,  6, 12/
      DATA (ISETS(I, 165), I = 1, 25)/
     1   0,  3,  0,  6,  7,  0, 18,  8, 89, 97,  5, 63,  1,  2,  3,  4,
     2   5,  6,  2,  2,  4,  4,  6,  6, 12/
      DATA (ISETS(I, 166), I = 1, 28)/
     1  16,  1,  0,  8,  6,  0,  8,  7, 89,  3,  5, 61, 60,-37,  1,  1,
     2   2,  3,  3,  4,  4,  5,  3,  6,  9, 18, 18, 36/
      DATA (ISETS(I, 167), I = 1, 22)/
     1  16,  1,  0,  5,  6,  0, 18,  8, 89,  5, 63,  1,  2,  3,  4,  5,
     2   6,  6, 12, 18, 18, 36/
      DATA (ISETS(I, 168), I = 1, 16)/
     1   0,  5,  1,  3,  4,  0, 89, 97, 88,  1,  2,  3,  1,  2,  3,  6/
      DATA (ISETS(I, 169), I = 1, 7)/
     1   0,  5,  0,  0,  1,  0,  6/
      DATA (ISETS(I, 170), I = 1, 7)/
     1  20,  5,  0,  0,  1,  0,  6/
      DATA (ISETS(I, 171), I = 1, 13)/
     1   0,  5,  0,  2,  3,  0, 89, 86,  1,  2,  3,  3,  6/
      DATA (ISETS(I, 172), I = 1, 13)/
     1  20,  5,  0,  2,  3,  0, 89, 86,  1,  2,  3,  3,  6/
      DATA (ISETS(I, 173), I = 1, 13)/
     1   0,  5,  1,  2,  3,  0, 89, 97,  1,  2,  2,  2,  6/
      DATA (ISETS(I, 174), I = 1, 32)/
     1   0,  6,  1, 11,  4,  0,  8,  7, 39, 40, 41, 42, 89, 97, 98,100,
     2  99,  1,  1,  1,  1,  1,  1,  2,  2,  2,  3,  3,  1,  2,  3,  6/
      DATA (ISETS(I, 175), I = 1, 36)/
     1   0,  5,  0, 11,  8,  0,  8,  7, 39, 40, 89,  5,  3, 97, 88,100,
     2  99,  1,  1,  2,  2,  3,  4,  4,  5,  6,  7,  7,  1,  2,  2,  3,
     3   4,  6,  6, 12/
      DATA (ISETS(I, 176), I = 1, 30)/
     1   0,  5,  0,  8,  8,  0, 18,  8, 43, 44, 89, 97,  5,101,  1,  2,
     2   3,  3,  4,  5,  6,  7,  2,  2,  2,  4,  4,  6,  6, 12/
      DATA (ISETS(I, 177), I = 1, 41)/
     1   0,  1,  1, 13,  9,  0,  8,  7, 39, 40, 89,  5,  3, 97, 88, 61,
     2  60, -7, -8,  1,  1,  2,  2,  3,  4,  4,  5,  6,  7,  7,  8,  8,
     3   1,  2,  2,  3,  4,  6,  6,  6, 12/
      DATA (ISETS(I, 178), I = 1, 13)/
     1   0,  1,  0,  2,  3,  0, 61,-22,  1,  2,  6,  6, 12/
      DATA (ISETS(I, 179), I = 1, 13)/
     1  20,  1,  0,  2,  3,  0, 61,-23,  1,  2,  6,  6, 12/
      DATA (ISETS(I, 180), I = 1, 33)/
     1   0,  1,  0, 10,  7,  0,  8,  7,  5,  3, 89, 88, 61, 60,-20,-21,
     2   1,  1,  2,  2,  3,  4,  5,  5,  6,  6,  3,  3,  6,  6,  6,  6,
     3  12/
      DATA (ISETS(I, 181), I = 1, 33)/
     1  20,  1,  0, 10,  7,  0,  8,  7,  5,  3, 89, 88, 61, 60,-20,-21,
     2   1,  1,  2,  2,  3,  4,  5,  5,  6,  6,  3,  3,  6,  6,  6,  6,
     3  12/
      DATA (ISETS(I, 182), I = 1, 30)/
     1   0,  1,  1,  8,  8,  0,  8, 18, 43, 45, 89, 97, 61,-22,  1,  2,
     2   3,  3,  4,  5,  6,  7,  2,  2,  2,  4,  4,  6,  6, 12/
      DATA (ISETS(I, 183), I = 1, 22)/
     1   0,  1,  1,  5,  6,  0, 89, 97, 88,103,-37,  1,  2,  3,  4,  5,
     2   1,  2,  3,  6,  6, 12/
      DATA (ISETS(I, 184), I = 1, 16)/
     1   0,  1,  1,  3,  4,  0, 89, 97, 88,  1,  2,  3,  2,  4,  6, 12/
      DATA (ISETS(I, 185), I = 1, 16)/
     1   0,  1,  1,  3,  4,  0, 89, 97,103,  1,  2,  3,  2,  4,  6, 12/
      DATA (ISETS(I, 186), I = 1, 16)/
     1   0,  1,  1,  3,  4,  0, 89, 97,-37,  1,  2,  3,  2,  2,  6, 12/
      DATA (ISETS(I, 187), I = 1, 40)/
     1   0,  1,  1, 14,  6,  0,  8,  7, 39, 40, 41, 42, 89, 97, 98, -7,
     2  -8,100, 99,-37,  1,  1,  1,  1,  1,  1,  2,  2,  2,  3,  3,  4,
     3   4,  5,  1,  2,  3,  6,  6, 12/
      DATA (ISETS(I, 188), I = 1, 34)/
     1   0,  1,  1, 11,  6,  0,  8, 18, 39, 43, 41, 44, 89, 97, 98, -7,
     2 101,  1,  2,  1,  2,  1,  2,  3,  3,  3,  4,  5,  2,  2,  4,  6,
     3   6, 12/
      DATA (ISETS(I, 189), I = 1, 36)/
     1   0,  1,  1, 11,  8,  0,  8,  7, 39, 40, 89, 61, 60, 97,103,100,
     2  99,  1,  1,  2,  2,  3,  4,  4,  5,  6,  7,  7,  1,  2,  2,  3,
     3   4,  6,  6, 12/
      DATA (ISETS(I, 190), I = 1, 30)/
     1   0,  1,  1,  8,  8,  0,  8, 18, 43, 44, 89, 97, 61,101,  1,  2,
     2   3,  3,  4,  5,  6,  7,  2,  2,  2,  4,  4,  6,  6, 12/
      DATA (ISETS(I, 191), I = 1, 52)/
     1   0,  1,  0, 17, 12,  0,  8,  7, 39, 40, 89,  5,  3, 97, 88, 61,
     2  60,-20,-21,103,-39,100, 99,  1,  1,  2,  2,  3,  4,  4,  5,  6,
     3   7,  7,  8,  8,  9, 10, 11, 11,  1,  2,  2,  3,  4,  6,  6,  6,
     4  12, 12, 12, 24/
      DATA (ISETS(I, 192), I = 1, 43)/
     1   0,  1,  0, 12, 13,  0, 18,  8, 43, 39, 89, 17,  5, 97, 88, 63,
     2 -22,100,  1,  2,  3,  4,  5,  6,  7,  8,  9, 10, 11, 12,  2,  2,
     3   4,  4,  4,  6,  6,  8, 12, 12, 12, 12, 24/
      DATA (ISETS(I, 193), I = 1, 40)/
     1   0,  1,  0, 11, 12,  0, 18,  8, 43, 39, 89,  5, 63, 97,-20,101,
     2 103,  1,  2,  3,  4,  5,  6,  7,  8,  9, 10, 11,  2,  2,  4,  4,
     3   4,  6,  6,  8, 12, 12, 12, 24/
      DATA (ISETS(I, 194), I = 1, 39)/
     1   0,  1,  0, 11, 11,  0,  8, 18, 43, 45, 89, 97,  5,-22, 61,101,
     2 -39,  1,  2,  3,  3,  4,  5,  6,  7,  8,  9, 10,  2,  2,  2,  4,
     3   4,  6,  6, 12, 12, 12, 24/
      DATA (ISETS(I, 195), I = 1, 30)/
     1   0,  5,  1,  9,  6,  0,  8,  1,  2,  5,-35, 61, 60, 59, 58,  1,
     2   1,  2,  2,  3,  4,  5,  5,  4,  1,  3,  4,  6,  6, 12/
      DATA (ISETS(I, 196), I = 1, 24)/
     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/
      DATA (ISETS(I, 197), I = 1, 22)/
     1   0,  5,  1,  5,  6,  0,  8,  2,-35, 61, 59,  1,  2,  3,  4,  5,
     2   2,  6,  8, 12, 12, 24/
      DATA (ISETS(I, 198), I = 1, 10)/
     1   0,  7,  1,  1,  2,  0,-35,  1,  4, 12/
      DATA (ISETS(I, 199), I = 1, 13)/
     1   0,  7,  1,  2,  3,  0,-35, 63,  1,  2,  8, 12, 24/
      DATA (ISETS(I, 200), I = 1, 35)/
     1   0,  5,  0, 11,  7,  0,  8,  1,  2,  5, 61, 60, 59, 58,-35,106,
     2 105,  1,  1,  2,  2,  3,  4,  4,  3,  5,  6,  6,  1,  3,  6,  6,
     3   8, 12, 24/
      DATA (ISETS(I, 201), I = 1, 27)/
     1  15,  6,  0,  7,  7,  5, 12,  8,  1, 35,-35, 62, 70,  1,  2,  2,
     2   3,  4,  5,  6,  2,  4,  6,  8, 12, 12, 24/
      DATA (ISETS(I, 202), I = 1, 30)/
     1   0,  5,  0,  8,  8,  0,  8,  1, 12, 26, 61,-35, 62,106,  1,  1,
     2   2,  3,  4,  5,  6,  7,  4,  8, 24, 24, 32, 48, 48, 96/
      DATA (ISETS(I, 203), I = 1, 23)/
     1  15,  6,  0,  6,  5, 10, 28, 47,  8,  1,-35, 68,  1,  1,  2,  2,
     2   3,  4,  8, 16, 32, 48, 96/
      DATA (ISETS(I, 204), I = 1, 28)/
     1   0,  5,  0,  7,  8,  0,  8,  2, 12, 61, 60,-35,106,  1,  2,  3,
     2   4,  5,  6,  7,  2,  6,  8, 12, 12, 16, 24, 48/
      DATA (ISETS(I, 205), I = 1, 15)/
     1   0,  1,  0,  3,  3,  0,  8,  1,-35,  1,  1,  2,  4,  8, 24/
      DATA (ISETS(I, 206), I = 1, 18)/
     1   0,  7,  0,  4,  4,  0,  8, 12,-35, 63,  1,  1,  2,  3,  8, 16,
     2  24, 48/
      DATA (ISETS(I, 207), I = 1, 33)/
     1   0,  1,  1, 10,  7,  0,  8,  1,  2,  5, 61, 58,-35, 59,-24,-25,
     2   1,  1,  2,  2,  3,  3,  4,  5,  6,  6,  1,  3,  6,  8, 12, 12,
     3  24/
      DATA (ISETS(I, 208), I = 1, 39)/
     1   0,  1,  1, 12,  9,  0,  8, 12, 46,  2, 25, 48,-35, 61, 60, 59,
     2 -30,-29,  1,  2,  2,  3,  4,  4,  5,  6,  7,  7,  8,  8,  2,  4,
     3   6,  6,  8, 12, 12, 12, 24/
      DATA (ISETS(I, 209), I = 1, 32)/
     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/
      DATA (ISETS(I, 210), I = 1, 26)/
     1   0,  1,  3,  7,  6,  0,  8,  1, 28, 47,-35, 61,-34,  1,  1,  2,
     2   2,  3,  4,  5,  8, 16, 32, 48, 48, 96/
      DATA (ISETS(I, 211), I = 1, 34)/
     1   0,  1,  1,  9, 10,  0,  8,  2, 12, 48, 61,-35, 59,-24,-30,  1,
     2   2,  3,  4,  5,  6,  7,  8,  9,  2,  6,  8, 12, 12, 16, 24, 24,
     3  24, 48/
      DATA (ISETS(I, 212), I = 1, 18)/
     1  20,  1,  0,  4,  4,  0, 28, 47,-35,-34,  1,  1,  2,  3,  4,  8,
     2  12, 24/
      DATA (ISETS(I, 213), I = 1, 18)/
     1   0,  1,  0,  4,  4,  0, 49, 50,-35,-33,  1,  1,  2,  3,  4,  8,
     2  12, 24/
      DATA (ISETS(I, 214), I = 1, 28)/
     1   0,  1,  1,  8,  6,  0, 28, 50, 51, 52,-35, 63,-33,-34,  1,  1,
     2   2,  2,  3,  4,  5,  5,  8, 12, 16, 24, 24, 48/
      DATA (ISETS(I, 215), I = 1, 31)/
     1   0,  1,  1,  9,  7,  0,  8,  1,  2,  5,-35, 61, 58, 59,-36,  1,
     2   1,  2,  2,  3,  4,  4,  5,  6,  1,  3,  4,  6, 12, 12, 24/
      DATA (ISETS(I, 216), I = 1, 27)/
     1   0,  1,  1,  8,  5,  0,  8,  1, 12, 46,-35, 61, 62,-36,  1,  1,
     2   1,  1,  2,  3,  3,  4,  4, 16, 24, 48, 96/
      DATA (ISETS(I, 217), I = 1, 28)/
     1   0,  1,  1,  7,  8,  0,  8,  2,-35, 48, 61, 59,-36,  1,  2,  3,
     2   4,  5,  6,  7,  2,  6,  8, 12, 12, 24, 24, 48/
      DATA (ISETS(I, 218), I = 1, 29)/
     1   0,  1,  1,  8,  7,  0,  8,  2, 48, 25,-35, 61, 59, 60,  1,  2,
     2   3,  3,  4,  5,  6,  6,  2,  6,  6,  8, 12, 12, 24/
      DATA (ISETS(I, 219), I = 1, 25)/
     1   0,  1,  1,  7,  5,  0,  8, 12, 26, 24,-35, 61, 62,  1,  1,  2,
     2   2,  3,  4,  4,  8, 24, 32, 48, 96/
      DATA (ISETS(I, 220), I = 1, 18)/
     1   0,  1,  1,  4,  4,  0, 53, 54,-35, 63,  1,  1,  2,  3, 12, 16,
     2  24, 48/
      DATA (ISETS(I, 221), I = 1, 41)/
     1   0,  1,  0, 13,  9,  0,  8,  1,  2,  5, 61, 58,-35, 59,-24,-25,
     2 106,105,-36,  1,  1,  2,  2,  3,  3,  4,  5,  6,  6,  7,  7,  8,
     3   1,  3,  6,  8, 12, 12, 24, 24, 48/
      DATA (ISETS(I, 222), I = 1, 31)/
     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/
      DATA (ISETS(I, 223), I = 1, 38)/
     1   0,  1,  0, 11, 10,  0,  8,  2, 25, 48, 12, 61, 60, 59,-35,-29,
     2 106,  1,  2,  3,  3,  4,  5,  6,  6,  7,  8,  9,  2,  6,  6,  8,
     3  12, 12, 16, 24, 24, 48/
      DATA (ISETS(I, 224), I = 1, 38)/
     1  15,  1,  0, 11, 10,  5, 12,  8,  1, 35,-35, 56, 62, 64,-32,-31,
     2 -36,  1,  2,  2,  3,  4,  5,  6,  7,  8,  8,  9,  2,  4,  6,  8,
     3  12, 12, 24, 24, 24, 48/
      DATA (ISETS(I, 225), I = 1, 38)/
     1   0,  1,  0, 11, 10,  0,  8,  1, 12, 26, 61,-35, 62,-24,-25,106,
     2 -36,  1,  1,  2,  3,  4,  5,  6,  7,  7,  8,  9,  4,  8, 24, 24,
     3  32, 48, 48, 96, 96,192/
      DATA (ISETS(I, 226), I = 1, 34)/
     1   0,  1,  0,  9, 10,  0, 12,  8, 24, 26, 61, 62,-35,-26,106,  1,
     2   2,  3,  4,  5,  6,  7,  8,  9,  8,  8, 24, 24, 48, 48, 64, 96,
     3  96,192/
      DATA (ISETS(I, 227), I = 1, 29)/
     1  15,  1,  0,  8,  7, 10, 28, 49,  8,  1,-35, 68,-36,-27,  1,  1,
     2   2,  2,  3,  4,  5,  6,  8, 16, 32, 48, 96, 96,192/
      DATA (ISETS(I, 228), I = 1, 28)/
     1  15,  1,  0,  7,  8, 11, 28, 12,  8, 57,-35, 68,-28,  1,  2,  3,
     2   4,  5,  6,  7, 16, 32, 32, 48, 64, 96, 96,192/
      DATA (ISETS(I, 229), I = 1, 40)/
     1   0,  1,  0, 11, 12,  0,  8,  2, 12, 25, 61,-35, 60,-24,-30,106,
     2 -36,  1,  2,  3,  4,  5,  6,  7,  8,  9, 10, 11,  2,  6,  8, 12,
     3  12, 16, 24, 24, 48, 48, 48, 96/
      DATA (ISETS(I, 230), I = 1, 28)/
     1   0,  1,  0,  7,  8,  0,  8, 28, 51, 53,-35, 63,-34,  1,  2,  3,
     2   4,  5,  6,  7, 16, 16, 24, 24, 32, 48, 48, 96/
      DATA TYPE /
     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'/
      DATA NLAUE /
     1 '   -1', '  2/m', '  mmm', '  4/m', '4/mmm', '   -3', ' -3m1',
     2 ' -31m', '  6/m', '6/mmm', '  m-3', ' m-3m', '     '/
      DATA TRTYP /'ABC  ', 'BA-C ', 'CAB  ', '-CBA ', 'BCA  ',
     1            'A-CB ', 'C-BA ', 'A-B-N'/
      DATA (((TRDAT(I, J, K), J = 1, 3), I = 1, 3), K = 1, 8) /
     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, 1.0, 0.0, 0.0,  0.0, 1.0,  1.0,  0.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, 0.0, 1.0, 1.0,  0.0, 0.0,  0.0,  1.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, 0.0, 0.0, -1.0, 0.0, -1.0,  0.0, -1.0/
      DATA BWCT/
     1 'CONTOUR   ', 'NET       ', 'SHADE     ', 'SEGMENT   ',
     2 'DOTS      ', 'BLACK     ', 'CROSS     ', 'GLOBE     ',
     3 'PARALLEL  ', 'MERIDIAN  ', 'HORIZONTAL', 'VERTICAL  ',
     4 'MESH      ', 'DIAGONAL  ', 'SLANT     ', 'TEXTILE   ',
     5 'VOID      '/
      DATA COLR/
     1 'BLACK     ', 'RED       ', 'GREEN     ', 'BLUE      ',
     2 'YELLOW    ', 'ORANGE    ', 'VIOLET    ', 'BROWN     ',
     3 'COPPER    ', 'BRASS     ', 'BRONZE    ', 'SILVER    ',
     4 'QUARTZ    ', 'GOLD      ', 'MICA      ', 'STEELBLUE ',
     5 'VOID      '/
      DATA RGB/
     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/
C * KEYWORDS (PLUTON)
      DATA (CRD(I), I = 1, 151) /
     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'/
      DATA (CRD(I), I = 152, NP37)/
     1 'FSUM', 'SCAL', 'CRYS', 'CALC', 'REN ', 'LAB ', 'DEL ', 'CONF',
     2 'VIE ', 'SOL ', 'STI ', 'UNL ', 'INC ', 'EXC ', 'UNI ', 'PAC ',
     3 'SCAT', 'FIT ', '    ', '    ', '    ', '    ', '    ', '    '/
      DATA (LABP(I), I = 1, 16) /
     1 '  ', 'AU', 'E ', 'NE', 'N ', 'NW', 'W ', 'SW', 'S ', 'SE',
     2 'NU', '  ', '  ', '  ', '  ', 'MS'/
      DATA NCNT /0/
      DATA MENX /
     1 'ORTEP  MENU', 'PLUTON MENU', 'Contents MU', 'Style  MENU',
     2 'View   MENU', 'GeomTy MENU', 'Aux    MENU', 'ORT_SP1MENU',
     3 'ORT_SP2MENU', 'PLATON MENU', 'PLA-SP1MENU', 'PLA-SP2MENU',
     4 'GEOM   MENU', 'ASYM   MENU', 'HELENA MENU', 'ABSCOR MENU',
     5 'SYSTEM - S ', 'S-SUB  MENU', 'S-SHXL MENU', 'LEPAGE MENU',
     6 'POWDER MENU', 'ContourMENU', 'CON-SupMENU', 'SOLV   MENU',
     7 'TwRoMt MENU', 'ADDSYM MENU', 'S/EXOR MENU', 'RDF    MENU',
     8 'BIJVOETMENU', 'POLYHN MENU'/
      DATA (CMEN(I), I = 1, 72) /
     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    '/
      DATA (CMEN(I), I = 73, 144) /
     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-TNCP ', '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 HGL TEK', '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'/
      DATA (CMEN(I), I = 145, 216) /
     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', 'FORMULA   Z', 'SHS SHP SHD', 'DIRDIF ORNT',
     7 'S86 SIR SR2', 'EXOR  /S /D', 'SHELXL-ISO ', 'SHELXL-ANIS',
     8 'DELABS MULA', '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', 'MOGLI-DGE  ',
     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 ', 'CSD-Search ', 'ListFlags  ', 'BondTaper> '/
      DATA (CMEN(I), I = 217, 288) /
     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', 'LstAtomsUij',
     * 'LineWidth  ', '<VertScale>', 'ScaleDegree', 'LstFlagRadi',
     1 'RemoveTree ', '           ', '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'/
      DATA (CMEN(I), I = 289, 360) /
     1 'MinDistCrit', 'LtReference', 'CoordRadDef', 'UnitFill   ',
     2 'ColorType  ', 'UnitSymPack', 'AutoEXTIref', 'RoundCell  ',
     3 'DspTwinMat1', 'DspTwinMat2', 'DspTwinMat3', 'DspTwinMat4',
     4 'HKLF5-Gener', 'Merg 4     ', 'Lambda     ', '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', 'Displ-Theta', '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  '/
      DATA (CMEN(I), I = 361, NP40) /
     1 'PolyShade  ', 'FCF-Calc   ', '           ', '           ',
     2 '           ', '           ', '           ', '           ',
     3 '           ', '           ', '           ', '           ',
     4 '           ', '           ', '           ', '           ',
     5 '           ', '           ', '           ', '           '/
      DATA (MENS(I, 1), I = 1, 25) /
     1      4803, 2, 1, 1, 409, 1, 3503, 3603, 5603, 605, 1, 1502, 1,
     2      508, 1, 1, 100, 9, 10, 10, 10, 2, 1, 2302, 2/
      DATA (MENS(I, 2), I = 1, 25) /
     1      1106, 4, 1, 2405, 1, 2, 1, 1, 203, 605, 1, 508, 1, 100,
     2      2, 707, 1502, 9, 10, 10, 10, 303, 1, 3, 2/
      DATA (MENS(I, 3), I = 1, 25) /
     1      1106, 1, 1, 1, 1410, 1, 1, 1, 1, 1, 6602, 1, 7308, 100,
     2      9002, 605, 1502, 9, 10, 10, 10, 1, 1, 1, 2/
      DATA (MENS(I, 4), I = 1, 25) /
     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/
      DATA (MENS(I, 5), I = 1, 25) /
     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/
      DATA (MENS(I, 6), I = 1, 25) /
     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/
      DATA (MENS(I, 7), I = 1, 25) /
     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/
      DATA (MENS(I, 8), I = 1, 25) /
     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/
      DATA (MENS(I, 9), I = 1, 25) /
     1      4803, 1, 6602, 1, 1, 1, 1, 3703, 3703, 5203, 1, 1,
     2      2, 2, 2, 1, 100, 1, 10, 10, 10, 2, 7503, 3903, 2/
      DATA (MENS(I, 10), I = 1, 25) /
     1      8603, 1, 6602, 1, 2604, 1, 1, 1, 1, 1, 1, 2, 2,
     2      1, 1, 2, 1, 8705, 8805, 2, 1, 2, 1, 1, 2/
      DATA (MENS(I, 11), I = 1, 25) /
     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/
      DATA (MENS(I, 12), I = 1, 25) /
     1      8603, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
     2      1, 1, 1, 5404, 1, 2105, 1, 1203, 1, 1, 1, 1, 2/
      DATA (MENS(I, 13), I = 1, 25) /
     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/
      DATA (MENS(I, 14), I = 1, 25) /
     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/
      DATA (MENS(I, 15), I = 1, 25) /
     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/
      DATA (MENS(I, 16), I = 1, 25) /
     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/
      DATA (MENS(I, 17), I = 1, 25) /
     1      4003, 3, 2, 3, 2, 2, 3, 2, 3, 3, 6, 6,
     2      1, 2, 6, 6, 2, 2, 2, 2, 2, 2, 2, 1, 2/
      DATA (MENS(I, 18), I = 1, 25) /
     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/
      DATA (MENS(I, 19), I = 1, 25) /
     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/
      DATA (MENS(I, 20), I = 1, 25) /
     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/
      DATA (MENS(I, 21), I = 1, 25) /
     1   4904,    1, 4605, 5005, 6105, 4505, 1, 1, 1, 1, 1, 1,
     2      1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1/
      DATA (MENS(I, 22), I = 1, 25) /
     1      1   ,6304,6304,6304,6304,1,1,1,1,1603, 2006, 1705,
     2      6, 6, 6, 1, 1502, 1805, 1908, 1, 5503, 1, 1, 2, 2/
      DATA (MENS(I, 23), I = 1, 25) /
     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/
      DATA (MENS(I, 24), I = 1, 25) /
     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/
      DATA (MENS(I, 25), I = 1, 25) /
     1      8406, 8206, 9405, 8305, 1, 1, 1, 1, 1, 1, 1, 9207,
     2      1, 1, 10103, 2, 1, 1,  1, 1, 1, 8506, 9305, 1, 1/
      DATA (MENS(I, 26), I = 1, 25) /
     1      7704, 7806, 7906, 8006, 8106, 1, 1, 1, 1, 1, 1, 1,
     2      1, 1, 1, 1, 1, 1, 1, 1, 8900, 1, 1, 1, 1/
      DATA (MENS(I, 27), I = 1, 25) /
     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/
      DATA (MENS(I, 28), I = 1, 25) /
     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/
      DATA (MENS(I, 29), I = 1, 25) /
     1      10006, 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/
      DATA (MENS(I, 30), I = 1, 25) /
     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/
      DATA (MENU(I, 1), I = 1, 50) /
     1 37, 17,  2,  8, 38,217,219,220,271, 22, 64, 11, 10, 12,141,
     2142, 14, 18, 19, 20, 21,251, 23,148, 53, 37, 34,502,508, 38,
     3717,719,720,771, 22,564,511,510, 32,641,642, 14, 18, 19, 20,
     4 21,251,523,148, 53/
      DATA (MENU(I, 2), I = 1, 50) /
     1 37, 17,  2,  4,  5,  6,  7,528,  3, 22, 58, 12, 13, 14, 15,
     2 16, 11, 18, 19, 20, 21, 99, 23, 24, 59, 37, 34,502,504,505,
     3506,507, 28,503, 22,558, 12,513, 14, 15, 16,511, 18, 19, 20,
     4 21,599,523, 24, 59/
      DATA (MENU(I, 3), I = 1, 50) /
     1537, 48, 50, 52, 54, 69,100,  8,  9, 10, 26, 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,526,566, 68, 14,535, 22,511, 18, 19, 20,
     4 21,734,593,701, 59/
      DATA (MENU(I, 4), I = 1, 50) /
     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/
      DATA (MENU(I, 5), I = 1, 50) /
     1537, 71, 72, 73, 74, 75, 83, 84, 85, 86, 87, 88, 89, 14,188,
     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,188,  1,511,  1, 19, 20,
     4 21,599,523, 24, 59/
      DATA (MENU(I, 6), I = 1, 50) /
     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/
      DATA (MENU(I, 7), I = 1, 50) /
     1537,269,276, 30,324,218, 27,284,  1,321, 91,242,326,325,305,
     2532,153,280,243,289, 96,686,251, 49, 59, 37,769,276,530,824,
     3718,527,784,  1,  1,591,242,326,325,305, 32,653,780,743,289,
     4596,186,251,549, 59/
      DATA (MENU(I, 8), I = 1, 50) /
     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/
      DATA (MENU(I, 9), I = 1, 50) /
     1537,243, 26,290,324,270,241,232,187,265,351,275,250,252,256,
     2 82, 14,280, 19, 20, 21,251,304,233, 53,537,743,526,790,824,
     3770,741,732,187,265,851,275,250,252,256, 82, 14,780, 19, 20,
     4 21,251,804,733, 53/
      DATA (MENU(I, 10), I = 1, 50) /
     1 37, 27, 26, 30, 31, 32,241,124,140,101,231,279,250, 78, 79,
     2256,  1,318,319,320,321,251,145, 49, 59, 37,527,526,530,531,
     3532,741,624,640,601,731,279,750, 78, 79,256,  1,318,319,820,
     4321,251,645,549, 59/
      DATA (MENU(I, 11), I = 1, 50) /
     1537,237,855,247,261,262,264,266,138,265,350,149,156, 29,358,
     2  1,291,  1,  1,289,  1,283,281,  1, 59,537,737,355,747,761,
     3762,764,766,638,265,850,649,656,529,858,  1,291,  1,  1,289,
     4  1,283,281,  1, 59/
      DATA (MENU(I, 12), I = 1, 50) /
     1537,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,362,345,249,267,
     2268,153,144,143,627, 91,243,280,147, 59,537,  1,  1,  1,  1,
     3  1,  1,  1,  1,  1,  1,862,845,749,767,768,653,644,643,127,
     4591,743,780,647, 59/
      DATA (MENU(I, 13), I = 1, 50) /
     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/
      DATA (MENU(I, 14), I = 1, 50) /
     1  1,109,110,111,  1,128,108,112,  1,122,123,  1,125,  1,134,
     2272,  1,103,  1,  1,  1,  1, 23,  1,104,  1,609,610,611,  1,
     3628,608,612,  1,122,123,  1,625,  1,634,272,  1,103,  1,  1,
     4  1,  1,523,  1,104/
      DATA (MENU(I, 15), I = 1, 50) /
     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/
      DATA (MENU(I, 16), I = 1, 50) /
     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/
      DATA (MENU(I, 17), I = 1, 50) /
     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/
      DATA (MENU(I, 18), I = 1, 50) /
     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/
      DATA (MENU(I, 19), I = 1, 50) /
     1537,193,213,  1,  1,212,  1,302,204,295,853,  1,  1,  1,267,
     2  1,  1,280,240,  1,357,238,239,183,184,537,693,213,  1,  1,
     3212,  1,802,704,795,353,  1,  1,  1,767,  1,  1,780,240,  1,
     4357,238,239,183,184/
      DATA (MENU(I, 20), I = 1, 50) /
     1210,211,244,278,245,296,  1,  1,  1,  1,  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,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,
     4  1,  1,  1,126, 25/
      DATA (MENU(I, 21), I = 1, 50) /
     1209,303,254,260,277,253,  1,  1,  1,  1,  1,  1,  1,  1,  1,
     2  1,  1,  1,  1,  1,334,335, 23, 44, 25,209,803,254,260,277,
     3253,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,
     4834,835,523, 44, 25/
      DATA (MENU(I, 22), I = 1, 50) /
     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/
      DATA (MENU(I, 23), I = 1, 50) /
     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/
      DATA (MENU(I, 24), I = 1, 50) /
     1  1, 17,288, 73, 74, 75,  1,  1,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,  1,  1,794, 14,792,287,513,786,785,592,511, 12, 19, 20,
     4 21,564,523, 44, 25/
      DATA (MENU(I, 25), I = 1, 50) /
     1316,314,332,315,328,343,297,298,299,300,327, 95,  1,  1,356,
     2103,344,336,337,338,339,317,331,301, 25,316,314,332,315,828,
     3343,797,798,799,800,327, 95,609,610,611,103,844,836,837,838,
     4839,317,331,301, 25/
      DATA (MENU(I, 26), I = 1, 50) /
     1309,310,311,312,313,230,  1,  1,263,333,  1,  1,  1,  1,  1,
     2  1,  1,  1,322,329,323,308,306,307, 25,309,310,311,312,313,
     3730,  1,  1,763,833,  1,  1,  1,  1,  1,  1,  1,  1,822,329,
     4323,308,306,307, 25/
      DATA (MENU(I, 27), I = 1, 50) /
     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/
      DATA (MENU(I, 28), I = 1, 50) /
     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/
      DATA (MENU(I, 29), I = 1, 50) /
     1349,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,359,
     2  1,  1,  1,  1,  1,  1,  1,  1, 44, 25,349,  1,  1,  1,  1,
     3  1,  1,  1,  1,  1,  1,  1,  1,  1,859,  1,  1,  1,  1,  1,
     4  1,  1,  1, 44, 25/
      DATA (MENU(I, 30), I = 1, 50) /
     1  1, 64,276,  1,  1,  1,  1,  1,  1, 22,360,361, 13,  1,  1,
     2 16, 93,  1, 19, 20, 21,  1, 23,148, 25,  1,564,776,  1,  1,
     3  1,  1,  1,  1, 22,860,861,513,  1,  1, 16,593,  1, 19, 20,
     4 21,  1,523,148, 25/
      DATA (MENA(I, 1), I = 1, 25) /
     1   0, 116, 212, 351,   0, 440, 341, 311, 508,   0,
     2 346, -75, 349,   0, 327, 328,   0,   0,   0,   0,
     3   0,   1,-103,   0,   0/
      DATA (MENA(I, 2), I = 1, 25) /
     1   0, 116, 212,1004,2004,3004,4004,   4, 345,   0,
     21341,   0,  46,   0,   0,   0, -75,   0,   0,   0,
     3   0, 346,-103,   0,   0/
      DATA (MENA(I, 3), I = 1, 25) /
     1   0, 173, 453, 448,   0, 344, 334, 351, 335, 349,
     2 -59, 343,   0,   0,   0,   0, -75, 105,   0,   0,
     3   0, 213, 141, 105,   0/
      DATA (MENA(I, 4), I = 1, 25) /
     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/
      DATA (MENA(I, 5), I = 1, 25) /
     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/
      DATA (MENA(I, 6), I = 1, 25) /
     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/
      DATA (MENA(I, 7), I = 1, 25) /
     1   0, -25,   0, -97, -105,  14, -30, 231,   0,   0,
     2 -35,   0,   0,   0,   0,  71, -46, -68, -69,   0,
     3 166,  73,   0, 462,   0/
      DATA (MENA(I, 8), I = 1, 25) /
     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/
      DATA (MENA(I, 9), I = 1, 25) /
     1 414, -69, -59,-104, -105, 506, -55, 312,   0,   0,
     2 341,   0,   0,   0,   0,   0,   0, -68,   0,   0,
     3   0,   1, 552, 476,   0/
      DATA (MENA(I, 10), I = 1, 25) /
     1   0, -30, -59, -97,  68, 119, -55, 324,  87, -52,
     2 110,   0,   0,   0,   0,   0,   0,   0,   0, -95,
     3   0,   0, -45, 462,   0/
      DATA (MENA(I, 11), I = 1, 25) /
     1   0,  29, 592, -56, 501, 502, 497, -61, 181,   0,
     2 154, 445, 363, -33,-121,   0,   0,   0,   0,   0,
     3   0, 346,-103,   0,   0/
      DATA (MENA(I, 12), I = 1, 25) /
     1   0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
     2   0, 594,-109, -57, -74,   0, -46, 449, -70,   0,
     3 -35, -69, -68, 590,   0/
      DATA (MENA(I, 13), I = 1, 25) /
     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/
      DATA (MENA(I, 14), I = 1, 25) /
     1   0,1394,2394,3394,   0, 406, 387, 388,   0,   0,
     2   0,   0, 369,   0, 468,   0,   0,   0,   0,   0,
     3   0,   0,-103,   0,   0/
      DATA (MENA(I, 15), I = 1, 25) /
     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/
      DATA (MENA(I, 16), I = 1, 25) /
     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/
      DATA (MENA(I, 17), I = 1, 25) /
     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/
      DATA (MENA(I, 18), I = 1, 25) /
     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/
      DATA (MENA(I, 19), I = 1, 25) /
     1   0, -44,   0,   0,   0,   0,   0, -91, -51, -96,
     2-125,   0,   0,   0, -74,   0,   0, -68,   0,   0,
     3   0,   0,   0,   0,   0/
      DATA (MENA(I, 20), I = 1, 25) /
     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/
      DATA (MENA(I, 21), I = 1, 25) /
     1   0, 549,   0,   0,   0,   0,   0,   0,   0,   0,
     2   0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
     3 569, 570,-103,   0,   0/
      DATA (MENA(I, 22), I = 1, 25) /
     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/
      DATA (MENA(I, 23), I = 1, 25) /
     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/
      DATA (MENA(I, 24), I = 1, 25) /
     1   0, 116,   0,   0,   0,   0,   0,   0, 537,   0,
     2 535,   0, 527, 528, 529, 532, -75,   0,   0,   0,
     3   0, 346,-103,   0,   0/
      DATA (MENA(I, 25), I = 1, 25) /
     1   0,   0,   0,   0, 469,   0,1543,2543,3543,4543,
     2   0,   0,   0,   0,   0,   0, 575, 571, 572, 573,
     3 574,   0,   0,   0,   0/
      DATA (MENA(I, 26), I = 1, 25) /
     1   0,   0,   0,   0,   0, 568,   0,   0, 503,-106,
     2   0,   0,   0,   0,   0,   0,   0,   0, 566,   0,
     3   0,   0,   0,   0,   0/
      DATA (MENA(I, 27), I = 1, 25) /
     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/
      DATA (MENA(I, 28), I = 1, 25) /
     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/
      DATA (MENA(I, 29), I = 1, 25) /
     1   0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
     2   0,   0,   0,   0, 593,   0,   0,   0,   0,   0,
     3   0,   0,   0,   0,   0/
      DATA (MENA(I, 30), I = 1, 25) /
     1   0, 346, 355,   0,   0,   0,   0,   0,   0,   0,
     2 353, 358, 357,   0,   0,   0, 356,   0,   0,   0,
     3   0,   0,   0,   0,   0/
      DATA (OPTS(1, I), I = 1, 7) /
     1 'PLUTONauto', 'CALC ALL  ', 'CALC SOLV ', 'ADDSYM    ',
     2 'DELrefABS ', 'VALIDATION', 'PATTERSON '/
      DATA (IOPT(1, I), I = 1, 7) /1, -2, 1, 1, 2, -1, 1/
      DATA (OPTS(2, I), I = 1, 7) /
     1 'ORTEP/ADP ', 'CALC INTRA', 'CALC K.P.I', 'ADDSYM-EQL',
     2 'ABSPsiScan', 'ASYM-VIEW ', 'FCF2HKL   '/
      DATA (IOPT(2, I), I = 1, 7) /1, -2, 1, -2, 2,  2, 2/
      DATA (OPTS(3, I), I = 1, 7) /
     1 'NEWMAN    ', 'CALC INTER', 'SQUEEZE   ', 'ADDSYM-EXT',
     2 'ABSTompa  ', 'FCF-VALID ', 'EXPAND-P1 '/
      DATA (IOPT(3, I), I = 1, 7) /-4, -3, 2, -2, 2, 2, 1/
      DATA (OPTS(4, I), I = 1, 7) /
     1 'RING-PLOTS', 'CALC COORD', 'CALC-FCF  ', 'ADDSYM-PLT',
     2 'ABSGauss  ', 'SUPPLEMMAT', 'FCF-GENER '/
      DATA (IOPT(4, I), I = 1, 7) /-4, 1, 2, -2, 2, 1, 1/
      DATA (OPTS(5, I), I = 1, 7) /
     1 'PLANE-PLOT', 'CALC METAL', 'CONTOUR-SQ', 'ADDSYM-SHX',
     2 'ABSXtal   ', 'ANALofVAR ', 'HKL-GENER '/
      DATA (IOPT(5, I), I = 1, 7) /-4, 1, 3, -2, 2, 5, -5/
      DATA (OPTS(6, I), I = 1, 7) /
     1 'POLYHEDRA ', 'CALC GEOM ', 'SOLV F3D  ', 'NEWSYM    ',
     2 'ABSSphere ', 'ByvoetPair', 'HKL-TRANSF'/
      DATA (IOPT(6, I), I = 1, 7) /1, -2, 1, -2, 2, 2, 2/
      DATA (OPTS(7, I), I = 1, 7) /
     1 'CONTOUR-DF', 'CALC HBOND', 'SOLV PLOT ', 'NONSYM    ',
     2 'MULscanABS', 'ASYM-EXPCT', 'EXOR-RES  '/
      DATA (IOPT(7, I), I = 1, 7) /2, -3, 1, -2, 2, 1, 2/
      DATA (OPTS(8, I), I = 1, 7) /
     1 'CONTOUR-Fo', 'CALC TMA  ', 'CAVITY-PLT', 'LEPAGE    ',
     2 'SHXABS    ', '          ', 'ANIS-RES  '/
      DATA (IOPT(8, I), I = 1, 7) /2, -2, 1, 1, 2, -2, -2/
      DATA (OPTS(9, I), I = 1, 7) /
     1 'AutoMolFit', 'L.S.-PLANE', '          ', 'DELRED    ',
     2 '          ', '          ', 'RENAME-RES'/
      DATA (IOPT(9, I), I = 1, 7) /1,  1, 1, 1, 1, 1, 1/
      DATA (OPTS(10, I), I = 1, 7) /
     1 'HKL2Powder', 'DihedAngle', '          ', 'MOLSYM    ',
     2 '          ', 'EXPECT-HKL', 'PDB   -pdb'/
      DATA (IOPT(10, I), I = 1, 7) /-2, 1, 1, -2, 1, 1, -2/
      DATA (OPTS(11, I), I = 1, 7) /
     1 'SimPowderP', 'AngleLines', '          ', '          ',
     2 '          ', 'CSD-CELL  ', 'SPF   -eld'/
      DATA (IOPT(11, I), I = 1, 7) /-2, 1, 2, 1, 1, -2, -5/
      DATA (OPTS(12, I), I = 1, 7) /
     1 'RadDistFun', 'AngLsplLin', '          ', 'ASYM      ',
     2 '          ', 'CSD-QUEST ', 'SHELXL-res'/
      DATA (IOPT(12, I), I = 1, 7) /1, 1, 1, 2, 1, -2, -5/
      DATA (OPTS(13, I), I = 1, 7) /
     1 '          ', 'CremerPopl', '          ', 'ASYMaverFR',
     2 '          ', '          ', 'CIF   -acc'/
      DATA (IOPT(13, I), I = 1, 7) /1, -4, 2, 2, 1, 1, -2/
      DATA (OPTS(14, I), I = 1, 7) /
     1 '          ', 'BondValenc', 'LePageTwin', 'SPGRfromEX',
     2 '          ', '          ', 'AUTO-RENUM'/
      DATA (IOPT(14, I), I = 1, 7) /1, -4, 1, 2, 1, 1, -2/
      DATA (OPTS(15, I), I = 1, 7) /
     1 'PLUTONativ', 'HFIX - RES', 'TwinRotMat', 'StructTidy',
     2 'Xtal Habit', 'CIF-LOCAL ', 'SYSTEM-S  '/
      DATA (IOPT(15, I), I = 1, 7) /1, 1, 2, 1, 1, -2, 2/
      END
      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-2006  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 *                                                                    C
C * THIS VERSION INCLUDES  FEATURES FOR INTERACTIVE USE OF THE PROGRAM C
C * WITH              TEKTRONIX 4010 (+ COLOR)    - GRAPHICS TERMINAL  C
C *                                                  X-Window/UNIX     C
C *        HPGL,TEK4014,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.                                     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 4  -  RECEIVES GENERATED INPUT FILE TO MOGLI(PS330)          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
      PARAMETER (NP4=9,NP9=118,NP10=16,NP12=600,NP13=500,NP14=64,
     1 NP17=99,NPVD=40000000,NP22=256,NP23=18000,NP32=63,NP37=175,
     2 NP38=125,NP39=30,NP43=12,NP45=2048)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON // MOL(2, NP23), RA(NPVD)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /PLUTO/ IPPR(129, 3), IBT(32), TRL(3), ROM(3, 3), R(3, 3),
     1 RP(NP14), XJX(12), XXX(12), YYY(12), TMX(3, 3), SHFT(3),
     2 XYZOR(3), XYZR(3),  ZU(15), OM(3, 3), RCG(4, NP32), TMY(3, 3),
     3 XYZPL(6), A(3, 3), XYZK(8), KRS(NP32), NCRS(9), NPRS(17)
      COMMON /Q/ ICL, IFL(NP17)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /CHDAT/ CRD(NP37), LABP(16), COLR(NP10 + 1), BWCT(NP10 + 1)
      CHARACTER CRD*4, J215*5, JK13*3, JK12*2, N12*3, LABP*2, BWCT*10,
     1          COLR*10
      COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9),
     1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10),
     2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10),
     3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770)
      COMMON /CGGT/ IGGT
      CHARACTER IGGT*80
      COMMON /FNAME/ KNM(8), KXT, KNM16
      COMMON /NAMES/ NAME(8), EXTENS, PROGNM, FNLU1, FNLU16, RDTYPE
      CHARACTER NAME*80, EXTENS*9, PROGNM*28, FNLU1*80, FNLU16*80,
     1          RDTYPE*7
      COMMON /GGT / MEDIUM
      COMMON /PLU99A/ SFC(16)
      COMMON /PLU99B/ NUNIT(16), NSF, NFHAT
      CHARACTER SFC*2, CLR*7
      COMMON /CGG11/ BCD, SBCD
      CHARACTER BCD*132, SBCD*132
      CHARACTER BCKG*10, BCOL*10, HCOL*20, IFLNQ*10
      COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0
C * MPLUT = -1 - NATIVE, RENAME, HFIX, ANIS FLAGS
C * MPLUT =  0 - S-MODE
C * MPLUT =  1 - FROM PLATON & ADDSYM
      IGBL30 = 0
      IGBL8  = 0
      PAR40  = 0.0
C * MAIN PLUTON ROUTINE
      IF (MPLUT .NE. 0) THEN
        CLOSE (LU1)
        IF (MPLUT .EQ. 1) THEN
          IF (IGBL(31) .NE. 0) THEN
            CLOSE (LU2, ERR = 10)
   10       IGBL(31) = 0
            IGBL(2)  = 0
          ENDIF
          IGBL(21) = 0
        ENDIF
        IF (IABS(IGBL(8)) .EQ. 4) THEN
          IGBL(90) = 2
        ELSE IF (IABS(IGBL(8)) .EQ. 3) THEN
          IGBL(90) = 1
        ELSE
          IGBL(90) = 0
        ENDIF
        IGBL30 = IGBL(30)
        IGBL8  = IGBL(8)
        IF (IPR(504) .EQ. 1) IGBL(30) = 0
      ENDIF
      CALL PLUT01 (-1)
C * LOOP: READ AND INTERPRET UNTIL FIRST PLOT INSTRUCTION
   20 IF (IGBL(2) .GT. 0) THEN
        IF (IGBL(50) .EQ. 0) THEN
          CALL PLA013 (0, 1)
          IF (IGGT(1:3) .EQ. 'END' .AND. IABS(IGBL(8)) .NE. 4)
     1        IGBL(2) = -1
        ELSE
          IF (IGBL(3) .EQ. 13) THEN
            CALL PLA280 ('HFIX')
          ELSE IF (IGBL(3) .EQ. 26) THEN
            CALL PLA280 ('ANIS')
          ENDIF
        ENDIF
        TIMT    = PAR(46)
        PAR(46) = CPUTIM()
        PAR(41) = PAR(46) - TIMT
        PAR(49) = PAR(46) - PAR(43)
        WRITE (LU6, 99987) IGBL(2), PAR(41), PAR(49)
      ENDIF
      IGBL(2)  = IGBL(2) + 1
      IF (IGBL(2) .EQ. 0) GOTO 1310
C * INITIALISE
      ISW = 0
   30 CALL PLUT01 (0)
      IF (IGBL(35) .EQ. 1) GOTO 50
      IGBL(24) = 1
      IF (IGBL(5) .EQ. 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
   40 CALL GEN038 (IGGT, 1, 80)
      IF (IGBL(5) * IGBL(24) * IGBL(25) .EQ. LU5) THEN
        IF (IGBL(50) .EQ. 0) THEN
          CALL PLA013 (0, 1)
          IF (IGGT(1:1) .EQ. ' ') GOTO 40
        ELSE
          GOTO 1260
        ENDIF
      ENDIF
      GOTO 50
   45 IF (IGBL(5) * IGBL(24) * IGBL(25) .EQ. LU5) THEN
        IF (IGBL(35) .NE. 1) GOTO 40
        CALL PLA280 ('PLOT')
      ENDIF
   50 CALL PLA006 (1, ISW)
      IF (IGBL(8) .EQ. 0) THEN
        IF (ICL(1:1) .EQ. '#') GOTO 50
      ENDIF
      IPR(170) = 0
      IF (ISW .GT. 1) THEN
        IF (IGBL(5) .EQ. LU5 .AND. IGBL(45) .GT. 0) THEN
          WRITE (LU3, 99965) ICL(1:80)
          WRITE (LU6, 99978) ICL(1:70)
          IF (ISW .NE. 14) THEN
            IGBL(45) = IGBL(45) + 1
          ELSE
            IGBL(45) = -1
          ENDIF
        ENDIF
      ELSE IF (ISW .LT. 1) THEN
        GOTO 1230
      ENDIF
      KL = IPR(220)
      KN = IPR(221)
      IF (KL .EQ. 0 .AND. KN .EQ. 0) GOTO 50
C * ISW = 1:
      IF (ISW .EQ. 1) THEN
        GOTO 360
C * ISW = 2: TITL - TITLE FOR PLOT
      ELSE IF (ISW .EQ. 2) THEN
        JID(1:74) = ICL(5:78)
        GOTO 1100
C * ISW = 3: MESS - MESSAGE DISPLAY
      ELSE IF (ISW .EQ. 3) THEN
        WRITE (LU6, 99967) ICL(5:80)
        GOTO 1100
C * ISW = 4: REMARK
      ELSE IF (ISW .EQ. 4) THEN
        GOTO 1100
C * ISW = 5: CELL CONSTANTS
      ELSE IF (ISW .EQ. 5) THEN
        IF (KN .EQ. 1) THEN
          FN(2)    = FN(1)
          FN(3)    = FN(1)
          IPR(221) = 3
          KN       = IPR(221)
        ENDIF
        IF (KN .EQ. 3) THEN
          FN(4)    = 90.0
          FN(5)    = 90.0
          FN(6)    = 90.0
          IPR(221) = 6
          KN       = IPR(221)
        ENDIF
        IF (KN .EQ. 6) THEN
          KN7 = 0
        ELSE IF (KN .EQ. 7) THEN
          KN7 = 1
        ELSE
          IPR(72) = 1
          GOTO 1100
        ENDIF
        DO 60 I = 1, 6
          PAR(100 + I) = FN(I + KN7)
   60   CONTINUE
        IPR(50) = 0
        GOTO 1100
C * ISW = 6: SPGR
      ELSE IF (ISW .EQ. 6) THEN
        GOTO 300
C * ISW = 7: LATT
      ELSE IF (ISW .EQ. 7) THEN
        GOTO 300
C * ISW = 8: LIST
      ELSE IF (ISW .EQ. 8) THEN
        GOTO 1190
C * ISW = 9: SYMM
      ELSE IF (ISW .EQ. 9) THEN
        GOTO 300
C * ISW = 10: ANGSTROM
      ELSE IF (ISW .EQ. 10) THEN
        IF (KL .EQ. 1) THEN
          IF (IPR(50) .EQ. 0 .AND. PAR(101) .GT. 0.0) THEN
            IPR(156) = 1
          ELSE
            IPR(50) = - 1
            IF (KN .GE. 1) PAR(11) = FN(1)
          ENDIF
        ENDIF
        GOTO 1100
C * ISW = 11: ROD MODE
      ELSE IF (ISW .EQ. 11) THEN
        IF (IPR(4) .NE. 2 .OR. KL .EQ. 1) THEN
          IPR(4) = 2
          CALL PLUT21 (-1)
        ENDIF
        GOTO 610
C * ISW = 12: ATOM
      ELSE IF (ISW .EQ. 12) THEN
        GOTO 360
C * ISW = 13: JOIN (CALC)
      ELSE IF (ISW .EQ. 13) THEN
        GOTO 500
C * ISW = 14: END
      ELSE IF (ISW .EQ. 14) THEN
        IF (IGBL(5) .EQ. LU1 .AND. IGBL(8) .EQ. 2 .AND.
     1      IGBL(95) .NE. 0) THEN
          GOTO 40
        ELSE
         GOTO 1240
        ENDIF
C * ISW = 17: U
      ELSE IF (ISW .EQ. 17) THEN
        GOTO 370
C * ISW = 18/161: VIE(W)
      ELSE IF (ISW .EQ. 18 .OR. ISW .EQ. 161) THEN
        CALL PLUT06
        GOTO 1100
C * ISW = 19/162: SOL(ID) MODE
      ELSE IF (ISW .EQ. 19 .OR. ISW .EQ. 162) THEN
        IF (IPR(4) .NE. 1 .OR. KL .EQ. 1) THEN
          IPR(4) = 1
          CALL PLUT21 (-1)
        END IF
      GOTO 610
C * ISW = 20/163: STI(CK) MODE
      ELSE IF (ISW .EQ. 20 .OR. ISW .EQ. 163) THEN
        IPR(4) = 0
        CALL PLUT21 (-1)
        GOTO 610
C * ISW = 21/158: LAB(EL) - INSTRUCTION
      ELSE IF (ISW .EQ. 21 .OR. ISW .EQ. 158) THEN
        CALL PLUT04 (2, 0)
        GOTO 1100
C * ISW = 22/164: UNL(ABEL) - INSTRUCTION
      ELSE IF (ISW .EQ. 22 .OR. ISW .EQ. 164) THEN
        CALL PLUT04 (3, 0)
        GOTO 1100
C * ISW = 23: PUT INSTRUCTION
      ELSE IF (ISW .EQ. 23) THEN
        CALL PLUT04 (4, 0)
        GOTO 1100
C * ISW = 24: RADII - INSTRUCTION
      ELSE IF (ISW .EQ. 24) THEN
        CALL PLUT21 (0)
        GOTO 1100
C * ISW = 25/168: PAC(KING) DIAGRAM CONTROL
      ELSE IF (ISW .EQ. 25 .OR. ISW .EQ. 168) THEN
        IF (IPR(37) .EQ. IPR(69)) THEN
          WRITE (LU6, 99993)
          IPR(72) = 8
        ELSE
          IF (IPR(17) .EQ. 0) THEN
            CALL PLUT05
            IF (IPR(72) .NE. 0) STOP '304'
          ENDIF
          CALL PLUT39
          IPR(46) = 1
        ENDIF
        GOTO 1100
C * ISW = 26: MOLES/ARU
      ELSE IF (ISW .EQ. 26) THEN
        GOTO 700
C * ISW = 27/165: INC(LUDE)
      ELSE IF (ISW .EQ. 27 .OR. ISW .EQ. 165) THEN
        N = 1
        GOTO 850
C * ISW = 28/166: EXC(LUDE)
      ELSE IF (ISW .EQ. 28 .OR. ISW .EQ. 166) THEN
        N = 0
        GOTO 850
C * ISW = 29/167: UNITCELL TO BE PLOTTED(OR UNIT CARD)
      ELSE IF (ISW .EQ. 29 .OR. ISW .EQ. 167) THEN
        IF (IPR(37) .GT. IPR(69)) THEN
          IF (IPR(50) .EQ. 0) THEN
            IF (KL .GT. 1 .AND. IFL(2)(2:2) .EQ. 'F') THEN
              IPR(46) = 0
            ELSE
              IPR(46) = 1
            ENDIF
            DO 70 I = 1, 8
              CALL PLUT15 (1, I, 27, IPR(46))
   70       CONTINUE
            IF (KN .EQ. 2) THEN
              PAR(75)  = FN(1)
              IPR(107) = NINT(FN(2))
            ENDIF
            IPR(130) = 0
          ELSE
            GOTO 40
          ENDIF
        ELSE IF (IABS(IGBL(8)) .EQ. 2) THEN
          DO 80 I = 1, KN
            NUNIT(I) = NINT(FN(I))
   80     CONTINUE
          GOTO 1100
        ENDIF
        GOTO 1100
C * ISW = 30: RETRACE INSTRUCTION
      ELSE IF (ISW .EQ. 30) THEN
        IF (KN .GT. 0) THEN
          IF (KL .GT. 1) THEN
            IF (IFL(2)(1:1) .NE. 'L') THEN
              IF (IFL(2)(1:1) .EQ. 'A') THEN
                IPR(5) = NINT(FN(1))
                IF (KN .EQ. 2) PAR(3) = FN(2)
              ELSE
                IPR(72) = 5
              ENDIF
            ELSE
              IPR(7) = NINT(FN(1))
              IF (KN .GE. 2) PAR(4) = FN(2)
            ENDIF
          ELSE
            IPR(72) = 6
          ENDIF
        ELSE
          IPR(72) = 7
        ENDIF
        GOTO 1100
C * ISW = 31: STEREO/MONO INSTRUCTION
      ELSE IF (ISW .EQ. 31) THEN
        PAR(25)  = 1.0
        IPR(130) = 0
        IPR(143) = IPR(19)
        IPR(144) = IPR(19)
        IF (ICL(1:1) .EQ. 'S') THEN
          IPR(116) = -1
          PAR(48)  = PAR(12)
          IPR(6)   = 1
          IF (PAR(18) .LT. 0) PAR(18) = - PAR(50) / 2.0
        ELSE IF (ICL(1:1) .EQ. 'M') THEN
          IPR(346) = IABS(IPR(346))
          IPR(116) = 0
          PAR(48)  = 0.0
          IPR(6)   = 0
          IF (PAR(18) .LT. 0) PAR(18) = - PAR(50)
        ENDIF
        IF (KL .GT. 1) THEN
          DO 910 II = 2, KL
            IF (IFL(II)(1:1) .EQ. 'R' .OR. IFL(II)(1:1) .EQ. 'G') THEN
              IPR(6)   = 0
              IPR(477) = 0
              IF (IFL(II)(1:1) .EQ. 'R') THEN
                IPR(346)   = - IABS(IPR(346))
                IPR(143)   = 2
                IF (IFL(II)(2:2) .EQ. 'B') THEN
                  IPR(144) = 4
                ELSE
                  IPR(144) = 3
                ENDIF
              ELSE
                IPR(346)   = - IABS(IPR(346))
                IPR(144)   = 2
                IF (IFL(II)(1:1) .EQ. 'B') THEN
                  IPR(143) = 4
                ELSE
                  IPR(143) = 3
                ENDIF
              ENDIF
              IF (PAR(18) .LT. 0) PAR(18) = - PAR(50)
            ELSE IF (IFL(II)(1:1) .EQ. 'C') THEN
              IPR(6)      = -1
            ELSE IF (IFL(II)(1:1) .EQ. 'S') THEN
              PAR(25) = 0.5
            ELSE IF (IFL(II)(1:1) .EQ. 'P') THEN
              PAR(48) = PAR(12)
              IF (KN .GT. 0) THEN
                IF (FN(1) .GT. 0.1) THEN
                  PAR(48) = FN(1)
                  IF (PAR(48) .GE. 10000.0) PAR(48) = 0.0
                ENDIF
              ENDIF
            ENDIF
  910     CONTINUE
        ENDIF
        GOTO 1100
C * ISW = 33: SIZE CONTROL: SIZE OF DRAWING, SCALE, LABELS,TITLE
      ELSE IF (ISW .EQ. 33) THEN
        IF (IGBL(8) .NE. 2) THEN
          IF (KN .NE. KL) GOTO 100
          IPR(130) = 0
          DO 90 K = 1, KL
            JK13 = IFL(K)(1:3)
            IF (JK13 .EQ. 'SIZ') THEN
              PAR(15) = FN(K)
            ELSE IF (JK13 .EQ. 'RAT') THEN
              PAR(18) = FN(K)
            ELSE IF (JK13 .EQ. 'SCA') THEN
              PAR(16) = FN(K)
            ELSE IF (JK13 .EQ. 'TIT') THEN
              PAR(14) = FN(K)
            ELSE IF (JK13 .EQ. 'CHA') THEN
              PAR(349) = FN(K)
            ENDIF
   90     CONTINUE
  100     P15 = - PAR(15)
          WRITE (LU6, 99994) PAR(18), PAR(14), P15, PAR(16),
     1      VERT, PAR(349)
          GOTO 1100
        ENDIF
C * ISW = 34: PLOT INSTRUCTION
      ELSE IF (ISW .EQ. 34) THEN
        IPR(151) = 0
        IF (IPR(157) .GT. 0) THEN
          IPR(130) = 0
          IPR(157) = 0
        ENDIF
        GOTO 1280
C * ISW = 35: RESET - SET DEFAULTS AND CLEAR FLAGS
      ELSE IF (ISW .EQ. 35) THEN
        CALL PLUT01 (1)
        GOTO 1100
C * ISW = 36: SEGMENT = PLOTSTEP SIZE (CM)
      ELSE IF (ISW .EQ. 36) THEN
        IF (KN .GT. 0) THEN
          PAR(5) = FN(1)
          IF (KN .GT. 1) IPR(111) = NINT(FN(2))
        ENDIF
        WRITE (LU6, 99999) PAR(5), IPR(111)
        GOTO 1100
C * ISW = 38: HP MANAGEMENT
      ELSE IF (ISW .EQ. 38) THEN
        IPDC = -2
        IF (KL .GT. 1) THEN
          IF (IFL(1)(3:3) .EQ. 'P') IPDC = -4
          IF (IFL(2)(2:2) .EQ. 'N') IPDC = IABS(IPDC)
          CALL GGIP (-999.0, 0.0, 0.0, IPDC)
        ENDIF
        GOTO 1100
C * ISW = 39: CAL MANAGEMENT
      ELSE IF (ISW .EQ. 39) THEN
        IPDC = -3
        IF (KL .GT. 1) THEN
          IF (IFL(1)(3:3) .EQ. 'P') IPDC = -4
          IF (IFL(2)(2:2) .EQ. 'N') IPDC = IABS(IPDC)
          CALL GGIP (-999.0, 0.0, 0.0, IPDC)
        ENDIF
        GOTO 1100
C * ISW = 40: COLOR/BWC MANAGEMENT
      ELSE IF (ISW .EQ. 40) THEN
        IF (IFL(1)(1:3) .EQ. 'BWC') THEN
          IBWC = 1
        ELSE
          IBWC = 0
        ENDIF
        IF (KL .GT. 1) THEN
          JK13  = IFL(2)(1:3)
          KSTEP = IBWC + 1
          IF (JK13 .EQ. 'TYP') THEN
            IF (KL .GE. 3 .AND. MOD(KL, KSTEP) .EQ. 0) THEN
              DO 1050 K = 3, KL, KSTEP
                CALL PLUT13 (0, -K, N1, XDUM)
                IF (N1 .LT. 0) THEN
                  N1 = - N1
                  IF (IBWC .EQ. 1) THEN
                    DO 1010 J = 1, NP10 + 1
                      IF (IFL(K + 1)(1:3) .EQ. BWCT(J)(1:3)) GOTO 1020
 1010               CONTINUE
                    J = 17
 1020               IBCL(N1) = J
                  ELSE
                    IF (KN .GE. K - 2) IACL(N1) = NINT(FN(K - 2))
                    DO 1030 J = 1, NP10 + 1
                      IF (IFL(K + 1)(1:3) .EQ. COLR(J)(1:3)) GOTO 1040
 1030               CONTINUE
                    J = 17
 1040               IACL(N1) = J
                  ENDIF
                ELSE
                  WRITE (LU6, 99981) IFL(K)
                ENDIF
 1050         CONTINUE
              IPR(90) = 256
            ENDIF
          ELSE IF (JK13 .EQ. 'RES') THEN
            IF (IFL(3)(1:3) .EQ. 'OFF') THEN
              IPR(346 - IBWC) = 0
              IPR(477 + IBWC) = 0
            ELSE
              IPR(346 - IBWC) = 1
              IPR(477 + IBWC) = -1
            ENDIF
          ELSE IF (JK13 .EQ. 'ARU') THEN
            IF (IFL(3)(1:3) .EQ. 'OFF') THEN
              IPR(346 - IBWC) = 0
              IPR(477 + IBWC) = 0
            ELSE
              IPR(346 - IBWC) = 1
              IPR(477 + IBWC) = 1
            ENDIF
          ELSE IF (JK13 .EQ. 'ON ') THEN
            IPR(346 - IBWC) = 1
          ELSE IF (JK13 .EQ. 'OFF') THEN
            IPR(346 - IBWC) = 0
          ELSE
            IPR(19) = 1
            IF (JK13 .EQ. 'RED') IPR(19) = 2
            IF (JK13 .EQ. 'GRE') IPR(19) = 3
            IF (JK13 .EQ. 'BLU') IPR(19) = 4
            IF (JK13 .EQ. 'YEL') IPR(19) = 5
            IF (JK13 .EQ. 'ORA') IPR(19) = 6
            IF (JK13 .EQ. 'VIO') IPR(19) = 7
            IF (JK13 .EQ. 'BRO') IPR(19) = 8
          ENDIF
        ELSE
          IF (IBWC .EQ. 1) THEN
            IPR(345) = 1
          ELSE
            IPR(346) = 1
          ENDIF
        ENDIF
        GOTO 1100
C * ISW = 41: SET, PARAMETER MANIPULATION
      ELSE IF (ISW .EQ. 41) THEN
        IF (KL .GT. 1) THEN
          JK12 = IFL(2)(1:2)
          IF (IFL(2)(1:3) .EQ. 'IPR' .OR.
     1        IFL(2)(1:3) .EQ. 'PAR' .OR.
     2        IFL(2)(1:3) .EQ. 'IGB' .OR.
     3        IFL(2)(1:3) .EQ. 'GL ') THEN
            CALL PLA206 (1, IFL(2)(1:3))
            GOTO 40
          ELSE IF (JK12 .EQ. 'DI') THEN
            MEDIUM = 1
          ELSE IF (JK12 .EQ. 'ME') THEN
            MEDIUM = 2
          ELSE IF (JK12 .EQ. 'WI') THEN
            CALL GGIP (-999.0, 0.0, FN(1) * 1000.0, 9)
          ELSE IF (JK12 .EQ. '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
          ENDIF
          IF (IPR(72) .EQ. 0) THEN
            IF (KL .GT. 2) THEN
              CALL GGIP (-999.0, 0.0, 0.0, 6)
            ENDIF
          ENDIF
        ENDIF
        GOTO 1100
C * ISW = 42: OMIT
      ELSE IF (ISW .EQ. 42) THEN
        N = 0
        GOTO 850
C * ISW = 43/49/150: QUIT/STOP/EXIT
      ELSE IF (ISW .EQ. 43 .OR. ISW .EQ. 49 .OR. ISW .EQ. 150) THEN
        GOTO 1260
C * ISW = 44: RESI
      ELSE IF (ISW .EQ. 44) THEN
        IPR(538) = NINT(FN(1))
        GOTO 1100
C * ISW = 45: ANGLE CALCULATION
      ELSE IF (ISW .EQ. 45) THEN
        IF (KL .EQ. 4) THEN
          CALL PLUT24 (3, 0, IDUM)
          GOTO 40
        ELSE
          GOTO 1100
        ENDIF
C * ISW = 46: DETACH
      ELSE IF (ISW .EQ. 46) THEN
        GOTO 520
C * ISW = 47: SAVE COMMAND
      ELSE IF (ISW .EQ. 47) THEN
        IGBL(45) = 1
        CALL GEN108 (LU3, 0)
        GOTO 1100
C * ISW = 48: OVERLAP OPTION OFF = 0, BA = 1, BB = 2, ON = 3
      ELSE IF (ISW .EQ. 48) THEN
        IF (KL .GT. 1) THEN
          N = 0
          DO 110 K = 2, KL
            JK12 = IFL(K)(1:2)
            IF (JK12 .EQ. 'SH') THEN
              N = N + 1
              PAR(58) = FN(N)
            ELSE IF (JK12 .EQ. 'MA') THEN
              N = N + 1
              PAR(36) = FN(N)
            ELSE IF (JK12 .EQ. 'ON') THEN
              IPR(77) = 3
            ELSE IF (JK12 .EQ. 'AB') THEN
              IPR(77) = 2
            ELSE IF (JK12 .EQ. 'BA') THEN
              IPR(77) = 1
            ELSE IF (JK12 .EQ. 'OF') THEN
              IPR(77) = 0
            ENDIF
  110     CONTINUE
        ENDIF
        WRITE (LU6, 99984) IPR(77), PAR(36), PAR(58)
        GOTO 1100
C * ISW = 51: BOX - INSTRUCTION
      ELSE IF (ISW .EQ. 51) THEN
        IF (KL .GT. 1) THEN
          IPR(130) = 0
          N = 0
          DO 120 K = 2, KL
            JK12 = IFL(K)(1:2)
C * BOX OFF
            IF (JK12 .EQ. 'OF') THEN
              IGBL(103) = 0
C * BOX ON
            ELSE IF (JK12 .EQ. 'ON') THEN
              IGBL(103) = 1
C * BOX SHRINK
            ELSE IF (JK12 .EQ. 'SH') THEN
              N = N + 1
              IF (N .GT. KN) THEN
                IPR(72) = 12
                GOTO 1100
              ELSE
                IF (FN(N) .LE. 1.0 .AND. FN(N) .GT. 0.01) THEN
                  PAR(13) = FN(N)
                ELSE
                  CALL PLUT38 (6, 0, LU6)
                ENDIF
              ENDIF
C * BOX RATIO
            ELSE IF (JK12 .EQ. 'RA') THEN
              N = N + 1
              IF (N .GT. KN) THEN
                IPR(72) = 13
                GOTO 1100
              ELSE
                PAR(18) = FN(N)
              ENDIF
            ENDIF
  120     CONTINUE
        ENDIF
        IF (IGBL(103) .EQ. 1) THEN
          N12 = 'ON '
        ELSE
          N12 = 'OFF'
        ENDIF
        WRITE (LU6, 99985) N12, PAR(13), ABS(PAR(18))
        GOTO 1100
C * ISW = 52: FVAR - SHELX76 STYLE
      ELSE IF (ISW .EQ. 52) THEN
        IGBL(8) = 2
        IPR(81) = 1
        IF (IPR(13) + KN .GT. NP14) CALL PLUT38 (7, 1, LU6)
        DO 350 I = 1, KN
          RP(IPR(13) + I) = MOD(FN(I) + 5.0, 10.0) - 5.0
  350   CONTINUE
        IPR(13) = IPR(13) + KN
        GOTO 1100
C * ISW = 53: HELP OPTION
      ELSE IF (ISW .EQ. 53) THEN
        CALL PLA109 (2)
        GOTO 1100
C * ISW = 55: B-ISO
      ELSE IF (ISW .EQ. 55) THEN
        GOTO 370
C * ISW = 58: CPK STYLE
      ELSE IF (ISW .EQ. 58) THEN
        IF (IABS(IPR(4)) .NE. 3 .OR. KL .EQ. 1) CALL PLUT21 (1)
        GOTO 610
C * ISW = 59: SFAC - SHELX STYLE
      ELSE IF (ISW .EQ. 59) THEN
        IF (IABS(IGBL(8)) .NE. 2) THEN
          IGBL(8) = 2
          NSF     = 0
          NFHAT   = 0
        ENDIF
        DO 320 I = 2, KL
          NSF = NSF + 1
          SFC(NSF) = IFL(I)(1:2)
          IF (SFC(NSF) .EQ. 'H ') NFHAT = 1
  320   CONTINUE
        GOTO 1100
C * ISW = 62: DISTANCE CALCULATION
      ELSE IF (ISW .EQ. 62) THEN
        CALL PLUT24 (2, 0, IDUM)
        GOTO 40
C * ISW = 63: TORSION CALCULATION
      ELSE IF (ISW .EQ. 63) THEN
        CALL PLUT24 (4, 0, IDUM)
        GOTO 40
C * ISW = 65: TRNS/TRMX INSTRUCTION
      ELSE IF (ISW .EQ. 65) THEN
        IF (KN .NE. 1) THEN
          IF (IPR(37) .LE. IPR(69)) THEN
            CALL GEN074 (XJX, 0.0, 1, 12)
            XJX(1) = 1.0
            XJX(5) = 1.0
            XJX(9) = 1.0
            IF (KN .EQ. 9 .OR. KN .EQ. 12) THEN
              IPR(127) = 1
              K        = 0
              DO 260 I = 1, 3
                DO 250 J = 1, 3
                  K = K + 1
                  TMX(I, J) = FN(K)
                  XJX(K)    = FN(K)
  250           CONTINUE
  260         CONTINUE
              CALL GEN003 (TMX, A, DET, 0)
              WRITE (LU6, 99973) DET
              CALL GEN005 (A, TMY)
            ENDIF
            IF (KN .EQ. 3 .OR. KN .EQ. 12) THEN
              IPR(128) = 1
              DO 270 I = 1, 3
                SHFT(I) = - FN(KN - 3 + I)
                XJX(I + 9) = - SHFT(I)
  270         CONTINUE
            ENDIF
          ELSE
            WRITE (LU6, 99970)
          ENDIF
        ELSE
          N = INT(ABS(FN(1)))
          IF (N .GT. IPR(48)) THEN
            WRITE (LU6, 99986) N, FN(1), IPR(48)
          ELSE
            IF (FN(1) .LT. 0) THEN
              PAR(140) = FN(1)
            ELSE
              PAR(141) = FN(1)
            ENDIF
          ENDIF
        ENDIF
        GOTO 1100
C * ISW = 67: INORG - INSTRUCTION
      ELSE IF (ISW .EQ. 67) THEN
        IGBL(97) = 0
        GOTO 1100
C * ISW = 68: ORGA - INSTRUCTION
      ELSE IF (ISW .EQ. 68) THEN
        IGBL(97) = 1
        GOTO 1100
C * ISW = 69: STRAW STYLE
      ELSE IF (ISW .EQ. 69) THEN
        IF (IPR(4) .NE. 4 .OR. KL .EQ. 1) THEN
          IPR(4) = 4
          CALL PLUT21 (-1)
        ENDIF
        GOTO 610
C * ISW = 70: INFO
      ELSE IF (ISW .EQ. 70) THEN
        GOTO 1190
C * ISW = 72: CROT(X/Y/Z)(M) (STEPS, (NR-STEPS)) (COLOR) INSTRUCTION
      ELSE IF (ISW .EQ. 72) THEN
        IF (KN .GT. 0) PAR(145) = FN(1)
        IF (KN .GT. 1) IPR(152) = NINT(FN(2))
        IPR(346) = - IABS(IPR(346))
        IF (IABS(IPR(4)) .EQ. 3) IPR(4) = -3
        IGBL(35) = 1
        IF (IFL(1)(5:5) .EQ. 'X') THEN
          IPR(155) = 1
        ELSE IF (IFL(1)(5:5) .EQ. 'Z') THEN
          IPR(155) = 3
        ELSE
          IPR(155) = 2
        ENDIF
        IF (IFL(1)(6:6) .EQ. 'M') THEN
          IPR(164) = -1
        ELSE
          IPR(164) = 1
        ENDIF
        IPR(336) = 0
        IF (KL .GT. 1 .AND. IFL(2)(1:1) .EQ. 'C') IPR(336) = 1
        IPR(151) = IPR(152)
        IPR(130) = 0
        CALL GGIP (-999.0, 0.0, 0.0, -3)
        IPR(221) = 0
        KN       = IPR(221)
        IPR(220) = 1
        KL       = IPR(220)
        GOTO 1280
C * ISW = 73: VIEW DEFINITION  XROT
      ELSE IF (ISW .EQ. 73) THEN
        CALL PLUT06
        GOTO 1100
C * ISW = 74: VIEW DEFINITION YROT
      ELSE IF (ISW .EQ. 74) THEN
        CALL PLUT06
        GOTO 1100
C * ISW = 75: VIEW DEFINITION ZROT
      ELSE IF (ISW .EQ. 75) THEN
        CALL PLUT06
        GOTO 1100
C * ISW = 76: DEFINE INSTRUCTION (CREATE CENTROID PSEUDO-ATOM)
      ELSE IF (ISW .EQ. 76) THEN
        IF (IPR(17) .EQ. 0) THEN
          CALL PLUT05
          IF (IPR(72) .NE. 0) STOP '305'
        ENDIF
        IPR(130) = 0
        NATX     = IPR(38)  + 1
        NAT6     = NATX * NP43
        DO 780 I = 1, 3
          RA(NAT6 + I) = 0.0
  780   CONTINUE
        NQ1         = 'CG'//CHAR(IPR(160) + ICHAR('1'))//'    '
        CALL PLA046 (9, NQ1, NED, NQX, NSS, NQSM, XNQNR, YNQNR, NIEN)
        RA(NAT6 + 7) = XNQNR
        N0           = 0
        IF (KL .LT. 5) THEN
          IPR(72) = 9
          GOTO 1100
        ENDIF
        DO 800 I = 2, KL
          IF (IFL(I)(1:2) .EQ. 'TO') THEN
            IF (I .EQ. 2) THEN
              IPR(161) = -1
            ELSE IF (I .EQ. 3) THEN
              IPR(161) = 1
            ELSE
              IPR(72) = 10
              GOTO 1100
            ENDIF
          ELSE IF (IFL(I)(1:2) .EQ. 'CG') THEN
            IF (I .EQ. 2) THEN
              IPR(161) = -2
            ELSE
              IPR(72) = 10
              GOTO 1100
            ENDIF
          ELSE
            N = I
            CALL PLUT13 (0, N, IAT, XDUM)
            IF (IAT .EQ. 0) THEN
              IPR(72) = 11
              GOTO 1100
            ENDIF
            IF (IPR(161) .NE. 0) THEN
              N0 = N0 + 1
              DO 790 J = 1, 3
                RA(NAT6 + J) = RA(NAT6 + J) + RA(IAT * NP43 + J)
  790         CONTINUE
              IF (N0 .EQ. 1) JAT = IAT
            ENDIF
          ENDIF
  800   CONTINUE
        IF (N0 .EQ. 0) THEN
          IPR(71) = 1
          GOTO 1100
        ENDIF
        DO 810 I = 1, 3
          RA(NAT6 + I) = RA(NAT6 + I) / N0
  810   CONTINUE
        IPR(38)  = NATX
        IPR(37)  = NATX
        IPR(160) = IPR(160) + 1
        CALL PLUT23 (NATX)
        RA(NAT6 + 8)  = RA(JAT * NP43 + 8)
        RA(NAT6 + 9)  = RA(JAT * NP43 + 9)
        RA(NAT6 + 10) = RA(JAT * NP43 + 10)
        RA(NAT6 + 11) = -1.0
        RA(NAT6 + 12) = RA(JAT * NP43 + 12)
        CALL PLUT25 (1, NATX, JUNK)
        IFL(KL + 1) = NQ1
        CALL PLUT25 (0, NATX, N1)
        IF (IPR(161) .EQ. -2) THEN
          IPR(161) = 0
          IF (IPR(4) .NE. 0 .AND. RADR(N1, 1) .EQ. 0.0)
     1      CALL PLUT21 (-1)
          GOTO 1100
        ELSE
        IVAL = 0
        CALL PLUT15 (1, NATX, 27, IVAL)
          GOTO 520
        ENDIF
C * ISW = 78/157: REN(AME) ATOM LABELS
      ELSE IF (ISW .EQ. 78 .OR. ISW .EQ. 157) THEN
        IF (MOD(KL, 2) .EQ. 1 .OR. KL .EQ. 2) THEN
          CALL PLUT32
        ELSE
          IPR(72) = 25
        ENDIF
        GOTO 1100
C * ISW = 79: GEOM CALCULATION AROUND ATOM
      ELSE IF (ISW .EQ. 79) THEN
        IPR(163) = 0
        CALL PLUT24 (1, IPR(38), IDUM)
        GOTO 40
C * ISW = 80: MENU (ON/OFF)
      ELSE IF (ISW .EQ. 80) THEN
        IF (KL .EQ. 2 .AND. IFL(2)(1:3) .EQ. 'OFF') THEN
          IGBL(25) = 0
        ELSE
          IGBL(25) = 1
        ENDIF
      GOTO 1100
C * ISW = 84: PART - SHELXL STYLE
      ELSE IF (ISW .EQ. 84) THEN
        GOTO 1100
C * ISW = 87: COORDN AROUND ATOM
      ELSE IF (ISW .EQ. 87) THEN
        IPR(163) = 1
        IF (IPR(44) - IPR(43) .EQ. 0) THEN
          IFL(4) = IFL(2)
          IFL(2)(1:5) = 'RADII'
          IFL(3)(1:5) = 'INTER'
          IPR(220) = 3
          KL       = IPR(220)
          CALL PLUT05
          IF (IPR(72) .NE. 0) STOP '306'
          IFL(2) = IFL(4)
          IPR(220) = 2
          KL       = IPR(220)
        ENDIF
        CALL PLUT24 (1, IPR(37), IDUM)
        GOTO 1100
C * ISW = 89/159: DEL(ETE)
      ELSE IF (ISW .EQ. 89 .OR. ISW .EQ. 159) THEN
        N = 0
        GOTO 850
C * ISW = 90: ENTRY - READ UNTIL SPECIFIED FDAT-ENTRY FOR KN .NE. 0
      ELSE IF (ISW .EQ. 90) THEN
        CALL PLA011
        IF (ICL(1:4) .EQ. 'END ') THEN
          GOTO 1240
        ELSE
          GOTO 1100
        ENDIF
C * ISW = 91: DIR
      ELSE IF (ISW .EQ. 91) THEN
        CALL PLA011
        IF (ICL(1:4) .EQ. 'END ') THEN
          GOTO 1240
        ELSE
          GOTO 1100
        ENDIF
C * ISW = 92: HFIX (SHELXL ONLY)
      ELSE IF (ISW .EQ. 92) THEN
        IF (KN .GT. 0) GOTO 1100
        IF (IGBL(50) .GT. 0) THEN
          IGBL(8) = - IABS(IGBL(8))
        ENDIF
        IF (IGBL(8) .EQ. -2) THEN
          IF (KL .EQ. 1) THEN
            KL0 = 1
          ELSE
            KL0 = 2
          ENDIF
          NHAUTO = IGBL(50)
          DO 170 KLI = KL0, KL
            IBEG = IPR(69) + 1
            IEND = IPR(39)
            IF (NHAUTO .EQ. 0) THEN
              IAT1 = 0
              IF (KLI .GT. 1) THEN
                CALL PLUT13 (0, KLI, IAT1, XDUM)
                IF (IAT1 .GT. 0) THEN
                  IF (KN .GT. 0) THEN
                    MNFIX = NINT(FN(1))
                    CALL PLUT29 (3, IFL(KLI), NQ2, MNFIX)
                    GOTO 170
                  ENDIF
                  IBEG = IAT1
                  IEND = IAT1
                ELSE IF (IAT1 .EQ. 0) THEN
                  GOTO 170
                ENDIF
              ENDIF
            ENDIF
            DO 160 I = IBEG, IEND
  140         IAT = I
              IF (IPR(140) .NE. 0) THEN
                CALL PLUT15 (-6, IAT, 5, IVAL)
                IF (IVAL .NE. IPR(140)) GOTO 160
              ENDIF
              CALL PLUT15 (-1, IAT, 44, IHAT)
              IF (IHAT .EQ. 1) GOTO 160
              CALL PLUT25 (1, IAT, IATK)
              IFL(2) = NQ1
              IF (IAT1 .LT. 0 .AND. -IAT1 .NE. IATK) GOTO 160
              CALL PLA046 (8, NQ1, NEI, NA, NAX, NS, XPK1, XPK2, NIEN)
              NB = 1
              NE = 7
              CALL GEN039 (1, IFL(2), 1, 7, NB, NE)
              IPR(220) = 2
              CALL PLUT24 (-1, IPR(38), MNFX)
              IF (MNFX .GE. 0) THEN
                CALL GEN040 (MNFX, NQ2, IP)
                IF (NHAUTO .EQ. 0) THEN
  150             IF (IGBL(25) * IGBL(32) .EQ. 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, RL)
                    IFLNQ = IFL(2)(1:NE)//'['//NQ2(1:IP)//']'
                    CALL GGIP20 (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)
                    CALL PLA013 (0, 1)
                    ICL = IGGT
                  ELSE
                    WRITE (LU6, 99968) IFL(2), MNFX
                    READ (LU5, '(A)') ICL(1:80)
                  ENDIF
                  CALL GEN020 (1, ICL, 1, 4)
                  IF (ICL(1:4) .EQ. 'QUIT' .OR.
     1                ICL(1:3) .EQ. 'END') THEN
                    GOTO 180
                  ELSE IF (ICL(1:4) .EQ. 'AUTO') THEN
                    NHAUTO = 1
                    MNFIX = MNFX
                  ELSE IF (ICL(1:4) .EQ. 'PLOT') THEN
                    CALL PLUT02
                    GOTO 140
                  ELSE IF (ICL(1:4) .EQ. 'VIEW') THEN
                    CALL PLA006 (1, IS)
                    CALL PLUT06
                    CALL PLUT02
                    GOTO 140
                  ELSE IF (ICL(1:1) .EQ. '!') THEN
                    IF (LRET .EQ. 2) THEN
                      CALL PLUT02
                      GOTO 140
                    ELSE
                      MNFIX = MNFX
                    ENDIF
                  ELSE
                    IF (ICL(1:4) .EQ. 'HFIX') THEN
                      MNFIX = 0
                    ELSE
                      READ (ICL, 99997, ERR = 150) MNFIX
                    ENDIF
                    IF (MNFIX .EQ. 0) MNFIX = MNFX
                  ENDIF
                ELSE
                  MNFIX = MNFX
                ENDIF
                IF (MNFIX .GT. 0) WRITE (LU27, 99998) MNFIX, IFL(2)
                CALL GEN038 (NQ2, 1, 7)
                CALL PLUT29 (3, IFL(2), NQ2, MNFIX)
                CALL GGIP20 (0.0, IFLNQ, NE + IP + 2, PAR(349), 0, 2,
     1              XL - PAR40, YL - PAR(28))
                CALL GGIP20 (0.0, IFL(2), NE, PAR(349), 1, 2,
     1              XL - PAR40, YL - PAR(28))
              ENDIF
  160       CONTINUE
  170     CONTINUE
        ENDIF
  180   IF (IGBL(50) .EQ. 0) THEN
          CALL PLA280 ('PLOT')
          IF (IGBL(3) .EQ. 13) THEN
            IPR(332) = 1
            CALL PLA015 (332, 1)
          ELSE IF (IGBL(3) .EQ. 26) THEN
            IPR(352) = 1
            CALL PLA015 (352, 1)
          ENDIF
          IF (IPR(308) .NE. 0) IGBL(3) = 8
          GOTO 1100
        ELSE
          IGBL(2) = 0
          CALL GEN038 (IGGT, 1, 80)
          GOTO 1310
        ENDIF
C * ISW = 135: ANIS
      ELSE IF (ISW .EQ. 135) THEN
        WRITE (LU27, '(A)') ICL(1:80)
        IF (IGBL(8) .EQ. -2) THEN
          IF (KL .EQ. 1) THEN
            KL0 = 1
          ELSE
            KL0 = 2
          ENDIF
          DO 9120 KLI = KL0, KL
            IAT1 = 0
            IF (KLI .GT. 1) THEN
              CALL PLUT13 (0, KLI, IAT1, XDUM)
              IF (IAT1 .GT. 0) THEN
                CALL PLUT29 (5, IFL(KLI), NQ2, 0)
              ENDIF
            ENDIF
 9120     CONTINUE
        ENDIF
        GOTO 1100
C * ISW = 140: ENDS
      ELSE IF (ISW .EQ. 140) THEN
        GOTO 1240
C * ISW = 143: NOMOVE
      ELSE IF (ISW .EQ. 143) THEN
        IF (IPR(17) .EQ. 0) THEN
          IF (KL .GT. 1 .AND. IFL(2)(1:3) .EQ. 'OFF') THEN
            IGBL(30) = 0
          ELSE
            IGBL(30) = 1
          ENDIF
        ENDIF
        GOTO 1100
C * ISW = 144: RESD
      ELSE IF (ISW .EQ. 144) THEN
        IF (IPR(50) .EQ. 1) THEN
          IPR(135) = NINT(FN(1))
        ELSE
          IF (IPR(136) .NE. 0) THEN
            IPR(136) = NINT(FN(1))
          ELSE IF (IPR(37) .EQ. IPR(69)) THEN
            IPR(136) = NINT(FN(1))
          ENDIF
        ENDIF
        GOTO 1100
C * ISW = 145: NOSORT OPTION
      ELSE IF (ISW .EQ. 145) THEN
        IGBL(33) = 0
        GOTO 1100
C * 147: HALL
      ELSE IF (ISW .EQ. 147) THEN
        GOTO 300
C * ISW = 152: PORTRAIT
      ELSE IF (ISW .EQ. 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)
        GOTO  1100
C * ISW = 170: FIT => END
      ELSE IF (ISW .EQ. 170) THEN
        GOTO 1260
      ENDIF
      GOTO 50
C * SPGR/LATT/SYMM/HALL - CARD
  300 IF ((ISW .EQ. 6 .OR. ISW .EQ. 9) .AND.
     1 (IGBL(8) .LE. 2) .AND.
     1     KL .EQ. 1 .AND. KN .EQ. 0) THEN
        WRITE (LU6, 99979) ICL(1:4)
        GOTO 1100
      ELSE IF (KL .EQ. 1 .AND. (KN .EQ. 9 .OR. KN .EQ. 12)) THEN
C * SYMM MATRIX INPUT: R11,R12,..,R33,(T1,T2,T3)
        ITRS = 15
        CALL SGSM (ICL, 0, FN, LU6, ITRS, IERR)
      ELSE
        IF (IPR(127) .EQ. 1 .OR. IPR(128) .EQ. 1) THEN
          ITRS = 16
        ELSE
          ITRS = 0
        ENDIF
        CALL SGSM (ICL, 0, XJX, LU6, ITRS, IERR)
      ENDIF
      CALL SGSM (ICL, 0, XXX, LU6, 18, IERR)
      SPGRNM(1) = ICL(1:26)
      IPR(48) = NINT(XXX(9))
      IF (IPR(48) .EQ. 0) THEN
        IF (IGBL(8) .NE. 4) THEN
          IPR(11) = 1
          WRITE (LU6, 99974)
        ENDIF
      ENDIF
      IF (IPR(48) .GT. 48) THEN
        IF (IPR(134) .NE. 9) WRITE (LU6, 99982)
        IPR(134) = 9
        PAR(42)  = 10.0
      ENDIF
      IF (ICL(12:12) .EQ. 'h') THEN
        PAR(148) = 120.0
      ELSE
        PAR(148) = 90.0
      ENDIF
      GOTO 1100
C * REAL OR POTENTIAL ATOM CARD
  360 IF (IPR(220) .EQ. 0 .AND. IPR(221) .EQ. 0) GOTO 50
      IF (IGBL(8) .EQ. 2) THEN
      ENDIF
      CALL PLUT03 (IER)
      IF (IER .NE. 0) IPR(72) = 2
      GOTO 1100
C * U/B
  370 IF (KL .EQ. 1) THEN
        GOTO 360
      ELSE
        GOTO 1100
      ENDIF
C * JOIN CARD - SETS UP CONNECTIONS
  500 IF (IPR(37) .GT. IPR(69)) THEN
        IMD      = 1
        IPR(110) = 0
        IF (KL .EQ. 1) THEN
          IF (IPR(17) .EQ. 0) THEN
            IMD = 0
          ELSE
            WRITE (LU6, 99971)
            GOTO 1100
          ENDIF
        ELSE IF (KL .EQ. 2) THEN
          J215 = IFL(2)(1:5)
          IF (J215 .EQ. 'INTRA') THEN
            IF (IPR(17) .EQ. 0) IMD = 0
          ELSE IF (J215 .EQ. 'UNIQU') THEN
            IF (IPR(17) .EQ. 0) IMD = 0
          ELSE IF (J215 .EQ. 'NONE ') THEN
            IPR(52) = IPR(68)
            IPR(53) = IPR(68)
            IPR(17) = 1
            IF (IPR(75) .EQ. 0) THEN
              CALL PLUT33
              IPR(75) = 1
              CALL PLUT17 (1555.0 + 1.0 / PAR(42), 0, MADDR, LU6)
              DO 510 III = 1, 3
                RCG(1, III) = RA(NP43 + III)
  510         CONTINUE
              RCG(1, 4) = IPR(37) - IPR(69)
            ENDIF
            GOTO 1100
          ELSE IF (J215 .EQ. 'HBOND' .OR. J215 .EQ. 'XBOND') THEN
            IFL(2)(1:5) = 'RADII'
            IFL(3)(1:5) = 'INTER'
            IF (J215 .EQ. 'HBOND') THEN
              IFL(4)(1:6) = 'HBONDS'
            ELSE
              IFL(4)(1:6) = 'XBONDS'
            ENDIF
            IFL(5)(1:6) = 'EXPAND'
            IPR(220) = 5
            KL       = IPR(220)
            GOTO 500
          ENDIF
        ELSE IF (KL .GE. 3) THEN
          IF (IPR(17) .EQ. 0) THEN
            IF (IFL(3)(1:5) .EQ. 'INTER') THEN
              CALL PLUT05
              IF (IPR(72) .NE. 0) STOP '301'
            ENDIF
          ENDIF
        ENDIF
        GOTO 530
      ELSE
        WRITE (LU6, 99993)
        IPR(72) = 3
        GOTO 1100
      ENDIF
C * DETACH CARD
  520 IMD = -1
      IF (KL .EQ. 1) THEN
        IPR(52) = IPR(68)
        IPR(53) = IPR(68)
        IPR(17) = -1
        GOTO 1100
      ENDIF
      IF (IPR(37) .LE. IPR(69)) THEN
        WRITE (LU6, 99993)
        IPR(72) = 4
        GOTO 1100
      ENDIF
      IF (IPR(52) .EQ. 0) THEN
        CALL PLUT05
        IF (IPR(72) .NE. 0) THEN
          IPR(72) = 0
          GOTO 50
        ENDIF
      ENDIF
  530 IPR(17) = IMD
      CALL PLUT05
      IF (IPR(72) .NE. 0) THEN
        IPR(72) = 0
        GOTO 50
      ENDIF
      IF (IABS(IPR(161)) .EQ. 1) THEN
        IMD      = 1
        IF (IPR(161) .EQ. -1) THEN
          IFL(2)   = IFL(KL + 1)
        ELSE
          IFL(3)   = IFL(KL + 1)
          IPR(220) = 3
          KL       = IPR(220)
        ENDIF
        IPR(161) = 0
        IF (IPR(4) .NE. 0 .AND. RADR(N1, 1) .EQ. 0.0) CALL PLUT21 (-1)
        GOTO 530
      ENDIF
      GOTO 1100
  610 IPR(130) = 0
      IF (IPR(100) .EQ. 0) CALL PLUT33
      IPR(8)   = IPR(74)
      IPR(18)  = 0
      IPR(96)  = 0
      IPR(345) = 0
      IPR(346) = 0
      IPR(139) = 0
      PAR(130) = 0.0
      PAR(131) = 0.0
      PAR(125) = 5.25
C * LOOP OVER SUB-KEYWORD OPTIONS
      IF (KL .GT. 1) THEN
        DO 620 K = 2, KL
          JK13 = IFL(K)(1:3)
          IF (JK13 .EQ. 'SPO') THEN
C * SET SPOT ON
            IPR(96) = 1
C * CPK/ROD/SOLID/STRAW GLOBE MODE
          ELSE IF (JK13 .EQ. 'GLO') THEN
            IPR(139) = 8
          ELSE IF (JK13 .EQ. 'CON') THEN
C * CPK/ROD/SOLID/STRAW CONTOUR MODE
            IPR(139) = 1
            IF (KN .EQ. 1) IPR(8) = NINT(FN(1))
          ELSE IF (JK13 .EQ. 'BLA') THEN
C * CPK/ROD/SOLID/STRAW BLACK MODE
            IPR(139) = 6
          ELSE IF (JK13 .EQ. 'SEG') THEN
C * CPK/ROD/SOLID/STRAW SEGMENT MODE
            IPR(139) = 4
C * CPK/ROD/SOLID/STRAW CROSS MODE
          ELSE IF (JK13 .EQ. 'CRO') THEN
            IPR(139) = 7
C * CPK/ROD/SOLID/STRAW PARALLEL MODE
          ELSE IF (JK13 .EQ. 'PAR') THEN
            IPR(139) = 9
C * CPK/ROD/SOLID/STRAW MERIDIAN MODE
          ELSE IF (JK13 .EQ. 'MER') THEN
            IPR(139) = 10
C * CPK/ROD/SOLID/STRAW DOTS
          ELSE IF (JK13 .EQ. 'DOT') THEN
            IPR(139) = 5
          ELSE IF (JK13 .EQ. 'NUC') THEN
C * CPK/ROD/SOLID NUCL MODE
            IPR(18) = 1
          ELSE IF (JK13 .EQ. 'SHA') THEN
C * CPK/ROD/SOLID SHADE MODE
            IPR(139) = 3
            IF (KN .GE. 2) THEN
              PAR(135) = FN(1)
              PAR(136) = FN(2)
              IF (KN .GT. 2)  PAR(134) = FN(3)
            ENDIF
          ELSE IF (JK13 .EQ. 'STI') THEN
C * CPK STICK MODE
            IF (IABS(IPR(4)) .EQ. 3) THEN
              IPR(4)      = -3
            ENDIF
          ELSE IF (JK13 .EQ. 'COL') THEN
C * CPK/ROD/SOLID COLOR (SHADE) MODE
            IPR(346) = 1
            IF (K .EQ. 2 .AND. K .EQ. KL) THEN
            ENDIF
          ELSE IF (JK13 .EQ. 'NET') THEN
C * CPK/ROD/SOLID NET MODE
            IPR(139) = 2
            IF (KN .EQ. 2) THEN
              IPR(85) = NINT(FN(1))
              IPR(86) = NINT(FN(2))
            ENDIF
          ELSE IF (JK13 .EQ. 'BWC') THEN
C * CPK/ROD/SOLID BWCOL MODE
            IPR(345) = 1
          ENDIF
  620   CONTINUE
      ENDIF
      GOTO 1100
C * ARU/MOLES (TO BE PLOTTED) - INSTRUCTION (SKIP MOLE IN SHELXS.RES)
  700 IF (IGBL(8) .NE. 2) THEN
        IF (KN .EQ. 0 .AND. KL .EQ. 1) THEN
          KL = 2
          IFL(1) = 'LIST'
          IFL(2) = 'ARU'
          GOTO 1190
        ELSE
          CALL PLUT17 (0.0, 1001, MADDR, LU6)
          MODE = 0
          IF (KL .GT. 1) THEN
            IF (IFL(2)(1:4) .EQ. 'BOND') THEN
              KLM  = 3
              KADD = 64
            ELSE IF (IFL(2)(1:3) .EQ. 'BWC') THEN
              KLM  = 3
              KL   = 3
              KADD = 0
              GOTO 720
            ELSE
              KLM  = 2
              KL   = 2
              KADD = 0
            ENDIF
            DO 710 K = 1, 9
              IF (IFL(KLM)(1:3) .EQ. COLR(K)(1:3)) THEN
                MODE = K + KADD
                KL   = 1
                GOTO 740
              ENDIF
  710       CONTINUE
  720       DO 730 K = 1, 17
              IF (IFL(KLM)(1:7) .EQ. BWCT(K)(1:7)) THEN
                MODE = K + 32 + KADD
                KL   = 1
                GOTO 740
              ENDIF
  730       CONTINUE
          ENDIF
  740     IF (KN .GT. 0 .OR. KL .GT. 1) THEN
            IF (KN .GT. 0) THEN
              DO 750 K = 1, KN
                FNK = FN(K)
                CALL PLUT17 (FNK, MODE, MADDR, LU6)
                IF (IPR(43) .GT. 1) CALL PLUT35 (FNK, 0)
  750         CONTINUE
            ENDIF
            IF (KL .GT. 1) THEN
              DO 760 K = 2, KL
                IF (IFL(K)(2:2) .EQ. ' ') THEN
                  CALL GEN105 (1, IFL(K)(1:1), K0)
                  IF (K0 .GT. 0) THEN
                    K0 = IPR(75) + K0 - ICHAR('A')
                    IF (K0 .LT. IPR(42)) THEN
                      XDUM = ABS(MOL(1, K0 + 1) / PAR(42))
                      CALL PLUT17 (XDUM, MODE, MADDR, LU6)
                    ENDIF
                  ENDIF
                ENDIF
  760         CONTINUE
            ENDIF
          ENDIF
        ENDIF
      ENDIF
      GOTO 1100
C * INCLUDE / EXCLUDE / OMIT / DELETE - INSTRUCTION
  850 IF (IGBL(8) .NE. 2) THEN
        IF (KL .GT. 1) THEN
          CALL PLUT09 (N, ISW)
        ELSE IF (KL .EQ. 1 .AND. KN .GT. 0) THEN
          DO 860 I = 1, KN
            FN(I) = ((N * 2) - 1) * FN(I)
  860     CONTINUE
          GOTO 700
        ENDIF
      ENDIF
C * GENERAL ERROR MESSAGE
 1100 IF (IPR(72) .GT. 0) THEN
        IF (IGBL(5) .EQ. LU5) WRITE (LU6, 99983) IPR(72), CHAR(7)
        IF (IPR(72) .EQ. 24) THEN
          ISW = 140
          GOTO 1240
        ENDIF
        IPR(72) = 0
        GOTO 1100
      ELSE
        IF (IGBL(5) .EQ. LU5) THEN
          IF (IFL(1)(1:3) .NE. 'REN') THEN
            WRITE (LU27, '(A)') ICL(1:80)
          ENDIF
          IF (IFL(1)(2:4) .EQ. 'ROT' .OR. IFL(1)(1:4) .EQ. 'VIEW') THEN
            IF (IGBL(35) .EQ. 1) THEN
              IPR(221) = 0
              KN       = IPR(221)
              IPR(220) = 1
              KL       = IPR(220)
              GOTO 1280
            ELSE
              GOTO 40
            ENDIF
          ENDIF
        ENDIF
        IF (IPR(170) .EQ. 2) THEN
          IF (IPR(140) .GT. 0) THEN
            DO 1110 I = 1, IPR(39)
              CALL PLUT15 (-6, I,  5, IVAL)
              IF (IVAL .EQ. IPR(140)) THEN
                CALL PLUT15 (-1, I,  27, IVAL)
                IF (IVAL .EQ. 1) THEN
                  IPR(140) = -I
                  GOTO 1120
                ENDIF
              ENDIF
 1110       CONTINUE
            IPR(140) = 0
          ENDIF
 1120     WRITE (LU6, 99964)
          CALL PLUT01 (2)
          CALL PLUT21 (-1)
          IPR(75) = 0
          IPR(17) = 0
          IGBL(5) = LU23
          CALL GEN108 (LU23, 0)
        ENDIF
      ENDIF
      GOTO 45
C * LIST/INFO ON DISPLAY OR TRAILER LISTING OF
C * SYMM/ATOM(S)/BOND(S)/ARU/MOLES/LINES LISTS ETC.
 1190 IF (KL .GT. 1 .AND.
     1   (IFL(2)(1:3) .EQ. 'PAR' .OR. IFL(2)(1:3) .EQ. 'IPR') .OR.
     2    IPR(37) .GT. IPR(69)) THEN
        IPR(90)  = 510
        IPR(147) = 0
        IF (KL .GE. 2) THEN
          IPR(90)  = 0
          IGBL(31) = 0
          DO 1200 I = 2, KL
            JK13 = IFL(I)(1:3)
            IF (JK13 .EQ. 'CEL') THEN
              WRITE (BCD, 99980) (PAR(100 + J), J = 1, 3),
     1        (ACOS(PAR(103 + J)) * GL(5), J = 1, 3), PAR(126), CHAR(0)
              IF (IGBL(25) * IGBL(32) .EQ. 1) THEN
                IGBL(23) = - IABS(IGBL(23))
                CALL GGIP (-999.0, 5.0 + FLOAT(IGBL(68)), 78.0, 111)
              ELSE
                WRITE (LU6, 99966) BCD
              ENDIF
              GOTO 40
            ELSE IF (JK13 .EQ. 'INT') THEN
              IGBL(31) = 1
            ELSE IF (JK13 .EQ. 'RES') THEN
              IF (KN .EQ. 1) IPR(147) = NINT(FN(1))
            ELSE IF (JK13 .EQ. 'IPR' .OR.
     1               JK13 .EQ. 'PAR' .OR.
     2               JK13 .EQ. 'IGB' .OR.
     3               JK13 .EQ. 'GL ') THEN
              CALL PLA206 (-1, JK13)
              CALL GGIP(0.0,0.0,0.0,6)
              GOTO 40
            ELSE IF (JK13 .EQ. 'SYM') THEN
              IPR(90) = IPR(90) + 2
            ELSE IF (JK13 .EQ. 'ATO') THEN
              IPR(90) = IPR(90) + 4
            ELSE IF (JK13 .EQ. 'BON') THEN
              IPR(90) = IPR(90) + 8
            ELSE IF (JK13 .EQ. 'LIN') THEN
              IPR(90) = IPR(90) + 16
            ELSE IF (JK13 .EQ. 'ARU') THEN
              IPR(90) = IPR(90) + 32
            ELSE IF (JK13 .EQ. 'MOL') THEN
              IPR(90) = IPR(90) + 32
            ELSE IF (JK13 .EQ. 'MAT') THEN
              IPR(90) = IPR(90) + 64
            ELSE IF (JK13 .EQ. 'STA')  THEN
              IPR(90) = IPR(90) + 128
            ELSE IF (JK13 .EQ. 'TYP') THEN
              IPR(90) = IPR(90) + 256
            ELSE IF (JK13 .EQ. 'FLA') THEN
              IPR(90) = IPR(90) + 512
            ELSE
              CALL PLUT13 (0, -I , IAT, XDUM)
              IF (IAT .EQ. 0) THEN
                IPR(72) = 21
                GOTO 1100
              ENDIF
            ENDIF
 1200    CONTINUE
        ENDIF
        CALL PLUT12
      ELSE
        IPR(72) = 22
      ENDIF
      GOTO 1100
C * UNCHECKED EOF OR CTRL_D - HANDLING
 1230 IF (IGBL(5) .EQ. LU1) THEN
        IF (IPR(39) .EQ. 0 .AND. IPR(50) .EQ. 1) GOTO 1260
        IPR(47)  = IPR(47) + 1
        IF (IPR(47) .GT. 1) GOTO 1260
      ELSE IF (IGBL(5) .EQ. LU23) THEN
        CALL GEN108 (LU23, 0)
        IGBL(5) = LU3
        GOTO 50
      ELSE IF (IGBL(5) .EQ. LU3) THEN
        CALL GEN108 (LU3, 0)
        IGBL(5)  = LU5
        IGBL(24) = IABS(IGBL(24))
        IF (IGBL(50) .EQ. 0) THEN
          IF (IGBL(24) * IGBL(25) .NE. 0) CALL PLA280 ('PLOT')
        ENDIF
        IPR(72) = 0
        GOTO 50
      ELSE IF (IGBL(5) .EQ. LU5) THEN
        GOTO 1260
      ENDIF
C * END / ENDS / EOF - HANDLING
 1240 IF (ISW .EQ. 140) THEN
        IF (IGBL(5) .EQ. LU1) WRITE (LU6, 99989) JID(1:19)
        IF (IGBL(5) .EQ. LU5) THEN
          ICL(1:4) = '    '
          GOTO 1250
        ENDIF
      ELSE
        IF (IGBL(5) .EQ. LU5) THEN
          IF (IGBL(8) .NE. 0) THEN
            IGBL(8) = IABS(IGBL(8))
            IF (IGBL(8) .NE. 2) THEN
              IGBL(5) = LU1
              GOTO 1250
            ENDIF
          ENDIF
          GOTO 1260
        ENDIF
      ENDIF
      IF (IABS(IGBL(8)) .EQ. 2) THEN
        IPR(47)  = IPR(47) + 1
        IGBL(8)  = 2
      ENDIF
      IGBL(8) = - IABS(IGBL(8))
      CALL GEN108 (LU3, 0)
      IF (IGBL(5) .EQ. LU1) THEN
        IGBL(5) = LU23
        CALL GEN108 (LU23, 0)
        GOTO 50
      ENDIF
      IF (ICL(1:4) .NE. 'ENDS') THEN
        IF (IGBL(5) .EQ. LU3 .AND. IPR(47) .EQ. 0) GOTO 1250
        IF (IPR(47) .GT. 0) GOTO 1260
      ENDIF
      IF (IGBL(5) .EQ. LU23) THEN
        IGBL(5) = LU3
        GOTO 50
      ENDIF
      IF (IGBL(5) .EQ. LU3) THEN
        IGBL(5)  = LU5
        IGBL(24) = IABS (IGBL(24))
        GOTO 50
      ENDIF
 1250 IPR(61) = - 1
      GOTO 30
C * ENTRY FROM CROT, XROT, YROT, ZROT
 1280 IPR(82)  = 0
      IPR(145) = 0
      IF (KL .GT. 1) THEN
        DO 1300 K = 2, KL
          JK13 = IFL(K)(1:3)
          IF (JK13 .EQ. 'LIS') THEN
            IPR(145) = 1
          ELSE IF (JK13 .EQ. 'MOG' .OR. JK13 .EQ. 'POV'
     1                  .OR. JK13 .EQ. 'PDB') THEN
            IPR(130) = 0
            IGBL(67) = 1
            IPR(82)  = 1
            IF (JK13 .EQ. 'MOG') THEN
              IPR(10) = 0
              IGBL(4) = IGBL(4) + 1
              WRITE (LU26, 99995) IGBL(4), IGBL(4)
            ELSE IF (JK13 .EQ. 'PDB') THEN
              OPEN (UNIT = LU31,  FILE = NAME(1)(1:KNM(1))//'.ras',
     1                                          STATUS = 'UNKNOWN')
              IPR(10)  = 2
              IGBL(11) = 1
              CALL GEN108 (LU31, 0)
              WRITE (LU31, '(''HEADER'', 3X, A)') JID(1:70)
              IPR(340) = 1
            ELSE
              OPEN (UNIT = LU28,  FILE = NAME(1)(1:KNM(1))//'.pov',
     1                                          STATUS = 'UNKNOWN')
              CALL GEN108 (LU28, 0)
              IPR(10)  = 1
              IGBL(98) = 1
              IF (IGBL(101) .EQ. 0) THEN
                BCKG = 'White '
                BCOL = 'Bronze'
                HCOL = 'rgb <0.6,0.6,0.6>'
              ELSE IF (IGBL(101) .EQ. 1) THEN
                BCKG = 'SummerSky '
                BCOL = 'LightGray'
                HCOL = 'White'
              ELSE IF (IGBL(101) .EQ. 2) THEN
                BCKG = 'Black '
                BCOL = 'LightGray'
                HCOL = 'White'
              ELSE IF (IGBL(101) .EQ. 3) THEN
                BCKG = 'Scarlet '
                BCOL = 'LightGray'
                HCOL = 'White'
              ELSE IF (IGBL(101) .EQ. 4) THEN
                BCKG = 'Silver'
                BCOL = 'Bronze'
                HCOL = 'rgb <0.6,0.6,0.6>'
              ENDIF
              WRITE (LU28, 99992) ABS(PAR(18)), BCOL, HCOL
              WRITE (LU28, 99991) BCKG
              DO 1290 I = 3, IAN
                ICOL = IACL(I)
                IF (ICOL .GT. 1 .AND. ICOL .LT. 9) THEN
                  CLR = COLR(ICOL)(1:7)
                  CALL GEN020 (0, CLR, 2, 7)
                ELSE
                  CLR = 'Coral  '
                ENDIF
                N2 = IEL(IEN(I))
                N1 = N2 / 100 + ICHAR('A') - 1
                N2 = MOD(N2, 100)
                IF (N2 .EQ. 0) THEN
                  N2 = ICHAR(' ')
                ELSE
                  N2 = N2 + ICHAR('a') - 1
                ENDIF
                WRITE (LU28, 99990) CHAR(N1), CHAR(N2), CLR
 1290         CONTINUE
              WRITE (LU28, 99988)
            ENDIF
          ELSE
            IPDC = -3
            IF (IFL(K)(1:1) .EQ. 'M' .OR. IFL(K)(1:1) .EQ. 'C')
     1        IPDC = -2
            CALL GGIP (-999.0, 0.0, 0.0, IPDC)
            IF (IFL(K)(1:1) .EQ. 'D') THEN
              IPDC = 2
              CALL GGIP (-999.0, 0.0, 0.0, IPDC)
            ENDIF
          END IF
 1300   CONTINUE
      ENDIF
      IF (IPR(37) .GT. IPR(69)) THEN
        IF (IPR(17) .EQ. 0) THEN
          CALL PLUT05
          IF (IPR(72) .NE. 0) GOTO 1100
        ENDIF
        IF (IGBL(67) .EQ. 0) THEN
          WRITE (LU6, 99996)
          IPR(220)    = 2
          KL          = IPR(220)
          IPR(221)    = 0
          KN          = IPR(221)
          IFL(2)(1:2) = 'MI'
          WRITE (LU6, 99996)
          CALL PLUT06
        ENDIF
      ELSE
        WRITE (LU6, 99993)
        IPR(72) = 24
      ENDIF
      IF (IPR(72) .NE. 0) GOTO  1100
      GOTO 1310
C * END OF JOB (STOP/EXIT)
 1260 IGBL(2) = -1
C * EXECUTE THIS PLOT INSTRUCTION / ALL PLOTTING IS DONE IN PLUT02
C * END OF LOOP: TEST (IGBL(2) = 0)
 1310 IF (IGBL(2) .GT. 0) THEN
        CALL PLUT02
        GOTO 20
      ELSE
        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)
        IF (IGBL8 .NE. 0) THEN
          IGBL(30) = IGBL30
          IGBL(8)  = IGBL8
        ENDIF
      ENDIF
      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 ('COLOR BONDING BYATOM MOL ', I3, /,
     1        'LABEL - ATOM NE',/,
     2        'MAKELABEL ATOM_TYPE ATOM AR', /,
     3        'ORIGIN MOL ', I3)
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 (/, ':: End Plot nr.', I3, ' - CPU Time:', F7.1,
     1  ' (TOTAL', F8.1, ')')
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)
99974 FORMAT (/, ':: DATA will be SKIPPED until END-OF-SECTION')
99973 FORMAT (':: Transformation on Input Data: Det =', F5.1)
99971 FORMAT (':: JOIN Instruction Ignored')
99970 FORMAT (':: TRNS Instruction NOT ALLOWED here and IGNORED')
99968 FORMAT (/, 'HFIX ', A, ' mn[',I3,'] or Q[uit] :', $)
99967 FORMAT ('** ', A)
99966 FORMAT (/, A, /)
99965 FORMAT (A)
99964 FORMAT (':: RESET executed in view of deleted atom(s)',
     1        ' or change of Element type')
      END
      SUBROUTINE PLUT01 (IMODE)
      PARAMETER (NP4=9,NP9=118,NP10=16,NP12=600,NP13=500,NP14=64,
     1 NP17=99,NPVD=40000000,NP22=256,NP23=18000,NP31=30,NP32=63,
     2 NP35=110,NP38=125,NP39=30,NP43=12,NP45=2048)
      COMMON // MOL(2, NP23), RA(NPVD)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLUTO/ IPPR(129, 3), IBT(32), TRL(3), ROM(3, 3), R(3, 3),
     1 RP(NP14), XJX(12), XXX(12), YYY(12), TMX(3, 3), SHFT(3),
     2 XYZOR(3), XYZR(3),  ZU(15), OM(3, 3), RCG(4, NP32), TMY(3, 3),
     3 XYZPL(6), A(3, 3), XYZK(8), KRS(NP32), NCRS(9), NPRS(17)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /Q/ ICL, IFL(NP17)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9),
     1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10),
     2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10),
     3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770)
      COMMON /MEN/ MENA(25, NP31), MENS(25, NP31), MENU(50, NP31),
     1   MNH(NP35)
      COMMON /CGGT/ IGGT
      CHARACTER IGGT*80
      COMMON /CGG11/ BCD, SBCD
      CHARACTER BCD*132, SBCD*132
      COMMON /FNAME/ KNM(8), KXT, KNM16
      COMMON /NAMES/ NAME(8), EXTENS, PROGNM, FNLU1, FNLU16, RDTYPE
      CHARACTER NAME*80, EXTENS*9, PROGNM*28, FNLU1*80, FNLU16*80,
     1          RDTYPE*7
      IF (IMODE .EQ. -1) THEN
        CALL GEN038 (IGGT, 1, 80)
        IGBL(100) = 0
        IGBL(2)   = 0
        IGBL(4)   = 0
        IGBL(5)   = 0
        IGBL(19)  = - IABS(IGBL(19))
        IGBL(23)  = 2
        IGBL(24)  = - IABS(IGBL(24))
        IGBL(27)  = 1
        IGBL(32)  = - IABS(IGBL(32))
        IPR(61)   = -1
        PAR(43)   = CPUTIM()
        SBCD      = CHAR(0)
        IF (IGBL(3) .EQ. 8 .OR. IGBL(3) .EQ. 12 .OR. IGBL(3) .EQ. 13
     1                     .OR. IGBL(3) .EQ. 26) THEN
          IGBL(8)  = IABS(IGBL(8))
          IF (IGBL(8) .EQ. 3 .OR. IGBL(8) .EQ. 2) IGBL(71) = 0
          IF (IGBL(3) .EQ. 26) IGBL(75) = 1
          IF (IGBL(20) .EQ. 1) THEN
            NAME(3) = 'satom'
            KNM(3)  = 5
            EXTENS  = 'spf'
            KXT     = 3
            NAME(1) = 'satom'
            KNM(1)  = 5
            IGBL(26) = 0
            OPEN (UNIT = 98, STATUS='SCRATCH', FORM = 'FORMATTED')
            OPEN (UNIT = LU3, STATUS = 'SCRATCH', FORM = 'FORMATTED')
            OPEN (UNIT = LU23, FILE = NAME(1)(1:KNM(1))//'.def',
     1                                       STATUS = 'UNKNOWN')
            OPEN (UNIT = LU26,  FILE = NAME(1)(1:KNM(1))//'.new',
     1                                         STATUS = 'UNKNOWN')
            OPEN (UNIT = LU27,  FILE = NAME(1)(1:KNM(1))//'.pjn',
     1                                         STATUS = 'UNKNOWN')
          ENDIF
          FNLU1 = NAME(3)(1:KNM(3))//'.'//EXTENS
          KNMXT = KNM(3) + KXT + 1
          IF (IGBL(3) .EQ. 12 .OR. IGBL(3) .EQ. 13 .OR.
     1        IGBL(3) .EQ. 26) THEN
            IGBL(48) = 1
            IGBL(23) = 3
          ENDIF
        ELSE
          IGBL(8) = 1
          FNLU1   = NAME(3)(1:KNM(3))//'.eld'
          KNMXT   = KNM(3) + 4
        ENDIF
        IF (IGBL(21) .EQ. 0 .AND. IGBL(3) .NE. 8) THEN
          CALL GEN108 (LU23, 0)
          WRITE (LU23, 99995)
          IF (IGBL(75) .EQ. 1) WRITE (LU23, 99997)
          IF (IGBL(87) * IGBL(67) .NE. 0) THEN
            WRITE (LU23, 99994) GL(28), GL(29), GL(30)
            IF (IGBL(87) .LT. 0) WRITE (LU23, 99993)
          ENDIF
          IF (IGBL(3) .EQ. 13 .AND. IGBL(50) .GT. 0) THEN
            WRITE (LU23, 99996)
          ELSE
            WRITE (LU23, 99992)
          ENDIF
          CALL GEN108 (LU23, 0)
        ENDIF
        OPEN (UNIT = LU1, FILE = FNLU1, STATUS = 'OLD', ERR = 4020)
        WRITE (LU6, 99991) FNLU1(1:KNMXT)
        GOTO 80
 4020   WRITE (LU6, 99990) FNLU1(1:KNMXT)
        LU1 = LU5
        GOTO 80
      ELSE IF (IMODE .EQ. 0) THEN
        IF (IPR(61) .EQ. 0) GOTO 80
        CALL GEN074 (PAR, 0.0, 1, NP13)
        CALL GEN048 (0, I, 0, I)
        IGBL(5) = LU1
        WRITE (LU6, 99999) IGBL(9)
        IGBL(8) = IABS(IGBL(8))
        IAN     = 4
        DO 20 I = 1, NP10
          IACL(I) = JACL(I)
          IF (I .GT. IAN) THEN
            IEN(I) = 0
          ELSE
            IEN(I) = I
            RADR(I, 3) = REL(IEN(I))
            RADR(I, 4) = ABS(VDWR(IEN(I)))
          ENDIF
          IENLB(I)   = 0
          RADR(I, 2) = 0.0
          RADR(I, 1) = 0.0
   20   CONTINUE
        CALL GEN097 (MNH, 1, NP35, 0)
        MNH(6) = 2
        MNH(7) = 2
        DO 30 I = 1, 31
          IBT(I) = 2**(I - 1)
   30   CONTINUE
        CALL GEN097 (IPPR, 1, 3 * 129, 0)
        DO 200 I = 1, 9
          NCRS(I) = I
  200   CONTINUE
        DO 201 I = 1, 17
          NPRS(I) = I
  201   CONTINUE
        DO 240 I = 1, 2
          DO 250 J = 1, NP23
            MOL(I, J) = 0
  250     CONTINUE
  240   CONTINUE
        DO 251 I = 1, 17
          CALL GEN048 (5, MOL(2, I), 1, I)
  251   CONTINUE
        DO 252 I = 1, 17
          CALL GEN048 (5, MOL(2, I), 6, I)
          CALL GEN048 (5, MOL(2, I), 11, I)
  252   CONTINUE
        IPPR(1, 1) = 1000
        IPPR(1, 2) = 0
        IPPR(1, 3) = 1
        PAR(24)    = 0
        PAR(22) = 0.3
        PAR(45) = 0.1
        PAR(42) = 100.0
        CALL GEN097 (IPR, 1, NP12, 0)
        CALL GEN038 (JID, 1, 80)
        IPR(460) = 3
        IPR(551) = 3
        IPR(9)  = 1
        IPR(50) = 1
        IPR(69) = 8
        IPR(37) = IPR(69)
        CALL SGSM (ICL, 0, XJX, LU6, 1, IERR)
        IPR(48) = 1
        IPR(134) = NP32
        IPR(36) = 0
        IPR(80) = NPVD - 100000
        IPR(76) = 100
        IPR(103) = 4035
        IPR(104) = 3060
        IPR(106) = 2120
        IPR(176) = 1
        CALL GEN038 (ICL, 1, 80)
        CALL PLUT29 (0, ICL, NQ1, 0)
        DO 60 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 50 J = 1, 3
            IVERM            = IVERM / 2
            NMK              = NM0 / IVERM
            NM0              = NM0 - NMK * IVERM
            RA(I * NP43 + J) = FLOAT(NMK)
   50     CONTINUE
          RA(I * NP43 + 7) = ICHAR(' ')
   60   CONTINUE
        RA(NP43 + 7)     = ICHAR('O')
        RA(2 * NP43 + 7) = ICHAR('c')
        RA(3 * NP43 + 7) = ICHAR('b')
        RA(5 * NP43 + 7) = ICHAR('a')
      ELSE
        IF (IMODE .EQ. 1) THEN
          WRITE (LU6, 99998)
          DO 70 I = IPR(69) + 1, IPR(37)
            IVAL = 0
            CALL PLUT15 (1, I, 42, IVAL)
            IVAL = 0
            CALL PLUT15 (4, I, 37, IVAL)
            IVAL = 1
            CALL PLUT15 (1, I, 27, IVAL)
   70     CONTINUE
        ELSE IF (IMODE .EQ. 2) THEN
          IPR(37) = IPR(39)
          IPR(38) = IPR(39)
          DO 75 I = IPR(69) + 1, IPR(37)
            IVAL = 0
            CALL PLUT15 (16, I, 1, IVAL)
            IF (IPR(136) .EQ. IPR(69)) THEN
              IVAL = 1
            ENDIF
            CALL PLUT15 (6,  I, 5, IVAL)
            IVAL = 0
            CALL PLUT15 (3,  I, 24, IVAL)
            IVAL = 0
            CALL PLUT15 (4,  I, 33, IVAL)
   75     CONTINUE
        ENDIF
      ENDIF
      CALL GEN038 (IGGT, 1, 80)
      IPR(142) = 0
      IPR(42)  = 0
      IPR(43)  = 0
      IPR(44)  = 0
      IPR(52)  = IPR(68)
      IPR(53)  = IPR(68)
      IF (IMODE .NE. 2) THEN
        CALL GEN021 (R, 1)
      ELSE IF (IMODE .EQ. 2) THEN
        GOTO 80
      ENDIF
      PAR(2) = 0.4
      PAR(5)  = 0.09
      PAR(3)  = 0.1
      PAR(4)  = 0.01
      PAR(9)  = 0.35
      PAR(10) = 0.40
      PAR(11)  = 1.0
      PAR(21) = 0.5
      PAR(349) = 0.25
      PAR(12) = 60.0
      PAR(13) = 0.9
      PAR(14) = 0.4
      PAR(15) = 0.0
      PAR(16) = 0.0
      PAR(17) = 3.0
      PAR(50) = (4.0 - IGBL(46)) / 3.0
      PAR(18) = - PAR(50)
      PAR(19) = 6.0 / 7.0
      PAR(25) = 1.0
      PAR(23) = 0.0195
      PAR(26) = 0.7
      PAR(36) = 0.1
      PAR(38) = 0.0
      PAR(39) = 0.2
      PAR(44) = 0.25
      PAR(48) = 0.0
      PAR(51) = 25.0
      PAR(52) = 15.0
      PAR(53) = 1.90
      PAR(54) = 0.15
      PAR(58) = 0.10
      PAR(60) = -100.0
      PAR(70) = 0.2
      PAR(75) = 0.01
      PAR(97) = 100.0
      PAR(125) = 5.25
      PAR(127) = - PAR(2)
      PAR(134) = 0.15
      PAR(135) = 120.0
      PAR(136) = -45
      PAR(140) = 0
      PAR(145) = 1.0
      PAR(149) = 0.05
      PAR(150) = 0.001
      PAR(350) = 0.50
      PAR(351) = 0.5
      PAR(352) = 0.5
      PAR(354) = 0.3
      IPR(46)   = 0
      IPR(116) = 0
      IPR(4)   = 0
      IPR(74)  = 8
      IPR(15)  = 0
      IPR(17)  = 0
      IPR(18)  = 0
      IPR(54)  = 7
      IPR(65) = 1
      IPR(71)  = 1
      IPR(85)  = 24
      IPR(86)  = 24
      IPR(107) = 2
      IPR(109) = 0
      IPR(110) = 0
      IPR(111) = 4
      IPR(112) = 13
      IPR(117) = 0
      IPR(124) = 5000
      IPR(130) = 0
      IPR(131) = 4
      IPR(132) = 24
      IPR(152) = 100000
      IPR(153) = 0
      IPR(154) = 1
      IPR(165) = 2
      IPR(166) = 1
      IPR(171) = 1024
      IPR(172) = 768
      IPR(212) = 1
      IPR(480) = 11
      IPR(19)  = 1
      IPR(5)   = 1
      IPR(6)   = 0
      IPR(7)   = 1
      IF (IGBL(50) .EQ. 0) THEN
        IF (IGBL(20) .NE. 0) IPR(308) = 1
      ENDIF
   80 RETURN
99999 FORMAT (/, ':: Full Init - PLATON/PLUTON (', I8, ') - ',
     1 'type  HELP for information', /, 42X,
     2 ' or   PLOT for default plot', //,
     3 ' ********************************************************',/
     4 ' >> PLEASE type ''MENU OFF'' when you dont want the      <<',/,
     5 ' >>              MENU feature (X-window only!)         <<',/,
     6 ' ********************************************************',/)
99998 FORMAT (':: Partial Init')
99997 FORMAT ('LABEL')
99996 FORMAT ('PLOT CAL')
99995 FORMAT ('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 PLUT02
      PARAMETER (NP0=6,NP4=9,NP9=118,NP10=16,NP12=600,NP13=500,
     1 NP14=64,NP17=99,NPVD=40000000,NP22=256,NP23=18000,NP32=63,
     2 NP37=175,NP38=125,NP39=30,NP43=12,NP45=2048)
      COMMON // MOL(2, NP23), RA(NPVD)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLUTO/ IPPR(129, 3), IBT(32), TRL(3), ROM(3, 3), R(3, 3),
     1 RP(NP14), XJX(12), XXX(12), YYY(12), TMX(3, 3), SHFT(3),
     2 XYZOR(3), XYZR(3),  ZU(15), OM(3, 3), RCG(4, NP32), TMY(3, 3),
     3 XYZPL(6), A(3, 3), XYZK(8), KRS(NP32), NCRS(9), NPRS(17)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /Q/ ICL, IFL(NP17)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9),
     1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10),
     2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10),
     3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770)
      COMMON /NAMES/ NAME(8), EXTENS, PROGNM, FNLU1, FNLU16, RDTYPE
      CHARACTER NAME*80, EXTENS*9, PROGNM*28, FNLU1*80, FNLU16*80,
     1          RDTYPE*7
      COMMON /CGG11/ BCD, SBCD
      CHARACTER BCD*132, SBCD*132
      CHARACTER TXT3*40, PLPATH*255
      CHARACTER NATYP*1, TXT2*6, KLEUR*10
      COMMON /FNAME/ KNM(8), KXT, KNM16
      COMMON /CHDAT/ CRD(NP37), LABP(16), COLR(NP10 + 1), BWCT(NP10 + 1)
      CHARACTER CRD*4, LABP*2, COLR*10, BWCT*10
      INTEGER FINDEXE
      COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0
      EXTERNAL SYSTEM
      IF (IPR(140) .LT. 0) THEN
        IVL = - IPR(140)
        CALL PLUT15 (-6, IVL, 5, IPR(140))
        DO 1 I = 1, IPR(42)
          XNM = ABS(MOL(1, I) / PAR(42))
          IRES = IABS(MOL(1, I)) - INT(XNM) * NINT(PAR(42))
          IF (IRES .NE. IPR(140)) THEN
            MOL(1, I) = - NINT(XNM * PAR(42))
          ELSE
            MOL(1, I) =   NINT(XNM * PAR(42))
          ENDIF
    1   CONTINUE
      ENDIF
      IPR(45) = 0
      IF (IGBL(2) .GT. 0) THEN
        IF (IPR(130) .EQ. 0) THEN
          CALL PLUT17 (0.0, 0, MADDR, LU6)
          CALL PLUT17 (0.0, 1002, MADDR, LU6)
          IPR(62) = IPR(142) * (IPR(37) - IPR(69)) + IPR(69)
          IPR(59) = IPR(62) + IPR(37) * IPR(452)
          IF (IPR(63) .EQ. 0) THEN
            IPR(40) = IPR(59)
          ELSE
            IPR(40) = IPR(59) + IPR(42)
          ENDIF
          IPR(125) = (IPR(37) + 1) * NP43
          IPR(158) = IPR(125) + IPR(62) * IPR(82) * 4
          NSPC     = NP0
          IPR(157) = IPR(158)
          IPR(167) = IPR(158)  + IPR(62) * NP0
          IPR(168) = IPR(158)  + IPR(62) * NP0
          IF (IPR(151) .GT. 0) THEN
            IPR(158) = IPR(158) + IPR(62) * NP0
            NSPC     = 2 * NP0
            IF (IPR(116) .NE. 0) THEN
              IPR(167) = IPR(158) + IPR(62) * NP0
              IPR(168) = IPR(167) + IPR(62) * NP0
              NSPC     = 4 * NP0
            ENDIF
          ENDIF
          IF (IPR(157) + NSPC * IPR(40) .GE. IPR(64) - IPR(52) * 2)
     1      THEN
            CALL PLUT38 (5, 0, LU6)
            GOTO 860
          ENDIF
        ENDIF
        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
   10   IF (IPR(130) .EQ. 0) THEN
          IF (IPR(116) .LE. 0) THEN
            CALL GEN074 (PAR,  1E10, 61, 63)
            CALL GEN074 (PAR, -1E10, 64, 66)
            IF (IPR(49) .NE. 0) WRITE (IPR(49), 99995)
            CALL GEN034 (RA, IPR(159) + 1 - IPR(142), IPR(159) - 1)
            NML = IPR(142)
            DO 170 M = 1, NML
              IF (M .EQ. 1) THEN
                I1 = 1
              ELSE
                I1 = ILPB
              ENDIF
              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
              DO 30 J = 1, NRES
                KRS(J) = -1
   30         CONTINUE
              DO 40 J = 1, NMOL
                YNM = MOL(1, J) / PAR(42)
                ZNM = INT(YNM)
                IF (XNM .EQ. ZNM)
     1              KRS(NINT((YNM - XNM) * PAR(42))) = MOL(2, J)
   40         CONTINUE
              DO 160 I = I1, NAT
                INCLUDE = - 1
                DO 50 J = 1, 3
                  XJX(J)     = RA(I * NP43 + J)
                  XJX(J + 3) = TRL(J)
                  XJX(J + 6) = XJX(J)
   50           CONTINUE
                IF (I .GE. ILPB) THEN
                  CALL SGSM (ICL, N, XJX, LU6, 3, IERR)
                  IF (IPR(15) .GT. 0) THEN
                    DO 60 J = 1, 6
                      JJJ  = (J + 1) / 2
                      JJJJ = JJJ * 2 - J
                      DIFF = XJX(JJJ + 6) - PAR(J + 28)
                      IF (DIFF .LT. 0.0) THEN
                        IF (JJJJ .NE. 0) GOTO 100
                      ELSE IF (DIFF .GT. 0.0) THEN
                        IF (JJJJ .EQ. 0) GOTO 100
                      ENDIF
   60               CONTINUE
                  ELSE IF (IPR(15) .LT. 0) THEN
                    GOTO 70
                  ENDIF
                ENDIF
                IDIS = 1000
                IF (IGBL(59) .NE. 0 .AND. I .GE. ILPB) THEN
                  CALL PLUT15 (-4, I, 28, IDIS)
                  IDIS   = IPPR(IDIS + 1, 1)
                ENDIF
                IF (IDIS .LT. 1000) THEN
                  IF (IGBL(88) .EQ. 0) THEN
                    IF (IDIS .GE. 500) INCLUDE = 1
                  ELSE
                    IF (IDIS .LE. 500) INCLUDE = 1
                  ENDIF
                ELSE
                  INCLUDE = 1
                ENDIF
   70           DO 80 II = 1, 3
                  RA(II) = XJX(II + 6)
   80           CONTINUE
                CALL PLUT23 (0)
                IF (IPR(15) .LT. 0) THEN
                  IF (I .GE. ILPB) THEN
                    DIS = 0
                    DO 90 II = 4, 6
                      DIS = DIS +
     1                   (RA( - IPR(15) * NP43 + II) - RA(II))**2
   90               CONTINUE
                    IF (DIS .GT. DISK)  GOTO 100
                    INCLUDE = 1
                  ENDIF
                ENDIF
                CALL GEN002 (1, R, RA(4), XYZR, XLNG)
                IF (I .LE. NATO) THEN
                  J = I
                ELSE
                  XLAB = RA(I * NP43 + 7)
                  DO 95 J = ILPB, NATO
                    IF (RA(J * NP43 + 7) .EQ. XLAB) GOTO 100
   95             CONTINUE
                  GOTO 96
                ENDIF
  100           CALL PLUT15 (-1, J, 27, NINCL)
                IF (NINCL .EQ. 0) INCLUDE = - 1
   96           IF (IPR(166) .EQ. 0) THEN
                  IF (I .GT. NATO) THEN
                    CALL PLUT15 (-6, I, 11, IRU)
                    MPM = IABS(MOL(1, IRU + 1))
                    CALL GEN098 (MPM, PAR(42), MS2, ITX, ITY, ITZ, MR2)
                    XJX(6) = ITX
                    XJX(7) = ITY
                    XJX(8) = ITZ
                    XJX(1) = N
                    XJX(2) = TRL(1)
                    XJX(3) = TRL(2)
                    XJX(4) = TRL(3)
                    XJX(5) = MS2
                    CALL SGSM (ICL, 0, XJX, LU6, 8, IERR)
                    NMZ = NINT(XJX(9)) * 1000 + NINT(XJX(10)) * 100
     1                  + NINT(XJX(11)) * 10  + NINT(XJX(12)) + 555
                    NMZ = NINT(NMZ * PAR(42)) + MR2
                    DO 105 J = 1, NMOL
                      IF (NMZ .EQ. MOL(1, J)) GOTO 106
  105               CONTINUE
                    INCLUDE = -1
                  ENDIF
                ENDIF
  106           JOMIT = 0
                IF (IPR(4) .NE. 0 .AND. M .GT. 1 .AND.
     1            INCLUDE .EQ. 1) THEN
                  JO = ILPB - 1
                  II = IPR(158) + JO * NP0
                  DO 110 N0 = ILPB, NAP
                    II = II + NP0
                    JO = JO + 1
                    IF (RA(II) .GT. 0.0) THEN
                      IF (ABS(RA(II - 3) - XYZR(1)) .LT. PAR(150))
     1                  THEN
                        IF (ABS(RA(II - 2) - XYZR(2)) .LT. PAR(150))
     1                    THEN
                          IF (ABS(RA(II - 1) - XYZR(3)) .LT. PAR(150))
     1                      THEN
                            IO = MOD(JO - ILPB, NAB) + ILPB
                            IF (IO .LE. IPR(39)) THEN
                              CALL PLUT15 (-1, IO, 27, NINC)
                              IF (NINC .EQ. 1) THEN
                                JOMIT = 1000
                                GOTO 120
                              ENDIF
                            ENDIF
                          ENDIF
                        ENDIF
                      ENDIF
                    ENDIF
  110             CONTINUE
                ENDIF
  120           NAP = NAP + 1
                IF (I .GE. ILPB) THEN
                  CALL PLUT15 (-6, I, 5, NRS)
                  IF (INCLUDE .EQ. 1 .AND. NRS .GT. 0) THEN
                    IF (I .GT. IPR(38)) THEN
                      CALL PLUT15 (-4, I, 37, ILAB)
                      IF (ILAB .EQ. 0 .OR. M .GT. 1) THEN
                        N2 = IPR(64) - IPR(53) * 2 - 1
                        N1 = IPR(64) - IPR(52) * 2 + 1
                        DO 130 N0 = N1, N2, 2
                          ICMD = NINT(RA(N0))
                          IF (ICMD .LT. 0) THEN
                            GOTO 130
                          ELSE
                            JAT = NINT(RA(N0 + 1))
                            IF (I .EQ. JAT) GOTO 140
                          ENDIF
  130                   CONTINUE
                        INCLUDE = - 1
                        GOTO 145
                      ENDIF
                    ENDIF
  140               IF (KRS(NRS) .LT. 0) INCLUDE = - 1
  145               CONTINUE
                  ENDIF
                  RA11 = RA(I * NP43 + 11)
                  IF (RA11 .LT. 0.0) THEN
                    IF (IPR(231) .EQ. 0) THEN
                      IATK = INT(RA(I * NP43 + 7) / 32000)
                      RAX  = RADR(IATK + 1, 1)
                    ELSE
                      RAX = ABS(RA11) * 0.35
                    ENDIF
                  ELSE
                    RAX  = RA11
                  ENDIF
                  IF (NRS .NE. 0) THEN
                    NPROP = KRS(NRS)
                  ELSE
                    NPROP = 0
                  ENDIF
                ELSE
                  IF (IPR(46) .EQ. 0) INCLUDE = - 1
                  RAX   = PAR(75)
                  NPROP = 0
                ENDIF
                IF (IPR(105) .EQ. 1) THEN
                  IF (N .NE. 1) INCLUDE = -1
                ENDIF
                IF (INCLUDE .EQ. 1) THEN
                  DO 150 JJ = 1, 3
                    PAR(63 + JJ) = MAX (XYZR(JJ) + RAX, PAR(63 + JJ))
                    PAR(60 + JJ) = MIN (XYZR(JJ) - RAX, PAR(60 + JJ))
  150             CONTINUE
                ELSE
                  JOMIT = - 1000
                  IF (RAX .GT. 0.0) THEN
                    RAX = - RAX
                  ELSE
                    RAX = - 1.0
                  ENDIF
                ENDIF
                RAX = RAX + JOMIT
                IASU = I * 1000 + M
                CALL PLUT14 (1, NAP, IASU, NPROP, XYZR(1), XYZR(2),
     1                       XYZR(3), RAX)
  160         CONTINUE
  170       CONTINUE
            IF (IPR(342) .NE. 0) THEN
              CALL PLUT14 (-1, IPR(342), IASU, NPROP, PAR(67), PAR(68),
     1                         PAR(69), YK)
            ENDIF
            DO 180 I = 1, 3
              IF (IPR(342) .EQ. 0)
     1        PAR(66 + I) = (PAR(60 + I) + PAR(63 + I)) / 2.0
              IF (I .LT. 3 .OR. IPR(151) .GT. 0) THEN
                PAR(60 + I) = (PAR(60 + I) - PAR(66 + I))
                PAR(63 + I) = (PAR(63 + I) - PAR(66 + I))
              ENDIF
  180       CONTINUE
            PAR(15) = VERT * ABS(PAR(18))
            IF (PAR(64) + PAR(65) .LT. 0.0001) THEN
              PAR(64) = 5
              PAR(65) = 5
            ENDIF
            IF (PAR(16) .EQ. 0.0 .AND. PAR(65) .NE. 0.0) THEN
              IF (PAR(64) / PAR(65) .GT. ABS(PAR(18))) THEN
                PAR(24) = PAR(15) * PAR(13) / (2.0 * PAR(64))
              ELSE
                PAR(24) = VERT * PAR(13) / (2.0 * PAR(65))
              ENDIF
            ELSE
              PAR(24) = PAR(16)
            ENDIF
            PAR(61) = - PAR(15) / 2
            PAR(62) = - VERT  / 2
            PAR(64) = - PAR(61)
            PAR(65) = - PAR(62)
            IPR(79) = IPR(64) - IPR(52) * 2 - IPR(142)
            CALL PLUT16 (-6, IDUM1, IDUM2, IDUM3, DUM4, IDUM5)
            IPR(66) = IPR(79) - IPR(97) * 4
          ENDIF
          NORG = (1 - IPR(46)) * IPR(69)
          II   = IPR(158)
          III  = 0
          IF (IPR(116) .GT. 0) THEN
            IF (IGBL(75) .GT. 0) THEN
              NATL = IPR(40)
            ENDIF
          ENDIF
          DO 190 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 .GE. 0) THEN
              INCLUDE =  1
            ELSE
              RI      =  ABS(RI)
              INCLUDE = -1
            ENDIF
            IF (RI .GT. 999.9) THEN
              JOMIT = 1000
              RI = RI - JOMIT
            ELSE
              JOMIT = 0
            ENDIF
            IF (IPR(116) .LE. 0) THEN
              XII = XI
              YII = YI
              ZII = ZI
              XI  = (XI - PAR(67)) * PAR(24)
              YI  = (YI - PAR(68)) * PAR(24)
              IF (IPR(151) .EQ. 0) THEN
                ZI = (ZI - PAR(66)) * PAR(24)
              ELSE
                ZI = (ZI - PAR(69)) * PAR(24)
              ENDIF
              RI = PAR(24) * RI
              IF (PAR(48) .GT. 0.0)
     1          RI = RI * PAR(48) / (PAR(48) - ZI)
              IF (IPR(82) .NE. 0 .AND. I .LE. IPR(62)
     1          .AND. I .GT. NORG) THEN
                CALL PLUT25 (-1, I, IATK)
                IF (INCLUDE .EQ. 1) THEN
                  IF (I .GT. IPR(69)) THEN
                    NATYP  = ' '
                  ELSE
                    NQ1(3:4) = '  '
                    LTYP = NINT(RA(I * NP43 + 7))
                    IF (LTYP .NE. ICHAR(' ')) THEN
                      NQ1(1:2) = 'AR'
                      NATYP  = CHAR(LTYP)
                    ELSE
                      NATYP  = ' '
                      NQ1(1:2) = 'NE'
                    ENDIF
                  ENDIF
                  III                            = III + 1
                  RA(IPR(125) + (I - 1) * 4 + 1) = III
                  RA(IPR(125) + (I - 1) * 4 + 2) = XII
                  RA(IPR(125) + (I - 1) * 4 + 3) = YII
                  RA(IPR(125) + (I - 1) * 4 + 4) = ZII
                  IF (IPR(10) .EQ. 0) THEN
                    WRITE (LU25, 99999) NQ1(1:4), NATYP, XII, YII, ZII
                  ELSE IF (IPR(10) .EQ. 1) THEN
                    IF (IPR(4) .NE. 0) THEN
                      IO = MOD(I - ILPB, NAB) + ILPB
                      CALL PLUT15 (-1, IO, 27, NINCL)
                      IF (NINCL .GT. 0) THEN
                        IF (IABS(IPR(477)) .EQ. 1) THEN
                          IF (IPR(477) .EQ. 1) THEN
                            CALL GEN048 (-5, NPROP, 1, ICOL0)
                          ELSE IF (IPR(477) .EQ. -1) THEN
                            CALL PLUT15 (-6, IO, 5, NRS)
                            IF (NRS .GT. 0 .AND. NRS .LE. 8) THEN
                              ICOL0 = NRS
                            ELSE
                              ICOL0 = 0
                            ENDIF
                          ENDIF
                          IF (ICOL0 .GT. 0) THEN
                            KLEUR = COLR(ICOL0)
                            CALL GEN020 (-1, KLEUR, 2, 10)
                          ELSE
                            KLEUR = '  color_C '
                          ENDIF
                        ELSE
                          NTYP = IEL(IEN(IATK))
                          NTP1 = NTYP / 100
                          NTP2 = NTYP - NTP1 * 100 + ICHAR('a') - 1
                          NTP1 = NTP1 + ICHAR('A') - 1
                          IF (NTP2 .EQ. ICHAR('a') - 1)
     1                      NTP2 = ICHAR(' ')
                          KLEUR = '  color_'//CHAR(NTP1)//CHAR(NTP2)
                        ENDIF
                        WRITE (LU28, 99996) NQ1, XII - PAR(67),
     1                         YII - PAR(68), - ZII + PAR(69),
     2                         RI / PAR(24), KLEUR
                      ENDIF
                    ENDIF
                  ELSE IF (IPR(10) .EQ. 2) THEN
                    IO = MOD(I - ILPB, NAB) + ILPB
                    CALL PLUT15 (-1, IO, 27, NINCL)
                    IF (NINCL .GT. 0) THEN
                      WRITE (LU31, 99994) I, NQ1(1:5), 0, XII - PAR(67),
     1                       - YII + PAR(68), - ZII + PAR(69),  1.0, 0.0
                    ENDIF
                  ENDIF
                ENDIF
              ENDIF
            ENDIF
            IF (IPR(151) .EQ. 0) THEN
              Q = 1.0
              IF (PAR(48) .GT. 0.0) Q = PAR(48) / (PAR(48) - ZI)
              IF (IPR(116) .EQ. 0) THEN
                XI = XI * Q
                YI = YI * Q
              ELSE
                IF (IPR(6) .LT. 0) THEN
                  DEYE = - PAR(17)
                ELSE
                  DEYE =   PAR(17)
                ENDIF
                IF (IPR(116) .LT. 0) THEN
                  XI = (XI + DEYE) * Q - DEYE
                  YI = YI * Q
                ELSE
                  XI = XI + 2.0 * DEYE * (1.0 - Q)
                ENDIF
              ENDIF
            ENDIF
            RA(II - 3) = XI
            RA(II - 2) = YI
            RA(II - 1) = ZI
            RA(II)     = (RI + JOMIT) * INCLUDE
  190     CONTINUE
        ENDIF
        IF (IPR(116) .LE. 0) THEN
          IGBL(32) = IABS (IGBL(32))
          IWIN     = IGBL(25) * IGBL(32)
          BCD = 'P.L.U.T.O.N'//CHAR(0)
          IF (IGBL(50) .EQ. 0) THEN
            CALL GGIP ((1 + IABS(IPR(6))) * PAR(15), VERT, PAR(25), 1)
          ELSE
            CALL GGIP (XSH0, YSH0, 0.0, -3)
          ENDIF
          CALL GGIP (PAR(64), PAR(65), 0.0, -3)
        ENDIF
        IF (IPR(82) .NE. 0) THEN
          IF (IPR(10) .EQ. 0) THEN
            WRITE (LU25, 99998)
          ENDIF
        ENDIF
        CALL GGIP (0.0, FLOAT(IPR(19)), 0.0, 0)
        IF (IPR(6) .EQ. 0) THEN
          IF (IPR(116) .EQ. -1) THEN
            CALL GGIP (0.0, FLOAT(IPR(143)), 0.0, 0)
          ELSE IF (IPR(116) .EQ. 1) THEN
            CALL GGIP (0.0, FLOAT(IPR(144)), 0.0, 0)
          ENDIF
        ENDIF
        CALL PLA115 (2, 1, 0.0, 0.0, 0)
        IF (IPR(151) .LE. 0) THEN
          IF (IGBL(25) * IGBL(32) .EQ. 1) THEN
            IF (IGBL(50) .EQ. 0) THEN
              BCD = 'Click HERE to INTERRUPT PLOTTING'//CHAR(0)
              CALL GGIP (-999.0, 2.0, 33.0, 111)
            ENDIF
            IF (IPR(116) .EQ. 0) THEN
              CLR = IPR(19)
            ELSE IF (IPR(116) .GT. 0) THEN
              CLR = IPR(144)
            ELSE
              CLR = IPR(143)
            ENDIF
              CALL GGIP (0.0, CLR, 0.0, 0)
          ENDIF
          IF (IPR(10) .LE. 0) THEN
            CALL PLUT11
            IF (IPR(45) .EQ. 0) CALL PLUT04 (1, 0)
          ENDIF
        ELSE
          IF (IGBL(25) * IGBL(32) .EQ. 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))
          ENDIF
          IF (IPR(169) .EQ. 0) THEN
            IF (IGBL(25) * IGBL(32) .EQ. 1) THEN
              CALL GGIP (-999.0, 2.0, 33.0, 111)
            ELSE
              CALL GGIP20 (0.0, TXT3, 40, PAR(14) * 1.4, 2, 2, PAR(61),
     1          PAR(62) + PAR(14) * 0.7)
            ENDIF
          ENDIF
        ENDIF
        IF (IPR(45) .EQ. 0) CALL PLUT10
        IF (IPR(45) .EQ. 0 .AND. IGBL(103) .EQ. 1) THEN
          P14  = PAR(14)
          IPM = MIN (NINT((PAR(64) - PAR(61)) / P14) - 15, 74)
          CALL GGIP20 (0.0, JID, IPM, P14, IPR(19), 1,
     1        PAR(61) + 7 * P14, PAR(62) + PAR(54))
          CALL GEN040 (IGBL(9), NQ2, IP)
          CALL GGIP20 (90.0, PROGNM//' - ('//NQ2(1:IP)//')',
     1         IP + 33, P14, IPR(19), 1, PAR(61) + P14 + PAR(54),
     2         PAR(62) + 3 * P14)
          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)
          IF (IGBL(21) .EQ. 1) THEN
            CALL GGIP20 (0.0, 'DEF-FILE ACTIVE', 15, P14,
     1        5 + IGBL(68), 1, PAR(64) - 55 * P14,
     2        PAR(65) - PAR(54) - P14)
          ENDIF
          IF (IGBL(60) .GT. 0) THEN
            CALL GGIP20 (0.0, 'INPUT ATOMS MOVED', 17,
     1        P14, 2, 1, PAR(64) - 41 * P14, PAR(65) - PAR(54) - P14)
          ELSE
            IF (IGBL(30) .EQ. 1) THEN
              CALL GGIP20 (0.0, 'NOMOVE FORCED', 13, P14,
     1          3, 1, PAR(64) - 37 * P14, PAR(65) - PAR(54) - P14)
            ENDIF
          ENDIF
          IDPLT = INT(PAR(48))
          IF (IDPLT .GT. 998) IDPLT = 0
          CALL GEN096 (R, IROTX, IROTY, IROTZ, IDET, XYZOR, PHI, ROM)
          IPR(65) = IDET
          IF (IDET .EQ. -1) CALL GGIP20 (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 GGIP20 (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 GGIP20 (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 GGIP20 (90.0, NQ1, IP, P14, 1, 1,
     1         P14 + PAR(54) + PAR(61), PAR(65) - IP * P14)
          CALL GGIP20 (0.0, 'Z', 1, P14, -1, 1, PAR(61) + PAR(54),
     1         PAR(62) + PAR(54))
          CALL GEN040 (IROTZ, NQ1, IP)
          CALL GGIP20 (0.0, NQ1, IP, P14, 1, 1,
     1           PAR(61) + PAR(54) + 2 * P14, PAR(62) + PAR(54))
          CALL GEN040 (IDPLT, NQ1, IP)
          CALL GGIP20 (0.0, NQ1, IP, P14, 1, 1, PAR(64) - IP * P14,
     1         PAR(65) - PAR(54) - P14)
        ENDIF
        IF (IPR(116) .LT. 0) THEN
          IPR(116) = 1
          IF (IABS(IPR(6)) .GT. 0)
     1        CALL GGIP (ABS(PAR(15)), 0.0, 0.0, -3)
          GOTO 10
        ELSE
          IPR(116) = - IPR(116)
          IF (IPR(130) .EQ. 0 .AND. IPR(145) .EQ. 1) THEN
            IPR(90) = 254
          ENDIF
          IPR(130) = 1 + IPR(116)
          IF (IPR(340) .NE. 0) THEN
            IF (IGBL(98) .EQ. 1) THEN
              CLOSE (LU28)
              XGGIP = -999.0
              YGGIP = 0.0
              ZGGIP = 0.0
              IF (IGBL(123) .EQ. 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)))
              ENDIF
              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 .GT. 0) THEN
                PLPATH(NE +1:) =
     1 ' +P +D +A0.3 +W'//NQ1//'+H'//NQ2//'+I'//NAME(1)(1:KNM(1))//' &'
                CALL SYSTEM (PLPATH)
                IPR(340) = 0
              ELSE
                CALL PLA015 (0, 9)
              ENDIF
              IGBL(98) = -1
            ELSE IF (IGBL(11) .EQ. 1) THEN
              CLOSE (LU31)
              CALL GEN038 (PLPATH, 1, 255)
C * FIND rasmol
              NE = FINDEXE ('RASEXE', PLPATH, 'rasmol')
              IF (NE .GT. 0) THEN
                PLPATH(NE + 1:) = ' '//NAME(1)(1:KNM(1))//'.ras &'
                CALL SYSTEM (PLPATH)
                IPR(340) = 0
              ELSE
                CALL PLA015 (0, 9)
              ENDIF
              IGBL(11) = -1
            ENDIF
          ENDIF
        ENDIF
      ENDIF
  860 RETURN
99999 FORMAT (A, 2X, A, 3F10.3)
99998 FORMAT ('END')
99996 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 } } }')
99995 FORMAT (//, ' NR  NMOL ATNR LABEL     XMOL', 9X, 'X', 9X, 'Y',
     1       9X, 'Z', 9X, 'RAX'/)
99994 FORMAT ('ATOM', 2X, I5, 1X, A, 4X, I5, 4X, 3F8.3, 2F6.2)
      END
      SUBROUTINE PLUT03 (IER)
      PARAMETER (NP4=9,NP9=118,NP10=16,NP12=600,NP13=500,NP14=64,
     1 NP17=99,NPVD=40000000,NP22=256,NP23=18000,NP32=63,NP36=1000,
     2 NP38=125,NP39=30,NP43=12,NP45=2048)
      COMMON // MOL(2, NP23), RA(NPVD)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLUTO/ IPPR(129, 3), IBT(32), TRL(3), ROM(3, 3), R(3, 3),
     1 RP(NP14), XJX(12), XXX(12), YYY(12), TMX(3, 3), SHFT(3),
     2 XYZOR(3), XYZR(3),  ZU(15), OM(3, 3), RCG(4, NP32), TMY(3, 3),
     3 XYZPL(6), A(3, 3), XYZK(8), KRS(NP32), NCRS(9), NPRS(17)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /Q/ ICL, IFL(NP17)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9),
     1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10),
     2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10),
     3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770)
      DIMENSION DUMA(3)
      COMMON /PLU99A/ SFC(16)
      CHARACTER SFC*2
      COMMON /ALIASES/ ALAB(NP36), BLAB(NP36)
      CHARACTER ALAB*7, BLAB*7
      I4 = 0
      KL = IPR(220)
      KN = IPR(221)
      NSYM = IPR(48)
      MULT = NSYM
      IF (KL .EQ. 3 .AND. IFL(3)(1:1) .EQ. 'X') THEN
        IPR(220) = 2
        KL       = IPR(220)
      ENDIF
      IF (KL .GT. 3 .OR. KL .EQ. 0) THEN
        WRITE (LU6, 99997) ICL(1:80)
        GOTO 170
      ENDIF
      IF (KN .LT. 3) THEN
        WRITE (LU6, 99998) ICL(1:70)
        GOTO 170
      ENDIF
      IF (IABS(IGBL(8)) .EQ. 3) THEN
        NQ1 = IFL(2)
      ELSE
        NQ1 = IFL(KL)
      ENDIF
      IF (IGBL(8) .EQ. 2) THEN
        IF (IPR(538) .NE. 0) THEN
          N = INDEX (NQ1, ' ')
          IF (N .NE. 0) THEN
            IF (IPR(538) .LT. 10) THEN
              WRITE (NQ1(N:N+1), '(''_'', I1)') IPR(538)
            ELSE
              WRITE (NQ1(N:N+2), '(''_'', I2)') IPR(538)
            ENDIF
          ENDIF
          IFL(KL) = NQ1
        ENDIF
      ENDIF
      IF (IGBL(8) .EQ. 1 .AND. KL .EQ. 2) THEN
        IF (IFL(1)(1:4) .NE. 'ATOM' .AND. IFL(1)(1:2) .NE. 'U ' .AND.
     1      IFL(1)(2:3) .NE. 'IJ' .AND. IFL(1)(3:4) .NE. 'IJ') THEN
          IGBL(71) = IGBL(71) + 1
          ALAB(IGBL(71)) = IFL(1)
          BLAB(IGBL(71)) = IFL(2)
        ENDIF
      ENDIF
      MODE = 9
      LOP  = 0
      NQ4  = NQ1
      CALL GEN020 ( 1, NQ4, 1, 7)
      CALL GEN020 (-1, NQ4, 2, 2)
   10 CALL PLA046 (MODE, NQ1, NED, NQX, NSS, NQSM, XNQNR, YNQNR, NIEN)
      IF (NIEN .EQ. -2) STOP 'Stop:: More that 16 atom types !!'
      LOP = LOP + 1
C * CHECK FOR ERROR RETURN
      IF (NIEN .LT. 0) THEN
        IF (IABS(IGBL(8)) .EQ. 3 .OR. IABS(IGBL(8)) .EQ. 2) THEN
          IF (IABS(IGBL(8)) .EQ. 3) THEN
            IF (ICHAR (NQ1(2:2)) .GE. 48 .AND.
     1          ICHAR (NQ1(2:2)) .LE. 48) THEN
              NQ1(2:) = ' '
            ELSE
              NQ1(3:) = ' '
            ENDIF
          ELSE
            NQ1 = SFC(NINT(FN(1)))
          ENDIF
          IF (NQ1(1:1) .EQ. ' ') THEN
            NQ1(1:1) = NQ1(2:2)
            NQ1(2:4) = '999'
          ELSE IF (NQ1(2:2) .EQ. ' ') THEN
            NQ1(2:4) = '999'
          ELSE
            NQ1(3:4) = '99'
          ENDIF
          MODE = 10
          IF (LOP .EQ. 1) GOTO 10
        ENDIF
      ENDIF
      IF (NIEN .LT. 0 .OR. NQSM .GT. 0) THEN
        IF (NIEN .LT. 0 .OR. IPR(50) .EQ. 0) THEN
          WRITE (LU6, 99996) NQ1
          GOTO 170
        ENDIF
      ENDIF
      IF (IPR(51) .EQ. 0) CALL PLUT23 (-1)
      ICLOSE = 0
      IANIS  = 0
      UISO   = -1.0
      IF (IPR(50) .EQ. 0) THEN
        IF (IABS(IGBL(8)) .EQ. 2) THEN
          IF (KN .EQ. 11) IANIS = 1
          RP(1) = 1
          IF (KN .EQ. 7) THEN
            IPR(221) = 6
            KN       = IPR(221)
          ENDIF
          DO 30 I = 2, KN
            YY = FN(I)
            IF (ABS(YY) .GT. 5.0) THEN
              J  = NINT(ABS(YY) * 0.1)
              SJ = SIGN(0.5, YY)
              IF (J .NE. 1 .AND. J .GT. IPR(13)) CALL PLUT38 (4, 1, LU6)
              YY = (YY - J * SJ * 20.0) * (RP(J) + SJ - 0.5)
            ENDIF
            FN(I - 1) = YY
   30     CONTINUE
          IF (KN .EQ. 6 .AND. FN(6) .GT. 0.0) UISO = - FN(6) / 0.04
          FN(KN)   = 0.0
          IPR(221) = IPR(221) -1
          KN       = IPR(221)
        ENDIF
        IF (IABS(IGBL(8)) .NE. 2 .AND. KN .EQ. 8 .OR.
     1      IABS(IGBL(8)) .EQ. 2 .AND. KN .GT. 3) THEN
          IF (FN(4) .LT. 0.0001) THEN
            WRITE (LU6, 99995) NQ1
            GOTO 170
          ENDIF
        ENDIF
        IF (IPR(127) .GT. 0 .OR. IPR(156) .GT. 0) THEN
          IF (IPR(156) .EQ. 1) THEN
            CALL GEN002 (1, ROM, FN, XJX, XLNG)
            DO 40 J = 1, 3
              FN(J) = XJX(J)
   40       CONTINUE
          ELSE
            CALL GEN002 (1, TMY, FN, XJX, XLNG)
            IGBL(30) = 0
            DO 50 J = 1, 3
              FN(J) = MOD(XJX(J), 1.0)
   50       CONTINUE
          ENDIF
        ENDIF
        I2 = (IPR(37) + 1) * NP43
        I4 = I2 + NP43
        DO 60 J = 1, 3
          XJX(J + 3) = 0.0
          IF (IPR(128) .GT. 0) FN(J) = FN(J) + SHFT(J)
          XJX(J)     = FN(J)
          RA(I2 + J) = FN(J)
          RA(I4 + J) = 0.0
   60   CONTINUE
        XJX(10) = 0.0
        CALL SGSM (ICL, 0, XJX, LU6, 19, IERR)
        IF (IGBL(8) .EQ. 3) FN(4) = FN(4) * XJX(10)
        IF (ABS(1.0 - FN(4) / XJX(10)) .LT. 0.001) THEN
          PAR22 = PAR(22)
        ELSE
          PAR22 = 0.005
        ENDIF
        MULT   = 0
        ICLOSE = 0
        DCLOSE = 999.0
        DO 120 J = 1, NSYM
          CALL SGSM (ICL, J, XJX, LU6, 3, IERR)
          I    = IPR(69) * NP43
          II   = IPR(69)
   70     I    = I + NP43
          II   = II + 1
          VERS = 0.0
          DO 100 K = 1, 3
            VRS = RA(I + K) - XJX(K + 6)
   80       IF (VRS .GT. 0.5) THEN
              XJX(K + 6) = XJX(K + 6) + 1.0
              VRS        = VRS - 1.0
              GOTO 80
            ENDIF
   90       IF (VRS .LE. - 0.5) THEN
              XJX(K + 6) = XJX(K + 6) - 1.0
              VRS        = VRS + 1.0
              GOTO 90
            END IF
            DUMA(K) = VRS
  100     CONTINUE
          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))
          IF (VERS .LT. PAR22) THEN
            IF (I .EQ. I2) THEN
              MULT = MULT + 1
              DO 110 K = 1, 3
                RA(I4 + K) = RA(I4 + K) + XJX(K + 6)
  110         CONTINUE
            ELSE
              CALL PLUT25 (2, II, IDUM)
              ICLOSE = 1
              DCLOSE = VERS
            ENDIF
          ENDIF
          IF (I .LT. I2)  GOTO 70
  120   CONTINUE
      ENDIF
      IF (IPR(37) .EQ. IPR(69)) THEN
        IPPR(1, 3) = NSYM
      ENDIF
      NATX = IPR(37) + 1
      I          = NATX * NP43
      RA(I + 6)  = YNQNR
      RA(I + 7)  = XNQNR
      RA(I + 8)  = 0.0
      RA(I + 9)  = 0.0
      RA(I + 10) = 0.0
      IF (PAR(141) .GT. 0.0) THEN
        TRNS     = PAR(141)
        PAR(141) = 0.0
      ELSE
        TRNS     = PAR(140)
      ENDIF
      RA(I + 11) = UISO
      RA(I + 12) = TRNS
      DO 140 II = 1, 3
        IF (IPR(50) .EQ. 1) THEN
          RA(I + II) = FN(II) * PAR(11)
        ELSE
          IF (MULT .EQ. 0) MULT = 1
          RA(I + II) = RA(I4 + II) / MULT
        ENDIF
  140 CONTINUE
      NPOP = IPR(9)
        FN(4) = MIN (1.0, FN(4) * MULT)
      IF (NQ1(1:1) .EQ. 'Q' .OR. FN(4) .LT. 0.001) FN(4) = 1.0
      INTPOP = NINT(FN(4) * 1000.0)
      IF (MULT .EQ. 48 .AND. INTPOP .GT. 997) INTPOP = 1000
      IF (INTPOP .EQ. 1000 .AND. ICLOSE .EQ. 1 .AND.
     1  (NQ1(1:1) .NE. 'Q' .OR.
     2  (NQ1(1:1) .EQ. 'Q' .AND. NQ2(1:1) .EQ. 'Q'))) THEN
        WRITE (LU6, 99999) NQ1, DCLOSE, NQ2
        GOTO 170
      ENDIF
      IF (INTPOP .EQ. 500 .AND. MULT .EQ. 1) THEN
        IF (FN(4) .GT. 0.5) INTPOP = 501
        IF (FN(4) .LT. 0.5) INTPOP = 499
      ENDIF
      IPPR(NPOP + 1, 1) = INTPOP
      IPPR(NPOP + 1, 3) = NSYM / MULT
      IPR(37) = NATX
      IPR(38) = NATX
      IPR(39) = NATX
      IF (IABS(IGBL(8)) .EQ. 3 .OR. IABS(IGBL(8)) .EQ. 2) THEN
        CALL PLUT25 (2, NATX, IDUM)
        IF (NQ2 .NE. NQ4) THEN
          IGBL(71) = IGBL(71) + 1
          ALAB(IGBL(71)) = NQ4
          BLAB(IGBL(71)) = NQ2
        ENDIF
      ENDIF
      DO 145 II = 1, NPOP
        IF (IPPR(II, 1) .EQ. IPPR(NPOP + 1, 1)) GOTO 146
  145 CONTINUE
      II = NPOP
      IF (NPOP .LT. 16) IPR(9) = NPOP + 1
      GOTO 147
  146 II = II - 1
  147 CALL PLUT15 (4, NATX, 28, II)
      CALL PLUT15 (6, NATX, 18, MULT)
      IVAL = 1
      CALL PLUT15 (1, NATX, 27, IVAL)
      IVAL = 0
      CALL PLUT15 (4, NATX, 37, IVAL)
      CALL PLUT15 (1, NATX, 41, IANIS)
      CALL PLUT25 (0, NATX, N1)
      N2 = IEN(N1)
      IF (N2 .EQ. 2) IGBL(97) = 1
      IF (N1 .GT. 4) RADR(N1, 3) = REL(N2)
      DO 150 II = 1, IPR(480)
        IF (N2 .EQ. IDOAC(II)) THEN
          IVAL = 1
          CALL PLUT15 (1, NATX, 46, IVAL)
          GOTO 160
        ENDIF
  150 CONTINUE
  160 IF (IATPR(N2) .GT. 0) THEN
        IWD = 1
      ELSE
        IWD = 0
      ENDIF
      CALL PLUT15 (1, NATX, 17, IWD)
      IF (N2 .EQ. 1 .OR. N2 .EQ. 33) THEN
        IWD = 1
      ELSE
        IWD = 0
      ENDIF
      CALL PLUT15 (1, NATX, 44, IWD)
      IF (IPR(136) .EQ. 0) THEN
        IVAL = 0
      ELSE
        IVAL = IPR(136)
      ENDIF
      CALL PLUT15 (6, NATX, 5, IVAL)
      IER = 0
      IF (IPR(50) * IPR(135) .GT. 0) THEN
        RA(NATX * NP43 + 3) = RA(NATX * NP43 + 3) + IPR(135) * 100.0
      ENDIF
      RETURN
  170 IER = 1
      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')
      END
      SUBROUTINE PLUT04 (MODE, NATR)
      PARAMETER (NP4=9,NP10=16,NP12=600,NP13=500,NP17=99,
     1 NPVD=40000000,NP22=256,NP23=18000,NP37=175,NP38=125,NP39=30,
     2 NP43=12,NP45=2048)
      COMMON // MOL(2, NP23), RA(NPVD)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /Q/ ICL, IFL(NP17)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      CHARACTER LABP*2
      COMMON /CHDAT/ CRD(NP37), LABP(16), COLR(NP10 + 1), BWCT(NP10 + 1)
      CHARACTER CRD*4, NQ0*13, NL123*3, LBPOS*2, COLR*10, BWCT*10
      LOGICAL CC
      COMMON /CTRLC/ CC
      KL      = IPR(220)
      KN      = IPR(221)
      ILPB    = IPR(69) + 1
      NAT     = IPR(37)
      NATO    = IPR(39)
      NAB     = NAT - IPR(69)
      IPR(72) = 0
      XSH     = PAR(39)
      IASU    = 0
      IF (MODE .EQ. 1) THEN
        IF (IGBL(75) .EQ. 0) THEN
          IF (IPR(339) .EQ. 1) THEN
            NATY = IPR(69)
          ELSE
            NATY = 0
          ENDIF
        ELSE
          NATY = NAT
        ENDIF
        IF (IPR(63) .EQ. 0) THEN
          NATX = NATY
        ELSE
          NATX = NATY + IPR(42)
        ENDIF
        IF (NATX .GT. 0) THEN
          PAR(28) = 0.5 * PAR(349)
          IF (IPR(116) .EQ. 1 .OR. IPR(130) .EQ. 1) THEN
            NTM = 1
            NT0 = 1
          ELSE
            NTM = 2
            IF (IPR(117) .EQ. 0) THEN
              NT0 = 2
            ELSE
              NT0 = 1
            ENDIF
          ENDIF
          DO 130 NT = NT0, NTM
            NATL = IPR(62)
            IF (NATR .NE. 0) THEN
              IBEG = NATR
              IEND = NATR
              NATL = IPR(62) + NATR - 1
            ELSE
              IBEG = 1
              IEND = NATX
            ENDIF
            DO 120 I = IBEG, IEND
              NATL = NATL + 1
              IF (I .LE. NATY) THEN
                IF (IPR(4) .GT. 0) THEN
                  CALL PLUT15 (-1, I, 45, IVAL)
                  IF (IVAL .EQ. 0 .AND. I .GE. ILPB) GOTO 120
                ENDIF
                CALL PLUT15 (-4, I, 37, M)
                IF (M .EQ. 0)  GOTO 120
                CALL PLUT14 (-1, I, IASU, NPROP, XI, YI, ZI, RI)
                IF (RI .LT. 0.0)  GOTO 120
                IF (IPR(4) .LE. 0 .AND. RI .GT. 0.0) RI = 0.0
                IF (I .LT. ILPB) THEN
                  IF (IPR(46) .EQ. 0) THEN
                    GOTO 120
                  ELSE
                    NQ0(1:1) = CHAR(INT(RA(I * NP43 + 7)))
                    KLB      = 1
                    GOTO 60
                  ENDIF
                ENDIF
                IAT = I
                IF (I .GE. ILPB .AND. IPR(14) .EQ. 1) IAT = - I
                CALL PLUT25 (2, IAT, IATK)
                NQ0 = NQ2
              ELSE
                M = IABS(IPR(63))
                XNM = MOL(1, I - NATY) / PAR(42)
                IF (XNM .LT. 0)  GOTO 120
                NM  = NINT(XNM)
                NR  = NINT((XNM - NM) * PAR(42))
                CALL GEN040 (NM, NQ0, IP0)
                IP0 = IP0 + 1
                NQ0(IP0:IP0) = '.'
                IF (NR .LT. 10 .AND. IPR(134) .GT. 9) THEN
                  IP0          = IP0 + 1
                  NQ0(IP0:IP0) = '0'
                ENDIF
                CALL GEN040 (NR, NQ0(IP0 + 1:IP0 + 1), IP)
                IP  = IP0 + IP
                NML = IPR(142)
                DO 20 JJ = 1, NML
                  INM = NINT(RA(IPR(159) + 1 - JJ))
                  IF (NM .EQ. INM) GOTO 30
   20           CONTINUE
   30           DO 40 KK = ILPB, NATO
                  CALL PLUT15 (-6, KK, 5, IVAL)
                  IF (IVAL .EQ. NR) THEN
                    CALL PLUT15 (-1, KK, 27, IVAL)
                    IF (IVAL .EQ. 1) GOTO 50
                  ENDIF
   40           CONTINUE
   50           KK = (JJ - 1) * NAB + KK
                CALL PLUT14 (-1, KK, IASU, NPROP, XI, YI, ZI, RI)
              ENDIF
              NB  = 0
              KLB = 0
              CALL GEN039 (1, NQ0, 1, 13, NB, KLB)
   60         PAR(40) = KLB * PAR(349) * PAR(19) / 2.0
              IF (IPR(116) .LE. 0 .AND. IPR(130) .EQ. 0 .AND.
     1            M .NE. 15) THEN
                IF (I .LE. NATY) THEN
                  CALL PLUT15 (-1, I, 42, ILB)
                ELSE
                  IF (IPR(63) .LT. -1) THEN
                    ILB = 1
                  ELSE
                    ILB = 0
                  ENDIF
                ENDIF
                XSH = PAR(39)
                IF (NT .EQ. 1) THEN
                  IF (ILB .EQ. 0)  GOTO 120
                  IF (M .EQ. 1)  GOTO 120
                  MM = 0
                ELSE
                  IF (ILB .EQ. 1)  GOTO 120
                  MMIN = 999
                  M0   = 10
                  XSH0 = 0.0
                  XSH = 0.0
   70             XSH = XSH + PAR(39)
                  IF (IPR(116) .NE. 0 .AND. XSH .GT. PAR(39)) GOTO 90
                  IF (XSH .GT. IPR(131) * PAR(39)) GOTO 90
                  M = 10 + IPR(18)
                  IF (PAR(40) .GT. RI * 0.9) M = 10
                  IF (I .GE. ILPB) THEN
                    MSTEP = 1
                  ELSE
                    MSTEP = 2
                    M     = 11
                  ENDIF
   80             M = M - MSTEP
                  IF (M .LT. 2) GOTO 70
                  CALL PLUT26 (M, NATL, XI, YI, ZI, RI, XL, YL, ZL,
     1                         RL, XSH)
                  IF (XL - PAR(40) .LT. PAR(61) .OR.
     1                XL + PAR(40) .GT. PAR(64) .OR.
     2                YL - PAR(28) .LT. PAR(62) .OR.
     3                YL + PAR(28) .GT. PAR(65)) THEN
                    MM = 999
                    IF (NT .EQ. 2)  GOTO 80
                    IVAL = 1
                    CALL PLUT15 (4, I, 37, IVAL)
                    GOTO 120
                  ENDIF
                  IPR(67) = 2
                  CALL PLUT18 (NATL, 0)
                  MM = IPR(78)
                  IF (MM .EQ. 0) THEN
                    GOTO 100
                  ELSE IF (MM .GT. 0) THEN
                    IF (MM .LT. MMIN) THEN
                      M0   = M
                      XSH0 = XSH
                      MMIN = MM
                    ENDIF
                  ENDIF
                  GOTO 80
   90             M = M0
                  IF (IPR(4) .GT. 0 .AND. MMIN .GT. 0
     1              .AND. I .LE. NATY .AND. I .GE. ILPB) THEN
                    IVAL = 0
                    CALL PLUT15 (1, I, 45, IVAL)
                    IF (IGBL(105) .EQ. 0) GOTO 120
                  ENDIF
                  XSH = XSH0
                ENDIF
                CALL PLUT26 (M, NATL, XI, YI, ZI, RI, XL, YL, ZL,
     1                       RL, XSH)
  100           IF (I .LE. NATY) THEN
                  CALL PLUT15 (4, I, 37, M)
                ELSE
                  IF (ILB .EQ. 1) THEN
                    IPR(63) = - M
                  ELSE
                    IPR(63) = 1
                  ENDIF
                ENDIF
              ELSE
                IF (I .LE. NATY) THEN
                  CALL PLUT15 (-4, I, 37, M)
                ELSE
                  M = MAX (-IPR(63), 2)
                ENDIF
                IF (IPR(116) .NE. 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)
                ENDIF
              ENDIF
              IF (CC) GOTO 230
              LMAX = IPR(7)
              DO 110  LL = 1, LMAX
                IF (I .GT. NATY) THEN
                  ICOL = 6
                ELSE
                  ICOL = -1
                  IF (IPR(116) .EQ. 0) THEN
                    IF (IGBL(3) .EQ. 26 .OR. IPR(352) .EQ. 1) THEN
                      CALL PLUT15 (-1, I, 41, IANIS)
                      IF (IANIS .EQ. 1) ICOL = 2
                    ENDIF
                    IF (IGBL(3) .EQ. 12) THEN
                      CALL PLUT15 (-1, I, 47, IREN)
                      IF (IREN .EQ. 1) ICOL = 3
                    ENDIF
                  ENDIF
                ENDIF
                CALL GGIP20 (0.0, NQ0, KLB, PAR(349), ICOL, 1,
     1            XL - PAR(40), YL - PAR(28))
                XL = XL + PAR(4)
  110         CONTINUE
  120       CONTINUE
  130     CONTINUE
        ENDIF
      ELSE
        IF (IPR(17) .EQ. 0) THEN
          CALL PLUT05
          IF (IPR(72) .NE. 0) STOP '308'
        ENDIF
        IF (MODE .EQ. 2 .OR. MODE .EQ. 3) THEN
          IPR(130) = 0
          LABL = 3 - MODE
          IF (KL .EQ. 1) THEN
            KL = 2
            IFL(2)(1:3) = 'ON '
          ENDIF
          ISET  = 0
          IUNIT = 0
          DO 160 K = 2, KL
            NL123 = IFL(K)(1:3)
            IF (NL123 .EQ. 'ON ') THEN
              IGBL(75) = LABL
              IPR(452) = IGBL(75)
              IPR(63)  = 0
              ISET     = 1
              IUNIT    = 1
            ELSE IF (NL123 .EQ. 'OFF') THEN
              IGBL(75) = 1 - LABL
              IPR(452) = IGBL(75)
              IPR(63)  = 0
              ISET     = 1
              IUNIT    = 1
              LABL = MOD(LABL + 1, 2)
            ELSE IF (NL123 .EQ. 'NON') THEN
              IPR(63)  = 0
              ISET     = 1
              IUNIT    = 1
              LABL = MOD(LABL + 1, 2)
            ELSE IF (NL123 .EQ. 'UNI') THEN
              IUNIT    = 1
            ELSE IF (NL123 .EQ. 'ARU') THEN
              IPR(63) = LABL
            ELSE IF (NL123 .EQ. 'MOL') THEN
              IPR(63) = LABL
            ELSE IF (NL123 .EQ. 'ATO') THEN
              IPR(452) = LABL
              IF (LABL .EQ. 1) IGBL(75) = LABL
              ISET     = 1
            ELSE IF (NL123 .EQ. 'ALL') THEN
              IPR(63)  = LABL
              IGBL(75) = LABL
              ISET     = 1
              IUNIT    = 1
            ELSE IF (NL123 .EQ. 'PAR') THEN
              IPR(71) = 0
            ELSE IF (NL123 .EQ. 'NOP') THEN
              IPR(71) = 1
            ELSE IF (NL123 .EQ. 'FUL') THEN
              IPR(14) = 0
            ELSE IF (NL123 .EQ. 'NUM') THEN
              IPR(14) = 1
              IPR(71) = 1
            ELSE
              CALL PLUT13 (-1, -K, IAT, XMOL)
              IGBL(75) = 1
              IF (IAT .LT. 0) THEN
                DO 150 I = ILPB, NAT
                  II = I
                  CALL PLUT25 (0, II, IAI)
                  IF (IAI + IAT .EQ. 0) THEN
                    IF (KN .EQ. 1) CALL PLUT28 (0, II, FN(1))
                    CALL PLUT15 (4, II, 37, LABL)
                  ENDIF
  150           CONTINUE
              ELSE IF (IAT .GT. 0) THEN
                IF (KN .EQ. 1) XMOL = FN(1)
                CALL PLUT28 (0, IAT, XMOL)
                CALL PLUT15 (4, IAT, 37, LABL)
              ENDIF
            ENDIF
  160     CONTINUE
          IF (ISET .EQ. 1) THEN
            DO 170 I = ILPB, NAT
              IF (LABL .EQ. 1) THEN
                IF (IPR(232) .EQ. 1) THEN
                  LABL0 = 1
                ELSE
                  CALL PLUT15 (-1, I, 44, IHA)
                  LABL0 = 1 - IHA
                ENDIF
              ELSE
                LABL0 = 0
              ENDIF
              CALL PLUT15 (4, I, 37, LABL0)
              IF (LABL .EQ. 0) THEN
                IVL = 0
                CALL PLUT15 (1, I, 42, IVL)
              ENDIF
  170       CONTINUE
          ENDIF
          IF (IPR(50) .EQ. 0 .AND. IUNIT .EQ. 1) THEN
            IPR(339) = LABL
            DO 140 I = 1, 8
              IF (I .LT. 4 .OR. I .EQ. 5) THEN
                ILB = LABL
              ELSE
                ILB = 0
              ENDIF
              CALL PLUT15 (4, I, 37, ILB)
  140       CONTINUE
          ENDIF
        ELSE IF (MODE .EQ. 4) THEN
          IPR(130) = 0
          L = 2
  180     IF (L .GT. KL)  GOTO 250
          NL123 = IFL(L)(1:3)
          IF (NL123 .EQ. 'ARU') THEN
            LMODE = -1
          ELSE IF (NL123 .EQ. 'MOL') THEN
            LMODE = -1
          ELSE IF (NL123 .EQ. 'ATO') THEN
            IAT   = 0
            LMODE = 1
          ELSE
            CALL PLUT13 (0, -L, IAT, XDUM)
            IF (IAT .EQ. 0) THEN
              L = L + 1
              GOTO 220
            ENDIF
            LMODE = 1
          ENDIF
          L = L + 1
          IF (L .GT. KL)  GOTO 220
          LBPOS = IFL(L)(1:2)
          DO 190 I = 1, 10
            IF (LABP(I + 1) .EQ. LBPOS)  GOTO 200
  190     CONTINUE
          GOTO 220
  200     IF (LMODE .EQ. -1) THEN
            IPR(63) = - MIN (IABS(IPR(63)), 1) * I
          ELSE
            IF (IAT .LE. 0) THEN
              JB = ILPB
              JE = NAT
            ELSE
              JB = IAT
              JE = IAT
            ENDIF
            DO 210 J = JB, JE
              CALL PLUT25 (0, J, IAJ)
              IAJ = - IAJ
              CALL PLUT15 (-4, J, 37, ILB)
              ILB = MIN (ILB, 1) * I
              IF (IAT .GE. 0 .OR. IAT .EQ. IAJ) THEN
                CALL PLUT15 (4, J, 37, ILB)
                IF (ILB .GT. 1) THEN
                  LFIX = 1
                ELSE
                  LFIX = 0
                ENDIF
                CALL PLUT15 (1, J, 42, LFIX)
              ENDIF
  210       CONTINUE
          ENDIF
          L = L + 1
          IPR(117) = 1
          GOTO 180
  220     IPR(72) = 26
        ENDIF
      ENDIF
  230 IF (MODE .GT. 1) THEN
        IF (IPR(63) .NE. 0) THEN
          ILBO = 1
        ELSE
          ILBO = 0
        ENDIF
        DO 240 I = 1, NAT
          CALL PLUT15 (-4, I, 37, IVAL)
          IF (IVAL .GT. 0) ILBO = 1
          IF (ILBO .EQ. 0) THEN
          ELSE
            GOTO 250
          ENDIF
  240   CONTINUE
      ENDIF
  250 IF (MODE .EQ. 2 .OR. MODE .EQ. 3) THEN
        IF (IPR(63) + IPR(339) + IGBL(75) .EQ. 0) THEN
          IGBL(75) = 0
        ELSE
          IGBL(75) = 1
        ENDIF
      ENDIF
      RETURN
      END
      SUBROUTINE PLUT05
      PARAMETER (NP4=9,NP9=118,NP10=16,NP12=600,NP13=500,NP17=99,
     1 NPVD=40000000,NP22=256,NP23=18000,NP33=15,NP38=125,NP39=30,
     2 NP43=12,NP45=2048)
      COMMON // MOL(2, NP23), RA(NPVD)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /Q/ ICL, IFL(NP17)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9),
     1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10),
     2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10),
     3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770)
      CHARACTER J15*5
      IDASH    = 0
      IPR(130) = 0
      KL       = IPR(220)
      KN       = IPR(221)
      PAR(1) = PAR(2) / 2
      IF (IPR(100) .EQ. 0) CALL PLUT33
      IPR(72) = 0
      IF (IPR(17) .EQ. 0) THEN
        IDASH    = 0
        IPR(35)  = 1 - IPR(50)
        IPR(60)  = 1
        IPR(110) = (1 - IPR(50)) * IGBL(97)
        IF (IPR(9) .GT. 1) THEN
          IGBL(30) = 1
          WRITE (LU6, 99999)
        ENDIF
      ELSE
        IF (KL .LE. 1) GOTO 230
        IF (IFL(2)(1:5) .EQ. 'RADII') THEN
          IPR(35) = 0
          IPR(60) = 1
          N       = 0
          DO 30 I = 1, NP10
             RADR(I, 2) = -1
   30     CONTINUE
          IF (KL .GT. 2) THEN
            IGBL(30) = IPR(50)
            DO 80 K = 3, KL
               J15 = IFL(K)(1:5)
               IF (J15 .EQ. 'NOMOV') THEN
                  IGBL(30) = 1
               ELSE IF (J15 .EQ. 'UNIQU') THEN
                  IPR(35)  = 1 - IPR(50)
                  IPR(110) = 0
               ELSE IF (J15 .EQ. 'INTER') THEN
                 IPR(35) = - 1
               ELSE IF (J15(1:3) .EQ. 'TOL') THEN
                 N = N + 1
                 IF (N .LE. KN) THEN
                   IF (J15(4:4) .EQ. 'E') THEN
                     PAR(26) = FN(N)
                   ELSE
                     PAR(1) = FN(N)
                   ENDIF
                   WRITE (LU6, 99998) PAR(1), IGBL(97) * PAR(26)
                 ENDIF
               ELSE IF (J15 .EQ. 'EXPAN') THEN
                 IPR(110) = 1
               ELSE IF (J15 .EQ. 'HBOND') THEN
                IPR(109) = 1
               ELSE IF (J15 .EQ. 'XBOND') THEN
                IPR(109) = 2
               ELSE
                 CALL PLUT13 (0, -K, IAT, XDUM)
                 IF (IAT .GE. 0) GOTO 230
                 M          = - IAT
                 N          = N + 1
                 RADR(M, 2) = FN(N)
                 IPR(60)    = 0
               ENDIF
   80       CONTINUE
            IPR(221) = 0
            KN       = IPR(221)
          ENDIF
        ELSE IF (IFL(2)(1:5) .EQ. 'INTRA') THEN
          IPR(37) = IPR(38)
          IPR(52) = IPR(53)
          GOTO 240
        ELSE
          IDASH = 0
          IF (IFL(2)(1:4) .EQ. 'DASH' .AND. KL .EQ. 4) THEN
            IDASH    = 1
            IFL(2)   = IFL(3)
            IFL(3)   = IFL(4)
            KL       = 3
            IPR(220) = KL
          ENDIF
          IF (KL .LT. 3) GOTO 230
          IF (IPR(52) .EQ. (1 - IPR(50)) * 12) THEN
            IPR(75) = 1
            CALL PLUT17 (1555.0 + 1 / PAR(42), 0, MADDR, LU6)
            WRITE (LU6, 99997)
            DO 90 I = 1, IPR(37)
              CALL PLUT23 (I)
   90       CONTINUE
          ENDIF
          IF (IPR(161) .LT. 0) THEN
            KB = 3
          ELSE
            KB = 2
          ENDIF
   95     CALL PLUT13 (0, - KB, IAT, XDUM)
          IF (IPR(161) .EQ. 1) THEN
            KL0 = 4
          ELSE
            KL0 = KB + 1
          ENDIF
          IF (IAT .EQ. 0 .OR. KL .LT. KL0) GOTO 230
          DO 220 K = KL0, KL
            IF (IAT .GT. 0) THEN
              I1 = IAT
              I2 = IAT
            ELSE
              I1 = IPR(69) + 1
              I2 = IPR(37)
            ENDIF
            IF (KN .EQ. 1) THEN
              M13 = -1
            ELSE
              M13 = 0
            ENDIF
            CALL PLUT13 (M13, -K, JAT, XMOL)
            IF (JAT .EQ. 0) THEN
              GOTO 230
            ELSE IF (JAT .GT. 0) THEN
              IF (IAT .GT. 0 .AND. KL .EQ. 3) THEN
                IF (KN .EQ. 1) XMOL = FN(1)
                CALL PLUT28 (IAT, JAT, XMOL)
                IFL(K) = NQ1
              ENDIF
              J1 = JAT
              J2 = JAT
            ELSE
              J1 = IPR(69) + 1
              J2 = IPR(37)
            ENDIF
            DO 210 I = I1, I2
              IAIO =  - INT(RA(I * NP43 + 7) / 32000) - 1
              IF (IAT .GE. 0 .OR. IAT .EQ. IAIO) THEN
                DO 200 J = J1, J2
                  JAIO = - INT(RA(J * NP43 + 7) / 32000) - 1
                  IF (JAT .GE. 0 .OR. JAT .EQ. JAIO) THEN
                    CALL PLUT16 (IPR(17) - 2, IDUM0, I, J, DUM1, IDUM2)
                    IF (IPR(17) .EQ. 1) THEN
                      CALL PLUT15 (-4, I, 33, IVAL)
                      IF (IVAL .LT. NP33) THEN
                        IVL = IVAL + 1
                        CALL PLUT15 (4, I, 33, IVL)
                      ENDIF
                      CALL PLUT15 (-4, J, 33, IVAL)
                      IF (IVAL .LT. NP33) THEN
                        IVL = IVAL + 1
                        CALL PLUT15 (4, J, 33, IVL)
                      ENDIF
                    ENDIF
                  ENDIF
  200           CONTINUE
              ENDIF
  210       CONTINUE
  220     CONTINUE
          IF (IPR(161) .LT. 0) THEN
            KB = KB + 1
            IF (KB .LT. KL) GOTO 95
          ENDIF
          GOTO 240
        ENDIF
      ENDIF
      IF (IPR(60) .NE. 0) THEN
        DO 110 I = 1, IAN
          RADR(I, 2) = RADR(I, 3) + PAR(1)
          IF (IPR(35) .LT. 0) THEN
            RADR(I, 2) = RADR(I, 4)
            IF (IPR(109) .GT. 0) THEN
              DO 115 N = 1, IPR(480)
                IF (IEN(I) .EQ. IDOAC(N)) THEN
                  RADR(I, 2) = RADR(I, 4)
                  GOTO 119
                ENDIF
  115         CONTINUE
              IF (MOD(IEN(I), 32) .EQ. 1) THEN
                RADR(1, 2) = VDWR(1)
              ELSE
                RADR(I, 2) = 0.0
              ENDIF
  119         CONTINUE
            ENDIF
          ENDIF
  110   CONTINUE
      ENDIF
      CALL PLUT07
      GOTO 240
  230 IPR(72) = 27
      WRITE (LU6, 99995)
      CALL PLA015 (0, 48)
  240 IF ((IDASH .EQ. 1 .OR. IPR(221) .EQ. 2) .AND. IPR(4) .NE. 0) THEN
        IF (IDASH .EQ. 1) THEN
          IFL(5)   = IFL(3)
          IFL(4)   = IFL(2)
          IFL(3)   = 'DASH '
          IPR(220) = 5
        ELSE
          IFL(4)  = IFL(3)
          IFL(3)  = IFL(2)
          IPR(20) = 4
        ENDIF
        IFL(2) = 'BONDS'
        CALL PLUT21 (0)
        IPR(220) = 5
        IDASH    = 0
      ENDIF
      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')
99995 FORMAT (':: Problem/Error in JOIN - routine')
      END
      SUBROUTINE PLUT06
      PARAMETER (NP12=600,NP13=500,NP14=64,NP17=99,NPVD=40000000,
     1 NP23=18000,NP32=63,NP38=125,NP39=30,NP43=12,NP45=2048)
      COMMON // MOL(2, NP23), RA(NPVD)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLUTO/ IPPR(129, 3), IBT(32), TRL(3), ROM(3, 3), R(3, 3),
     1 RP(NP14), XJX(12), XXX(12), YYY(12), TMX(3, 3), SHFT(3),
     2 XYZOR(3), XYZR(3),  ZU(15), OM(3, 3), RCG(4, NP32), TMY(3, 3),
     3 XYZPL(6), A(3, 3), XYZK(8), KRS(NP32), NCRS(9), NPRS(17)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /Q/ ICL, IFL(NP17)
      CHARACTER ICL*(NP45), IFL*7
      CHARACTER INVERT*6, N12*2, N1*1
      DIMENSION RSAVE(3, 3)
      IPR(130) = 0
      IPR(150) = 0
      KL       = IPR(220)
      KN       = IPR(221)
      IF (IPR(17) .EQ. 0) THEN
        KNS = KN
        KLS = KL
        IPR(221) = 0
        IPR(220) = 1
        CALL PLUT05
        IF (IPR(72) .NE. 0) STOP '309'
        IPR(221) = KNS
        KN       = IPR(221)
        IPR(220) = KLS
        KL       = IPR(220)
      ENDIF
      DO 20 I = 1, 3
        DO 10 J = 1, 3
          RSAVE(I, J) = R(I, J)
   10   CONTINUE
   20 CONTINUE
      IF (IPR(51) .EQ. 0 .OR. IPR(37) .EQ. 0) THEN
        WRITE (LU6, 99994)
        GOTO 400
      ENDIF
      IPR(72)  = 0
      N        = 0
      L        = 2
      IGBL(67) = 1
      IF (KL .EQ. 1) THEN
        IPR(220) = 2
        KL       = IPR(220)
        IF (IFL(1)(1:1) .EQ. 'V') THEN
          IFL(2)(1:4) = 'UNIT'
        ELSE
          IFL(2) = IFL(1)
        ENDIF
      ENDIF
      N12 = IFL(L)(1:2)
      IF (N12 .EQ. 'IN' .OR. N12 .EQ. 'XR' .OR. N12 .EQ. 'YR' .OR.
     1    N12 .EQ. 'ZR') THEN
         L = 1
         GOTO 200
      ENDIF
      IF (N12 .EQ. 'AL') THEN
        IF (KL .NE. 6)  GOTO 400
        IF (IFL(5)(1:1) .NE. 'W')  GOTO 400
        IF (IFL(6)(1:1) .EQ. 'X') THEN
          ANG = 0.0
        ELSE IF (IFL(6)(1:1) .EQ. 'Y') THEN
          ANG = -90.0
        ELSE
          GOTO 400
        ENDIF
        CALL PLUT13 (0, 3, IAT, XDUM)
        CALL PLUT13 (0, 4, JAT, XDUM)
        IF (IAT .LE. 0 .OR. JAT .LE. 0)  GOTO 400
        IF (KN .EQ. 1 .AND. KL .EQ. 6) CALL PLUT28 (IAT, JAT, FN(1))
        DO 40 I = 1, 2
          ZU(I + 9)  = 0.0
          ZU(I + 12) = 0.0
          DO 30 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)
   30     CONTINUE
          ZU(I) = ZU(I + 12) - ZU(I + 9)
   40   CONTINUE
        IF (ABS(ZU(1)) + ABS(ZU(2)) .LE. 1.0) THEN
          WRITE (LU6, 99998)
          GOTO 430
        ENDIF
        ANG         = ATAN2(ZU(2), ZU(1)) * GL(5) + ANG
        N           = 0
        L           = 0
        IPR(220)    = 1
        KL          = IPR(220)
        IPR(221)    = 1
        KN          = IPR(221)
        FN(1)       = ANG
        IFL(1)(1:1) = 'Z'
        IGBL(67)    = 1
      ELSE IF (N12 .EQ. 'MA') THEN
        IF (KN .LT. 9) THEN
          WRITE (LU6, 99991)
          GOTO 400
        ENDIF
        K = 0
        DO 60 I = 1, 3
          DO 50 J = 1, 3
            K = K + 1
            R(I, J) = FN(K)
   50     CONTINUE
   60   CONTINUE
        N = 9
      ELSE IF (N12 .EQ. 'MI') THEN
        CALL PLUT08
        L        = 2
        IPR(150) = 2
      ELSE IF (N12 .EQ. 'XO') THEN
        CALL GEN021 (R, 0)
        R(1, 2) = 1.0
        R(2, 3) = 1.0
        R(3, 1) = 1.0
        IPR(150) = 3
      ELSE IF (N12 .EQ. 'YO') THEN
        CALL GEN021 (R, 0)
        R(1, 3) = 1.0
        R(2, 1) = 1.0
        R(3, 2) = 1.0
        IPR(150) = 4
      ELSE IF (N12 .EQ. 'ZO' .OR. N12 .EQ. 'UN') THEN
        CALL GEN021 (R, 1)
        IF (N12 .EQ. 'ZO') THEN
          IPR(150) = 5
        ELSE
          IPR(150) = 1
        ENDIF
      ELSE IF (N12 .EQ. 'CU') THEN
        GOTO 200
      ELSE
        CALL GEN021 (R, 0)
        CALL GEN074 (RA, 0.5, 1, 3)
        IF (N12(2:2) .EQ. 'F') THEN
          IF (N12(1:1) .EQ. 'B') THEN
            J = 2
          ELSE IF (N12(1:1) .EQ. 'C') THEN
            J = 3
          ELSE
            J = 1
          ENDIF
          IPR(150) = 5 + J
          ILINE = 1
          RA(J) = 1.0
          GOTO 100
        ENDIF
        IF (N12 .EQ. 'DI') THEN
          IF (KN .LT. 3) THEN
            WRITE (LU6, 99987)
            GOTO 400
          ENDIF
          DO 80 K = 1, 3
            RA(K) = FN(K)
   80     CONTINUE
          ILINE = 1
          L = 2
          N = 3
          GOTO 100
        ENDIF
        IF (N12 .EQ. 'LI') THEN
          ILINE = 1
          IF (KL .LT. 4) THEN
            WRITE (LU6, 99992)
            GOTO 400
          ENDIF
          CALL PLUT13 (0, 3, IAT, XDUM)
          CALL PLUT13 (0, 4, JAT, XDUM)
          IF (IAT .LE. 0 .OR. JAT .LE. 0) THEN
            WRITE (LU6, 99993)
            GOTO 400
          ENDIF
          IF (KN .EQ. 1 .AND. KL .EQ. 4) CALL PLUT28 (IAT, JAT, FN(1))
          DO 90 K = 1, 3
            RA(K) = RA(IAT * NP43 + K) - RA(JAT * NP43 + K)
   90     CONTINUE
          L = L + 2
          GOTO 100
        ENDIF
        IF (N12 .EQ. 'PE') THEN
          ILINE = 2
          GOTO 140
        ENDIF
        IF (N12 .EQ. 'BI') THEN
          ILINE = 3
          GOTO 140
        ENDIF
        WRITE (LU6, 99986)
         GOTO 400
  100   CALL PLUT23 (0)
        XDUM = GEN017 (RA(4))
        DO 110 K = 7, 9
          ZU(K)     = RA(K - 3)
          ZU(K + 6) = 0.0
  110   CONTINUE
        IF (ABS(ZU(8)) .GT. 0.9999) THEN
          ZU(13) = 1.0
        ELSE
          ZU(14) = 1.0
        ENDIF
        CALL GEN008 (ZU(13), ZU(7), ZU(1), 1)
        CALL GEN008 (ZU(7), ZU(1), ZU(4), 1)
        GOTO 180
  140   IF (KL .LT. 5) THEN
          WRITE (LU6, 99989)
          GOTO 400
        ENDIF
        CALL PLUT13 (0, 3, J1, XDUM)
        CALL PLUT13 (0, 4, J2, XDUM)
        CALL PLUT13 (0, 5, J3, XDUM)
        IF (J1 .LE. 0 .OR. J2 .LE. 0 .OR. J3 .LE. 0) THEN
          WRITE (LU6, 99988)
          GOTO 400
        ENDIF
        L = L + 3
        DO 150 K = 1, 3
          KKK = K + 3
          ZU(K + 6)  = 0.5 * (RA(J1 * NP43 + KKK)
     1               + RA(J3 * NP43 + KKK)) - RA(J2 * NP43 + KKK)
          ZU(K + 9)  = RA(J1 * NP43 + KKK)  - RA(J2 * NP43 + KKK)
          ZU(K + 12) = RA(J3 * NP43 + KKK)  - RA(J2 * NP43 + KKK)
  150   CONTINUE
        XDUM = GEN017 (ZU(7))
        XDUM = GEN017 (ZU(10))
        XDUM = GEN017 (ZU(13))
        CALL GEN008 (ZU(7), ZU(13), ZU(4), 1)
        CALL GEN008 (ZU(4), ZU(7), ZU(1), 1)
        IF (ILINE .NE. 3) THEN
          DO 170 K = 1, 3
            TEMP      = ZU(K + 6)
            ZU(K + 6) = ZU(K + 3)
            ZU(K + 3) = ZU(K)
            ZU(K)   = TEMP
  170     CONTINUE
        ENDIF
  180   DO 190 I = 1, 9
          J = (I - 1) / 3
          K = I - J * 3
          R(J + 1, K) = ZU(I)
  190   CONTINUE
      ENDIF
  200 L = L + 1
      IF (L .GT. KL)  GOTO 370
      N1 = IFL(L)(1:1)
      IF (N1 .EQ. 'I') THEN
        CALL GEN010 (R, -1, -1)
        GOTO 200
      ENDIF
      N = N + 1
      IF (N .GT. KN) THEN
        WRITE (LU6, 99985)
        GOTO 400
      ENDIF
      CALL GEN021 (A, 1)
      ANG = FN(N) / GL(5)
      CA  = COS(ANG)
      SA  = SIN(ANG)
      IF (N1 .EQ. 'B') THEN
        IF ((L + 2) .GT. KL) THEN
          WRITE (LU6, 99985)
          GOTO 400
        ENDIF
        L = L + 1
        CALL PLUT13 (0, L, I, XDUM)
        L = L + 1
        CALL PLUT13 (0, L, J, XDUM)
        IF (I .LE. 0 .OR. J .LE. 0) THEN
          WRITE (LU6, 99988)
          GOTO 400
        ENDIF
        DO 250 K = 1, 3
          RA(K) = RA(I * NP43 + K) - RA(J * NP43 + K)
  250   CONTINUE
        CALL PLUT23 (0)
        XDUM = GEN017 (RA(4))
        CALL GEN002 (1, R, RA(4), RA(1), XLNG)
        GOTO 340
      ELSE IF (N1 .EQ. 'L') THEN
        IF ((N + 3) .GT. KN)  GOTO 400
        DO 260 I = 1, 3
          N = N + 1
          RA(I) = FN(N)
  260   CONTINUE
        CALL PLUT23 (0)
        XDUM = GEN017 (RA(4))
        CALL GEN002 (1, R, RA(4), RA(1), XLNG)
        GOTO 340
      ELSE IF (N1 .EQ. 'O') THEN
        IF ((N + 3) .GT. KN)  GOTO 400
        DO 270 I = 1, 3
          N = N + 1
          ZU(I + 6) = FN(N)
  270   CONTINUE
        XDUM = GEN017 (RA(4))
        CALL GEN002 (1, R, RA(4), RA(1), XLNG)
        GOTO 340
      ELSE IF (N1 .EQ. 'P') THEN
        IF ((N + 3) .GT. KN)  GOTO 400
        DO 280 I = 1, 3
          N = N + 1
          ZU(I + 3) = FN(N)
  280   CONTINUE
        XDUM = GEN017 (ZU(4))
         GOTO 340
      ELSE IF (N1 .EQ. 'X') THEN
        CALL GEN043 (1, A, ANG)
        CALL GEN004 (A, R, R)
        GOTO 200
      ELSE IF (N1 .EQ. 'Y') THEN
        CALL GEN043 (2, A, ANG)
        CALL GEN004 (A, R, R)
        GOTO 200
      ELSE IF (N1 .EQ. 'Z') THEN
        CALL GEN043 (3, A, ANG)
        CALL GEN004 (A, R, R)
        GOTO 200
      ENDIF
      GOTO 400
  340 CB = 1.0 - CA
      DO 360 I = 1, 3
        DO 350 J = 1, 3
          A(I, J) = CB * RA(I) * RA(J)
  350   CONTINUE
  360 CONTINUE
      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, R)
      GOTO 200
  370 CALL GEN096 (R, IROTX, IROTY, IROTZ, IDET, XYZOR, PHI, ROM)
      GL(28)   = IROTX
      GL(29)   = IROTY
      GL(30)   = IROTZ
      IGBL(87) = IDET
      INVERT   = ' '
      IF (IDET .EQ. 0) THEN
        WRITE (LU6, 99997) ((R(I, J), J = 1, 3), I = 1, 3)
        GOTO 400
      ELSE IF (IDET .LT. 0) THEN
        WRITE (LU6, 99999)
        INVERT = 'INVERT'
      ENDIF
      IPR(330) = (1 - IDET) / 2
      WRITE (LU6, 99996) IROTX, IROTY, IROTZ, INVERT
      WRITE (LU6, 99995) (XYZOR(I), I = 1, 3), PHI, INVERT
      GOTO 430
  400 IPR(72) = 28
      WRITE (LU6, 99984)
      DO 420 I = 1, 3
        DO 410 J = 1, 3
          R(I, J) = RSAVE(I, J)
  410   CONTINUE
  420 CONTINUE
      WRITE (LU6, 99990)
  430 RETURN
99999 FORMAT (':: Absolute Configuration changed !!')
99998 FORMAT (':: ATOMS superimposed in this VIEW: VIEW MATRIX ',
     1        'NOT changed')
99997 FORMAT (/,':: Abs(Determinant) .NE. 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 PLUT07
      PARAMETER (NP4=9,NP9=118,NP10=16,NP12=600,NP13=500,NP14=64,
     1 NP17=99,NPVD=40000000,NP22=256,NP23=18000,NP32=63,NP38=125,
     2 NP39=30,NP43=12,NP45=2048)
      COMMON // MOL(2, NP23), RA(NPVD)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLUTO/ IPPR(129, 3), IBT(32), TRL(3), ROM(3, 3), R(3, 3),
     1 RP(NP14), XJX(12), XXX(12), YYY(12), TMX(3, 3), SHFT(3),
     2 XYZOR(3), XYZR(3),  ZU(15), OM(3, 3), RCG(4, NP32), TMY(3, 3),
     3 XYZPL(6), A(3, 3), XYZK(8), KRS(NP32), NCRS(9), NPRS(17)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /Q/ ICL, IFL(NP17)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9),
     1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10),
     2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10),
     3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770)
      COMMON /PLXXX/ DLIM(3), T(3), XJS(3), SEP(3), XYZJS(3)
      DIMENSION XTT(96, 3), RAXJX(3)
      ILSTRT = 0
      IT     = 0
C * AUTOMATIC SEARCH FOR CONNECTIONS
      IDUM0 = 0
      IDUM2 = 0
      DUM1  = 0.0
      DO 20 I = 1, 96
        DO 10 J = 1, 3
          XTT(I, J) = 0.0
   10   CONTINUE
   20 CONTINUE
      NATO  = IPR(39)
      NSYM  = IPR(48)
      ILPB  = IPR(69) + 1
      NRESM = IPR(134)
      KSHFT = 0
      IF (IPR(35) .GE. 0) THEN
        IF (IPR(35) .EQ. 1) THEN
          KSHFT = 1
          IF (IPR(110) .EQ. 1) THEN
            WRITE (LU6, 99998)
          ELSE
            WRITE (LU6, 99993)
          ENDIF
          WRITE (LU27, 99991)
        ELSE
          WRITE (LU6, 99996)
          IPR(52) = IPR(68)
          IPR(53) = IPR(68)
        ENDIF
        CALL GEN074 (RCG, 0.0, 1, NP32 * 4)
        IPR(38) = NATO
        IPR(42) = 0
        IPR(43) = 0
        IPR(44) = 0
        IPR(70) = 0
        IVAL = MAX (0, IGBL(30) * 4)
        DO 30 I = ILPB, NATO
          IF (IVAL .GT. 0) RA(I * NP43 + 12) = 1.555
          CALL PLUT15 (4, I, 1, IVAL)
          IF (IPR(50) .EQ. 1) CALL PLUT23 (I)
   30   CONTINUE
        ILSTRT = ILPB
      ELSE
        IPR(52) = IPR(53)
        KSHFT   = 1 - IPR(50)
        I       = ILPB - 1
      ENDIF
      IPR(37)  = IPR(38)
      IPR121   = IPR(121)
      IPR122   = IPR(122)
      IPR123   = IPR(123)
      IPR(72)  = 0
      IPR(130) = 0
      IPR(55)  = 0
      GOTO 330
   40 DO 45 L = 1, 3
        XYZOR(IPR(120 + L)) = RA(I * NP43 + L)
   45 CONTINUE
      CALL PLUT15 (-4, I, 28, IDIS)
      IDIS   = IPPR(IDIS + 1, 1)
      NRI    = INT(RA(I * NP43 + 7) / 32000) + 1
      NELI   = IEN(NRI)
      IATPRX = IATPR(NELI)
      IMETAL = ISIGN(1, IATPRX)
      IF (IATPRX .EQ. 5 .OR. IATPRX .EQ. 6) THEN
        IATPRI = 1
      ELSE IF (IATPRX .LT. 0) THEN
        IATPRI = -1
      ELSE
        IATPRI = 0
      ENDIF
      NEXT = 0
      CALL PLUT15 (-6, I, 5, NRESI)
      CALL PLUT15 (-1, I, 44, IHAT)
      IF (IPR(35) .LT. 0) THEN
        IF (IPR(109) .GT. 0) THEN
          IF (NELI .EQ. 8) GOTO 330
          IF (NELI .EQ. 10) GOTO 330
          IF (NELI .EQ. 4 .OR. NELI .EQ. 6) THEN
            CALL PLUT15 (-1, I, 46, IVAL)
            IF (IVAL .EQ. 0) GOTO 330
          ENDIF
        ENDIF
      ELSE
        IF (IPR(50) .EQ. 0) THEN
          IF (IHAT .EQ. 1) THEN
            J = NATO
            NEXT = 0
            GOTO 310
          ENDIF
        ENDIF
      ENDIF
      J = ILPB
      IF (IPR(50) .EQ. 1 .AND. IPR(35) .GE. 0) J = ILSTRT
   50 IF (IPR(35) .GE. 0 .AND. IPR(50) .EQ. 1 .AND. J .LT. I) THEN
        CALL PLUT15 (-2, J, 1, IVAL)
        IF (IVAL .EQ. 1) GOTO 310
      ENDIF
      CALL PLUT15 (-4, J, 28, JDIS)
      JDIS = IPPR(JDIS + 1, 1)
      NRJ    = INT(RA(J * NP43 + 7) / 32000) + 1
      NELJ   = IEN(NRJ)
      IATPRX = IATPR(NELJ)
      JMETAL = ISIGN(1, IATPRX)
      IF (IATPRX .EQ. 5 .OR. IATPRX .EQ. 6) THEN
        IATPRJ = 1
      ELSE IF (IATPRX .LT. 0) THEN
        IATPRJ = -1
      ELSE
        IATPRJ = 0
      ENDIF
      CALL PLUT15 (-1, J, 44, JHAT)
      IF (IPR(35) .LT. 0) THEN
        IF (IPR(109) .GT. 0) THEN
          IF (NELJ .EQ. 8) GOTO 310
          IF (IHAT .EQ. JHAT) GOTO 310
          IF (NELJ .EQ. 4 .OR. NELJ .EQ. 6) THEN
            CALL PLUT15 (-1, J, 46, IVAL)
            IF (IVAL .EQ. 0) GOTO 310
          ENDIF
        ENDIF
      ENDIF
      CALL PLUT15 (-6, J, 18, NMULT)
      CALL PLUT15 (-6, J, 5, NRESJ)
      DMAX = RADR(NRI, 2) + RADR(NRJ, 2)
      IF (IPR(35) .GE. 0) THEN
        IF (IPR(60) .EQ. 1) THEN
          IF ((NELI .EQ. 10 .AND. (NELJ .GE. 3 .AND. NELJ .LE. 5)) .OR.
     1        (NELJ .EQ. 10 .AND. (NELI .GE. 3 .AND. NELI .LE. 5)) .OR.
     2        (NELI .EQ. 30 .AND. NELJ .EQ. 4) .OR.
     3        (NELI .EQ. 4  .AND. NELJ .EQ. 30) .OR.
     4        (NELI .EQ. 30 .AND. NELJ .EQ. 6)  .OR.
     5        (NELI .EQ. 6  .AND. NELJ .EQ. 30)) THEN
            DMAX = DMAX + PAR(9)
          ELSE IF (NELI .EQ. 59 .AND. NELJ .EQ. 3  .OR.
     1             NELI .EQ. 3  .AND. NELJ .EQ. 59 .OR.
     2             NELI .EQ. 59 .AND. NELJ .EQ. 4  .OR.
     3             NELI .EQ. 4  .AND. NELJ .EQ. 59) THEN
            DMAX = DMAX + PAR(10)
          ELSE
            IF (IATPRI * IATPRJ .LT. 0) THEN
              DMAX = DMAX + IGBL(97) * PAR(26)
            ENDIF
            IF (IMETAL + JMETAL .EQ. 2) THEN
              IF (PLA260 (NELI, NELJ) .LT. 0) THEN
                DMAX = 2.0
              ELSE
                DMAX = DMAX + PAR(127)
              ENDIF
            ENDIF
          ENDIF
          IF (NELI .EQ. 1 .OR. NELJ .EQ. 1) DMAX = MIN (DMAX, 2.0)
        ENDIF
      ELSE
        IF (IPR(109) .GT. 0) THEN
          DMAX = DMAX - 0.12
        ENDIF
      ENDIF
      DMAXSQ = DMAX**2
      NT = 0
      DO 55 JJ = 1, 3
        DLIM(IPR(120 + JJ)) = DMAX / PAR(112 + JJ)
        RAXJX(JJ)           = RA(J * NP43 + JJ)
   55 CONTINUE
      MOLY = 1555
      DO 300 N = 1, NSYM
        DO 60 JJ = 1, 3
          T(JJ)       = 0.0
          XJX(JJ + 3) = 0.0
          XJX(JJ)     = RAXJX(JJ)
   60   CONTINUE
        CALL SGSM (ICL, N, XJX, LU6, 3, IERR)
        IF (NMULT .GT. 1) THEN
          IF (N .GT. 1) THEN
            DO 68 KK = 1, NT
              DO 65 JJ = 1, 3
                IF (0.5 - ABS(MOD(10.0 + ABS(XJX(JJ + 6)
     1            - XTT(KK, JJ)), 1.0)
     2            - 0.5) .GT. 0.005) GOTO 68
   65         CONTINUE
              GOTO 300
   68       CONTINUE
          ENDIF
          NT = NT + 1
          DO 67 JJ = 1, 3
            XTT(NT, JJ) = XJX(JJ + 6)
   67     CONTINUE
        ENDIF
        XJS(IPR121) = XJX(7)
        XJS(IPR122) = XJX(8)
        XJS(IPR123) = XJX(9)
        K = 1
        IF (KSHFT .EQ. 0) THEN
          IF (I .EQ. J)  GOTO 300
          DO 70 K = 1, 3
            SEP(K) = XYZOR(K) - XJS(K)
            IF (ABS(SEP(K)) .GT. DLIM(K))  GOTO 300
   70     CONTINUE
          GOTO 110
        ENDIF
   80   IF (XYZOR(K) - XJS(K) .GT. DLIM(K))  GOTO 100
        XJS(K) = XJS(K) - 1.0
        T(K)   = T(K)   - 1.0
        GOTO 80
   90   K = K - 1
        IF (KSHFT .EQ. 0) GOTO 300
  100   XJS(K) = XJS(K) + 1.0
        T(K)   = T(K)   + 1.0
        SEP(K) = XJS(K) - XYZOR(K)
        IF (SEP(K) .LT. - DLIM(K))  GOTO 100
        IF (SEP(K) .GT. DLIM(K)) THEN
          K = K - 1
          IF (K .GT. 0) THEN
            GOTO 100
          ELSE
            GOTO 300
          ENDIF
        ENDIF
        K = K + 1
        IF (K .LT. 4)  GOTO 80
        IT = INT(ABS(T(1)) + ABS(T(2)) + ABS(T(3)))
        IF (N .EQ. 1 .AND. IT .EQ. 0 .AND. I .EQ. J) GOTO 90
  110   RA(1) = SEP(IPR121)
        RA(2) = SEP(IPR122)
        RA(3) = SEP(IPR123)
        CALL PLUT23 (0)
        DIJSQ = RA(4)**2 + RA(5)**2 + RA(6)**2
        DIJ = SQRT(DIJSQ)
        IF (DIJSQ .LT. DMAXSQ) THEN
          IF (IPR(35) .LT. 0) THEN
            IF (N .EQ. 1) THEN
              IF (NRESI .EQ. NRESJ) THEN
                IF (IPR(109) .EQ. 0) THEN
                  IF (IT .EQ. 0) GOTO 90
                ELSE
                  IF (IHAT .EQ. 1) THEN
                    IF (IT .EQ. 0) GOTO 90
                  ENDIF
                  CALL PLUT40 (I, J, N, ISW)
                  IF (ISW .LT. 0) GOTO 90
                ENDIF
              ELSE
                IF (IPR(109) .GT. 0) THEN
                  CALL PLUT40 (I, J, N, ISW)
                  IF (ISW .LT. 0) GOTO 90
                ENDIF
              ENDIF
            ELSE
              IF (IPR(109) .GT. 0) THEN
                CALL PLUT40 (I, J, N, ISW)
                IF (ISW .LT. 0) GOTO 90
              ENDIF
            ENDIF
          ENDIF
        ELSE
          GOTO 90
        ENDIF
        DIJ = SQRT(DIJSQ)
        IF (IPR(109) .GT. 0 .AND. DIJ .LT. 1.25) GOTO 90
        MOLZ = NINT(N * 1000 + T(IPR(121)) * 100 + T(IPR(122)) * 10
     1       + T(IPR(123)) + 555)
        IF (NELJ .EQ. 111) THEN
          IF (DIJ .LT. GL(25) .AND. I .NE. J) THEN
            CALL PLUT25 (1, J, JDUM)
            CALL PLUT25 (2, I, IDUM)
            WRITE (LU6, 99992) NQ1, NQ2, DIJ
            IVAL = 0
            CALL PLUT15 (6, J, 18, IVAL)
            IVAL = 0
            CALL PLUT15 (1, J, 27, IVAL)
            IVAL = 1
            CALL PLUT15 (2, J,  1, IVAL)
            GOTO 310
          ENDIF
        ENDIF
        XYZJS(1) = XJS(IPR121)
        XYZJS(2) = XJS(IPR122)
        XYZJS(3) = XJS(IPR123)
        IF (DIJ .LT. 0.05 .AND. I .EQ. J) THEN
          IF (J .GT. IPR(37)) GOTO 90
          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 .EQ. J) GOTO 90
          IVL = 0
          CALL PLUT15 (1, J, 2, IVL)
          L = IPR(68) + 1
  120     CALL PLUT16 (0, L, IL1, IL2, DUM1, IDUM2)
          IF (IL1 .GT. IPR(38) .OR. IL2 .GT. IPR(38)) THEN
            IF (IL1 .EQ. J) THEN
              GOTO 140
            ELSE IF (IL1 .GT. J) THEN
              GOTO 160
            ENDIF
            IF (IL2 .NE. J)  GOTO 150
  140       CALL PLUT16 (-3, IDUM0, IL1, IL2, DUM1, IDUM2)
          ENDIF
  150     L = L + 1
          IF (L .LE. IPR(52))  GOTO 120
  160     IVL = 3
          CALL PLUT15 (2, J, 3, IVL)
          GOTO 300
        ENDIF
        KAT = J
        NEW = 1
        IF (IPR(35) .LT. 0) THEN
          IF (N .EQ. 1 .AND. IT .EQ. 0 .AND. NRESI .NE. NRESJ) THEN
            GOTO 290
          ELSE
            GOTO 230
          ENDIF
        ELSE
          IF (JHAT .EQ. 1) THEN
            CALL PLUT15 (-1, I, 46, JDOAC)
            CALL PLUT15 ( 1, J, 32, JDOAC)
          ENDIF
          CALL PLUT15 (-1, J, 1, IVAL)
          IF (IVAL .EQ. 0) THEN
            IVL = 1
            CALL PLUT15 (1, J, 2, IVL)
            IF (IPR(50) .EQ. 0) THEN
              IF (IATPRI .GE. 0 .AND. IATPRJ .LT. 0) NEXT = 1
            ENDIF
          END IF
          CALL PLUT15 (-2, J, 3, IVL)
          IF (N .EQ. 1 .AND. IT .EQ. 0) THEN
            ITX = 1
            IF (IVL .GT. 0) GOTO 290
          ELSE
            ITX = 0
          ENDIF
          IF (IVL .EQ. 0) THEN
            IF (ITX .EQ. 0) THEN
              DO 180 II = 1, 3
                RA(J * NP43 + II) = XYZJS(II)
  180         CONTINUE
              CALL PLUT23 (J)
              IVL = 2
            ELSE
              IVL = 1
            ENDIF
            CALL PLUT15 (2, J, 3, IVL)
            GOTO 290
          ENDIF
          IF (IPR(50) .EQ. 0) THEN
            DO 220 II = 1, 3
              IF (ABS(RA(J * NP43 + II) - XYZJS(II)) * PAR(100 + II)
     1           .GT. PAR(22)) GOTO  230
  220       CONTINUE
            GOTO 290
          ENDIF
        ENDIF
  230   IF (NEW .GT. 0) THEN
          NATC = IPR(38) + IPR(55)
          DO 250 KAT = ILPB, NATC
            DO 240 II = 1, 3
              IF (ABS(RA(KAT * NP43 + II) - XYZJS(II))
     1            * PAR(100 + II) .GE. PAR(22)) GOTO 250
  240       CONTINUE
            GOTO 290
  250     CONTINUE
          IPR(55) = IPR(55) + 1
          KAT     = IPR(38) + IPR(55)
          IF ((KAT + 1) * NP43 .GT. IPR(64) - IPR(52) * 2) THEN
            IPR(42) = IPR(43)
            IPR(52) = IPR(53)
            IPR(37) = IPR(38)
            IPR(72) = 29
            GOTO 460
          ENDIF
          DO 260 II = 1, 3
            RA(KAT * NP43 + II) = XYZJS(II)
  260     CONTINUE
          CALL PLUT23 (KAT)
          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 PLA081 (21, 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)
            CALL PLUT15 (-6, I,   5, IVAL)
            CALL PLUT15 ( 6, KAT, 5, IVAL)
          IVL = 0
          CALL PLUT15 ( 1, KAT, 27, IVL)
        ENDIF
        IF (IPR(35) .GE. 0) THEN
          CALL PLUT15 (6, KAT,  5, IPR(70))
          IVL = IPR(70) - 1
          CALL PLUT15 (6, KAT, 11, IVL)
        ENDIF
        IF (IPR(35) .GE. 0) THEN
          CALL PLUT15 (-6, KAT, 5, NRESJ)
        ELSE
          CALL PLUT15 (-6, J, 5, NRESJ)
        ENDIF
        XM1  = MOLZ
        XM2  = MOLY
        CALL PLA081 (22, XM1, XM2, XM3)
        XMOL = INT(XM3) + NRESJ / PAR(42)
        IF (IPR(35) .LT. 0) THEN
          MTYPE = -1
        ELSE
          MTYPE =  0
        ENDIF
        CALL PLUT17 (XMOL, MTYPE, MADDR, LU6)
        IF (IPR(35) .LT. 0) CALL PLUT35 (XMOL, -1)
        IF (NEW .GT. 0) THEN
          RA(KAT * NP43 + 7) = RA(J * NP43 + 7)
          CALL PLUT15 (6, KAT, 11, MADDR)
        ENDIF
  290   IF (RA(KAT * NP43 + 12) .LE. 0.0) THEN
          RA(KAT * NP43 + 12) = MOLZ / 1000.0
          IF (KAT .LE. NATO) THEN
            XM1 = MOLZ
            XM2 = 0.0
            CALL PLA081 (23, XM1, XM2, XM3)
            IF (IPR(2) .NE. 0) THEN
              IPR(72) = 100 + IPR(2)
              GOTO 460
            ENDIF
            MOLY = INT(XM3)
          ENDIF
        ENDIF
        IF (I .LE. KAT) THEN
          IF (IDIS .EQ. 1000 .OR. JDIS .EQ. 1000 .OR.
     1        (IDIS .EQ. JDIS .AND. N .EQ. 1)) THEN
            IF (NEW .GT. 0) THEN
              CALL PLUT16 (-1, IDUM0, I, KAT, DUM1, IDUM2)
              IF (IPR(35) .GE. 0) THEN
                CALL PLUT15 (-3, I, 24, IVAL1)
                IF (NELJ .EQ. 3 .AND. IVAL1 .LT. 7) THEN
                  IVL = IVAL1 + 1
                  CALL PLUT15 (3, I, 24, IVL)
                ENDIF
                CALL PLUT15 (-3, KAT, 24, IVAL2)
                IF (NELI .EQ. 3 .AND. IVAL2 .LT. 7) THEN
                  IVL = IVAL2 + 1
                  CALL PLUT15 (3, KAT, 24, IVL)
                ENDIF
              ENDIF
            ENDIF
          ENDIF
        ENDIF
        GOTO 90
  300 CONTINUE
  310 IF (NEXT .EQ. 0) THEN
        J = J + 1
        IF (J .LE. NATO)  GOTO 50
        IF (IPR(35) .GE. 0) THEN
          IVL = 1
          CALL PLUT15 (2, I, 1, IVL)
          DO 320 JJ = 1, 3
            RCG(JJ, NRESI) = RCG(JJ, NRESI) + RA(I * NP43 + JJ)
  320     CONTINUE
          RCG(4, NRESI) = RCG(4, NRESI) + 1
        ENDIF
      ENDIF
  330 IF (IPR(35) .GE. 0) THEN
        IATPRI = 0
        INXT   = 0
        I      = 0
        IL0    = ILSTRT
        DO 340 IL = IL0, NATO
          CALL PLUT15 (-2, IL, 1, IVAL)
          IF (IVAL .NE. 1) THEN
            IF (IPR(50) .EQ. 0)
     1      IATPRI = IATPR(IEN(INT(RA(IL * NP43 + 7) / 32000) + 1))
            IF (IVAL .EQ. 2) THEN
              IF (IATPRI .LT. 0) THEN
                I = IL
                GOTO 349
              ELSE
                IF (I .EQ. 0) I = - IL
              ENDIF
            ENDIF
            IF (INXT .LE. 0) THEN
              IF (IVAL .EQ. 0) THEN
                IF (IATPRI .LT. 0) THEN
                  INXT =   IL
                ELSE
                  INXT = - IL
                ENDIF
              ENDIF
            ENDIF
          ELSE
            IF (IL .EQ. ILSTRT) ILSTRT = ILSTRT + 1
          ENDIF
  340   CONTINUE
        IF (I .LT. 0) THEN
          I = IABS(I)
          GOTO 349
        ENDIF
        JJ = IPR(70)
        IF (JJ .GT. 0) THEN
          ICG = IPR(38) + IPR(55) + 1
          ID0 = ICG + 1
          ID1 = ID0 + 1
          DO 360 II = 1, 3
            RCG(II, JJ)        = RCG(II, JJ) / RCG(4, JJ)
            RA(ICG * NP43 + II) = RCG(II, JJ)
            RA(ID0 * NP43 + II) = PAR(141 + II)
  360     CONTINUE
          RA(ICG * NP43 + 12) = 1.555
          CALL PLUT15 (6, ICG, 5, JJ)
          IF (IGBL(30) .LE. 0) THEN
            CALL PLUT23 (ICG)
            CALL PLUT23 (ID0)
            DUM5 = 99999.0
            IF (PAR(140) .GE. 0.0) THEN
              DO 343 K = 1, NSYM
                DO 342 L = 1, 3
                  XJX(L)     = RA(ICG * NP43 + L)
                  XJX(L + 3) = 0.0
  342           CONTINUE
                CALL SGSM (ICL, K, XJX, LU6, 3, IERR)
                DO 344 L = 1, 3
                  DUM1 = AMOD(XJX(L + 6), 1.0)
                  IF (DUM1 .LT. 0.0) DUM1 = DUM1 + 1.0
                  RA(ID1 * NP43 + L) = DUM1
                  TRL(L)            = DUM1 - XJX(L + 6)
  344           CONTINUE
                CALL PLUT23 (ID1)
                CALL PLUT22 (ID0, ID1, DUM4)
                IF (DUM4 .LT. DUM5) THEN
                  DUM5 = DUM4
                  N = K
                  DO 345 L = 1, 3
                    T(L) = TRL(L)
  345             CONTINUE
                ENDIF
  343         CONTINUE
            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
            ENDIF
            YM1 = N * 1000.0 + T(1) * 100.0 + T(2) * 10.0 + T(3)
     1          + 555.0
            CALL PLA081 (24, YM1, 0.0, YMM1)
            IF (IPR(2) .NE. 0) STOP '105'
            DO 1400 I0 = ILPB, ICG
              CALL PLUT15 (-6, I0, 5, I0RES)
              IF (I0RES .EQ. JJ) THEN
                DO 1346 L = 1, 3
                  XJX(L)     = RA(I0 * NP43 + L)
                  XJX(L + 3) = T(L)
 1346           CONTINUE
                CALL SGSM (ICL, N, XJX, LU6, 3, IERR)
                DO 1347 L = 1, 3
                  RA(I0 * NP43 + L) = XJX(L + 6)
 1347           CONTINUE
                CALL PLUT23 (I0)
                YM2 = RA(I0 * NP43 + 12) * 1000.0
                CALL PLA081 (25, YM1, YM2, YM3)
                IF (IPR(2) .EQ. 0)
     1          RA(I0 * NP43 + 12) = YM3 / 1000.0
              ENDIF
 1400       CONTINUE
            DO 1410 L = 1, 3
              RCG(L, JJ) = RA(ICG * NP43 + L)
 1410       CONTINUE
            L1 = IPR(42)
            IF (L1 .GT. 0) THEN
              DO 1420 L = 1, L1
                YRES = MOD(MOL(1, L) / PAR(42), 1.0)
                JJRES = NINT(YRES * PAR(42))
                IF (JJ .EQ. JJRES) THEN
                  YM3 = INT(MOL(1, L) / PAR(42))
                  CALL PLA081 (26, YM1, YM3, YM2)
                  IF (IPR(2) .NE. 0) STOP '103'
                  CALL PLA081 (27, YM2, YMM1, YM3)
                  IF (IPR(2) .NE. 0) STOP '102'
                  MOL(1, L) = NINT((YM3 + YRES) * PAR(42))
                ENDIF
 1420         CONTINUE
            ENDIF
          ENDIF
        ENDIF
        IF (INXT .EQ. 0) GOTO 350
        I = IABS(INXT)
        IF (IGBL(30) .EQ. 0) THEN
          NTRNS = IABS(NINT(RA(I * NP43 + 12) * 1000))
          IF (NTRNS .GT. 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 346 L = 1, 3
              XJX(L)     = RA(I * NP43 + L)
              XJX(L + 3) = T(L)
  346       CONTINUE
            CALL SGSM (ICL, N, XJX, LU6, 3, IERR)
            DO 347 L = 1, 3
              RA(I * NP43 + L) = XJX(L + 6)
  347       CONTINUE
            NTRNS = N * 1000 + NINT(T(1) * 100.0 + T(2) * 10.0 + T(3))
     1            + 555
            IF (NTRNS .NE. 1555) THEN
              IVL = 1
              CALL PLUT15 (1, I, 43, IVL)
            ENDIF
            XTRNS = NTRNS / 1000.0
          ELSE
            XTRNS = 1.555
          ENDIF
        ELSE
          XTRNS = 1.555
        ENDIF
        RA(I * NP43 + 12) = XTRNS
        IVL = 1
        CALL PLUT15 (2, I, 3, IVL)
        IF (IPR(70) .LT. NRESM) THEN
          IF (IPR(136) .EQ. 0) THEN
            IPR(70) = IPR(70) + 1
          ELSE
            CALL PLUT15 (-6, I, 5, IPR(70))
          ENDIF
          IPR(75) = MAX (IPR(75), IPR(70))
          IF (IPR(70) .EQ. NRESM) WRITE (LU6, 99999) NRESM
        ENDIF
        XMOL = 1555.0 + IPR(70) / PAR(42)
        CALL PLUT17 (XMOL, 0, MADDR, LU6)
  349   CALL PLUT23 (I)
        CALL PLUT15 (6, I,  5, IPR(70))
        IVL = IPR(75) - 1
        CALL PLUT15 (6, I, 11, IVL)
      ELSE
        I = I + 1
        IF (I .GT. NATO)  GOTO 350
      ENDIF
      GOTO 40
  350 IPR(37) = IPR(38) + IPR(55)
      IF (IPR(35) .GE. 0) THEN
        IPR(38) = IPR(37)
        IPR(53) = IPR(52)
        IPR(20) = 1
        WRITE (LU6, 99997) IPR(75)
        DO 390 I = ILPB, NATO
          CALL PLUT15 (-2, I, 3, IVAL)
          IF (IVAL .EQ. 2) THEN
            IVL = 1
            CALL PLUT15 (1, I, 43, IVL)
          ENDIF
  390   CONTINUE
      ENDIF
      IF (IPR(35) .LT. 0) THEN
        MTYPE = -1
      ELSE
        MTYPE   = 0
        IPR(43) = IPR(42)
        IPR(44) = IPR(42)
      ENDIF
        DO 395 I = ILPB, IPR(39)
          IF (RA(I * NP43 + 12) .NE. 1.555) IGBL(60) = IGBL(60) + 1
  395   CONTINUE
      IF (IPR(110) .EQ. 1) THEN
        INFIN = 0
        IF (IPR(42) .GT. 1) THEN
          NML0   = 0
  400     NMOL   = IPR(42)
          MI     = 0
  410     MI     = MI + 1
          IF (MI .GT. NMOL) GOTO 440
          MPM = MOL(1, MI)
          IF (MPM .LT. 0) GOTO 410
          CALL GEN098 (MPM, PAR(42), MS1, MT11, MT21, MT31, MR1)
          IF (MI .GT. NML0) THEN
            MJ = 0
          ELSE
            MJ = NML0
          ENDIF
  420     MJ = MJ + 1
          IF (MJ .GT. NMOL) GOTO 410
          MPM = MOL(1, MJ)
          IF (MPM .LT. 0) GOTO 420
          CALL GEN098 (MPM, PAR(42), MS2, ITX, ITY, ITZ, MR2)
          IF (MR2 .NE. MR1) GOTO 420
          XJX(1) = MS1
          XJX(2) = MT11
          XJX(3) = MT21
          XJX(4) = MT31
          XJX(5) = MS2
          XJX(6) = ITX
          XJX(7) = ITY
          XJX(8) = ITZ
          CALL SGSM (ICL, 0, XJX, LU6, 8, IERR)
          MS3  = NINT(XJX(9))
          MT13 = NINT(XJX(10))
          MT23 = NINT(XJX(11))
          MT33 = NINT(XJX(12))
          M3   = (MS3 * 1000 + MT13 * 100 + MT23 * 10 + MT33 + 555)
          M3   = NINT(M3 * PAR(42)) + MR1
          XM3  = M3 / PAR(42)
          MK   = 0
  430     MK   = MK + 1
          IF (MK .GT. NMOL) THEN
            CALL PLUT17 (XM3, MTYPE, MADDR, LU6)
            IF (IPR(35) .LT. 0) CALL PLUT35 (XM3, -1)
            GOTO 420
          ENDIF
          XM4 = MOL(1, MK) / PAR(42)
          IF (XM4 .LT. 0.0) GOTO 420
          IF (XM3 .EQ. XM4) GOTO 420
          M4  = INT(XM4)
          MR4 = NINT((XM4 - M4) * PAR(42))
          IF (MR4 .NE. MR1) GOTO 430
          MS4 = M4 / 1000
          MT4 = M4 - MS4 * 1000
          IF (MS3 .EQ. MS4) THEN
            MT14 = MT4 / 100
            IF (IABS(MT13 - MT14 + 5) .GT. 0) THEN
              INFIN = 1
              GOTO 420
            ELSE
              MT4 = MT4 - MT14 * 100
              MT24 = MT4 / 10
              IF (IABS(MT23 - MT24 + 5) .GT. 0) THEN
                INFIN = 1
                GOTO 420
              ELSE
                MT34 = MT4 - MT24 * 10
                IF (IABS(MT33 - MT34 + 5) .GT. 0) THEN
                  INFIN = 1
                  GOTO 420
                ENDIF
              ENDIF
            ENDIF
          ENDIF
          GOTO 430
  440     IF (IPR(42) .GT. NMOL) THEN
            NML0 = NMOL
            GOTO 400
          ENDIF
        ENDIF
        IF (IPR(35) .GE. 0) THEN
          IPR(43) = IPR(42)
          IPR(44) = IPR(42)
          DO 500 I = 1, IPR(37)
            NRI  = INT(RA(I * NP43 + 7) / 32000) + 1
            NELI = IEN(NRI)
            IF (NELI .EQ. 4) THEN
              CALL PLUT15 (-4, I, 33, IVL)
              IF (IVL .EQ. 2) THEN
                NRBO = 99
              ELSE IF (IVL .EQ. 3) THEN
                NRBO = 2
              ELSE
                NRBO = 1
              ENDIF
            ELSE IF (NELI .EQ. 6) THEN
              NRBO = 2
            ELSE
              NRBO = 99
            ENDIF
            CALL PLUT15 (-3, I, 24, IVAL)
            IF (IVAL .GE. NRBO) THEN
              IVL = 0
              CALL PLUT15 (1, I, 46, IVL)
              DO 495 J = 1, IPR(37)
                NRJ = INT(RA(J * NP43 + 7) / 32000) + 1
                IATPRJ = IATPR(IEN(NRJ))
                IF (IATPRJ .GT. 0) THEN
                  CALL PLUT16 (-3, IDUM0, I, J, DUM1, IDUM2)
                ENDIF
  495         CONTINUE
            ENDIF
  500     CONTINUE
          WRITE (LU6, 99995) IPR(43)
          IF (INFIN .GT. 0) THEN
            IPR(73) = 1
            WRITE (LU6, 99994)
          ENDIF
        ENDIF
      ENDIF
  460 IF (IPR(50) * IPR(135) .GT. 0) THEN
        DO 455 I = 1, IPR(37)
          ZZ = MOD(RA(I * NP43 + 3), 100.0)
          IF (ZZ .GT. 50.0) ZZ = ZZ - 100.0
          RA(I * NP43 + 3) = ZZ
          RA(I * NP43 + 6) = ZZ
  455   CONTINUE
      ENDIF
      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 PLUT08
      PARAMETER (NP12=600,NP13=500,NP14=64,NP17=99,NPVD=40000000,
     1 NP23=18000,NP32=63,NP38=125,NP39=30,NP43=12,NP45=2048)
      COMMON // MOL(2, NP23), RA(NPVD)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLUTO/ IPPR(129, 3), IBT(32), TRL(3), ROM(3, 3), R(3, 3),
     1 RP(NP14), XJX(12), XXX(12), YYY(12), TMX(3, 3), SHFT(3),
     2 XYZOR(3), XYZR(3),  ZU(15), OM(3, 3), RCG(4, NP32), TMY(3, 3),
     3 XYZPL(6), A(3, 3), XYZK(8), KRS(NP32), NCRS(9), NPRS(17)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /Q/ ICL, IFL(NP17)
      CHARACTER ICL*(NP45), IFL*7
      DIMENSION V(3, 3), XDA(6)
      CALL PLUT17 (0.0, 0, MADDR, LU6)
      NAT  = IPR(37)
      NMOL = IPR(42)
      ILPB = IPR(69) + 1
      CALL GEN074 (PAR, 0.0, 67, 69)
      N  = 0
      K  = (NAT + 1) * NP43
      KM = IPR(64) - IPR(52) * 2 - 3
      DO 60 I = ILPB, NAT
        CALL PLUT15 (-1, I, 27, NINCL)
        IF (NINCL .GT. 0) THEN
          CALL PLUT15 (-6, I, 5, IRES)
          CALL PLUT15 (-6, I, 18, JINC)
          IF (JINC .EQ. 1) THEN
            NM = NMOL
          ELSE
            NM = 1
          ENDIF
          DO 50 M = 1, NM
            XNM = MOL(1, M) / PAR(42)
            IF (XNM .GT. 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
              IF (NR .EQ. 0 .OR. IRES .EQ. NR) THEN
                DO 20 II = 1,3
                  XJX(II)     = RA(I * NP43 + II)
                  XJX(II + 3) = TRL(II)
   20           CONTINUE
                CALL SGSM (ICL, NS, XJX, LU6, 3, IERR)
                DO 30 II = 1, 3
                  RA(II) = XJX(II + 6)
   30           CONTINUE
                CALL PLUT23 (0)
                IF (K .LT. KM) THEN
                  DO 40 II = 1, 3
                    RA(K + II)   = RA(II + 3)
                    PAR(66 + II) = PAR(66 + II) + RA(II + 3)
   40             CONTINUE
                  K = K + 3
                  N = N + 1
                ELSE
                  IPR(101) = IPR(101) + 1
                ENDIF
              ENDIF
            ENDIF
   50     CONTINUE
        ENDIF
   60 CONTINUE
      IF (N .GT. 0) THEN
        IF (N .GT. 1) THEN
          IF (N .EQ. 2) THEN
            DO 70 II = 1, 3
              PAR(66 + II) = PAR(66 + II) + 0.01
   70       CONTINUE
          ENDIF
          CALL GEN074 (XDA, 0.0, 1, 6)
          DO 80 II = 1, 3
            PAR(66 + II) = PAR(66 + II) / N
   80     CONTINUE
          K = (NAT + 1) * NP43
          DO 90 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
            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)
   90     CONTINUE
          CALL GEN023 (XDA, V, 3)
          CALL GEN005 (V, R)
          DO 100 K = 1, 3
            TEMP = R(1, K)
            R(1, K) = -R(3, K)
            R(3, K) = TEMP
  100     CONTINUE
          CALL GEN010 (R, IDET, 1)
        ELSE
          CALL GEN021 (R, 1)
        ENDIF
      ELSE
        IPR(72) = 30
      ENDIF
      RETURN
      END
      SUBROUTINE PLUT09 (NINCL, ISW)
      PARAMETER (NP4=9,NP10=16,NP12=600,NP13=500,NP17=99,
     1 NPVD=40000000,NP22=256,NP23=18000,NP38=125,NP39=30,
     2 NP43=12,NP45=2048)
      COMMON // MOL(2, NP23), RA(NPVD)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /Q/ ICL, IFL(NP17)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      CHARACTER N213*3
      IS = ISW
      IF (IABS(IGBL(8)) .NE. 2) THEN
        IF (IS .EQ. 89 .OR. IS .EQ. 159) THEN
          IS = 28
          NINCL  = 0
        ENDIF
      ENDIF
      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 .GT. 1) THEN
        N213 = IFL(2)(1:3)
      ELSE
        N213 = 'ALL'
      ENDIF
      NINC = NINCL
      IF (N213 .EQ. 'NON') THEN
        NINC = MOD(NINCL + 1, 2)
        N213 = 'ALL'
      ENDIF
      IF (N213 .EQ. 'ALL') THEN
        DO 220 I = ILPB, NAT
          CALL PLUT15 (1, I, 27, NINC)
  220   CONTINUE
      ELSE IF (N213 .EQ. 'ZOM') THEN
        IPR(166) = NINC
        IPR(130) = 0
      ELSE IF (N213 .EQ. 'OUT') THEN
        DO 120 I = 1, 3
          PAR(I * 2 + 28) =  1.01
          PAR(I * 2 + 27) = -0.01
  120   CONTINUE
        PAR(35) = 4.5
        IF (KL .EQ. 3) THEN
          CALL PLUT13 (0, KL, M, XDUM)
        ELSE
          M = 0
        ENDIF
        IF (KN .EQ. 0 .AND. M .LE. 0) THEN
          IPR(15) = 1
        ELSE IF (KN .EQ. 1) THEN
          PAR(35) = FN(1)
          IF (PAR(35) .GT. 0.0) THEN
            IPR(15) = - M
          ELSE
            IPR(15) = 0
          ENDIF
        ELSE IF (KN .EQ. 6) THEN
          DO 170 I = 1, KN
            PAR(I + 28) = FN(I)
  170     CONTINUE
          IF (M .GT. 0) THEN
            DO 150 I = 1, 3
              DO 140 J = 27, 28
                PAR(I * 2 + J) = PAR(I * 2 + J) + RA(M * NP43 + I)
  140         CONTINUE
  150       CONTINUE
          ENDIF
          IPR(15) = 1
        ELSE
          IPR(72) = 31
        ENDIF
      ELSE
        DO 100 K = 2, KL
           IF (IFL(K)(1:3) .EQ. 'UNI') THEN
             M = NATO + 1
             IF (M .LE. NATOS) THEN
               DO 10 I = M, NATOS
                  CALL PLUT15 (1, I, 27, NINCL)
   10          CONTINUE
             ENDIF
           ELSE IF (IFL(K)(1:3) .EQ. 'INT') THEN
             M = NATOS + 1
             IF (M .LE. NAT) THEN
               DO 30 I = M, NAT
                 CALL PLUT15 (1, I, 27, NINCL)
   30          CONTINUE
             ENDIF
           ELSE IF (IFL(K)(1:3) .EQ. 'ORI') THEN
             DO 50 I = ILPB, NATO
               CALL PLUT15 (1, I, 27, NINCL)
   50        CONTINUE
           ELSE
             IF (IS .EQ. 89 .OR. IS .EQ. 159) THEN
               CALL PLUT13 (0, K, M, XDUM)
             ELSE
               CALL PLUT13 (0, -K, M, XDUM)
             ENDIF
             IF (M .LT. 0) THEN
               IBEG = ILPB
               IF (NINC .EQ. 0) THEN
                 IEND = NAT
               ELSE
                 IEND = NATO
               ENDIF
             ELSE
               CALL PLUT25 (0, M, IAI)
               IBEG = M
               IEND = M
               M    = - IAI
             ENDIF
             DO 80 I = IBEG, IEND
               CALL PLUT25 (0, I, IAI)
               IF (IAI .EQ. - M) THEN
                 IF (IS .EQ. 89 .OR. IS .EQ. 159) THEN
                   IVAL = 0
                   CALL PLUT15 (6, I, 18, IVAL)
                   CALL PLUT25 (1, I, IDUM2)
                   CALL PLUT29 (4, NQ1, NQ2, 0)
                 ELSE
                   CALL PLUT15 (1, I, 27, NINCL)
                 ENDIF
               ENDIF
   80        CONTINUE
           ENDIF
  100   CONTINUE
      ENDIF
      IF (IS .EQ. 89 .OR. IS .EQ. 159) THEN
        L = IPR(69)
        DO 300 I = ILPB, NATO
          CALL PLUT15 (-6, I, 18, IMULT)
          IF (IMULT .GT. 0) THEN
            L = L + 1
            DO 310 K = 1, 12
              RA(L * NP43 + K) = RA(I * NP43 + K)
  310       CONTINUE
          ENDIF
  300   CONTINUE
        IPR(37)  = L
        IPR(38)  = L
        IPR(39)  = L
        IPR(170) = 2
      ENDIF
      RETURN
      END
      SUBROUTINE PLUT10
      PARAMETER (NP0=6,NP4=9,NP9=118,NP10=16,NP12=600,NP13=500,NP14=64,
     1 NP17=99,NPVD=40000000,NP22=256,NP23=18000,NP32=63,NP38=125,
     2 NP39=30)
      COMMON // MOL(2, NP23), RA(NPVD)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLUTO/ IPPR(129, 3), IBT(32), TRL(3), ROM(3, 3), R(3, 3),
     1 RP(NP14), XJX(12), XXX(12), YYY(12), TMX(3, 3), SHFT(3),
     2 XYZOR(3), XYZR(3),  ZU(15), OM(3, 3), RCG(4, NP32), TMY(3, 3),
     3 XYZPL(6), A(3, 3), XYZK(8), KRS(NP32), NCRS(9), NPRS(17)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9),
     1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10),
     2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10),
     3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770)
      LOGICAL CC
      COMMON /CTRLC/ CC
      PAR145  = 0.0
      CPH     = 0.0
      SPH     = 0.0
      IDF     = 0
      IRADR   = 0
      JRADR   = 0
      IND1    = 0
      IND2    = 0
      IND3    = 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)
      NATOT   = IPR(62)
      ILPB    = IPR(69) + 1
      PAR(37) = 0
      IF (.TRUE.) THEN
        IPR151 = IPR(151)
        IPR152 = IPR(152)
        IF (IPR151 .GT. 0) THEN
          IF (IPR(116) .NE. 0) IPR(336) = 0
          PAR145   = PAR(145)   * IPR(164)
          CPH      = COS(PAR145 / GL(5))
          SPH      = SIN(PAR145 / GL(5))
          IDF      = NATOT * NP0
          DELCOL   = IPR(153)
          WRICOL   = IPR(154)
          PAR(146) = 0.0
          IRADR    = IPR(157)
          JRADR    = IPR(167)
          IND1     = IPR(155)
          IND2     = 2
          IND3     = 3
          IF (IND1 .EQ. 2) THEN
            IND2   = 1
            IND3   = 3
            SPH    = - SPH
          ELSE IF (IND1 .EQ. 3) THEN
            IND2   = 1
            IND3   = 2
          ENDIF
        ENDIF
        IF (IPR(4) .EQ. 0 .OR. IPR(151) .GT. 0) THEN
          CSS = COS (6.0 / GL(5))
          SNS = SIN (6.0 / GL(5))
          DO 10 K = 1, NATOT
            IF (IPR(116) .NE. 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)
            ENDIF
            IO = MOD(K - ILPB, NAB) + ILPB
            CALL PLUT15 (-1, IO, 27, NINCL)
            IF (NINCL .NE. 0) THEN
              CALL PLUT14 (-1, K, NPROP, IUASU, XYZK(1), XYZK(2),
     1                     XYZK(3), XYZK(4))
              IF (XYZK(4) .LT. 0.0 .OR. XYZK(4) .GT. 999.9) GOTO 10
              IF (IO .GE. ILPB) THEN
                CALL PLUT15 (-4, IO, 33, NBOND)
              ELSE
                NBOND = 3
              ENDIF
              IF (NBOND .EQ. 0) THEN
                I = K * NP0 + IPR(158)
                CALL PLUT31 (I - NP0, -1.0)
                IF (IPR(151) .GT. 0) RA(I) = 100000.0
              ENDIF
            ENDIF
   10     CONTINUE
        ENDIF
   20   IF (IPR(151) .NE. 0 .AND. IGBL(25) .EQ. 1) THEN
          XG = 0.0
          YG = 0.0
          ZG = 0.0
          IG = 9
          CALL GGIP (XG, YG, ZG, IG)
          IF (IG .GT. 0) CC = .TRUE.
        ENDIF
        IF (CC) THEN
          IF (IPR(116) .EQ. 0) THEN
            IPR(346) =   IABS(IPR(346))
          ELSE
            IPR(346) = - IABS(IPR(346))
          ENDIF
          IPR(4) = IABS(IPR(4))
          GOTO 120
        ENDIF
        IPR(56) = 0
        IADR    = IPR(79)
   30   IPR(56) = IPR(56) + 1
        IF (IPR(151) .LE. 0) THEN
          IF (CC) THEN
            IPR(346) = IABS(IPR(346))
            GOTO 120
          ENDIF
        ENDIF
        IF (IPR(56) .GT. IPR(97)) THEN
          IPR151 = IPR151 - 1
          IF (IPR151 .LE. 0) THEN
            GOTO 110
          ELSE
            IF (CC) THEN
              IPR(346) = IABS(IPR(346))
              GOTO 120
            ENDIF
            PAR(146) = PAR(146) + PAR145
            JADR     = IRADR
            KADR     = JADR  + IDF
            JADR1    = JRADR
            KADR1    = JADR1 + IDF
            DO 40 I = 1, NATOT
              RA(JADR + NP0)  = RA(KADR + NP0)
              RA(JADR + IND1 + NP0 - 4) = RA(KADR + IND1 + NP0 - 4)
              RAK2                      = RA(KADR + IND2 + NP0 - 4)
              RAK3                      = RA(KADR + IND3 + NP0 - 4)
              RA(JADR + IND2 + NP0 - 4) =   CPH * RAK2 + SPH * RAK3
              RA(JADR + IND3 + NP0 - 4) = - SPH * RAK2 + CPH * RAK3
              IF (IPR(116) .NE. 0) THEN
                RA(JADR1 + IND1 + NP0 - 4) =
     1             RA(KADR1 + IND1 + NP0 - 4)
                RA(JADR1 + NP0)  = RA(KADR1 + NP0)
                RAK2             = RA(KADR1 + IND2 + NP0 - 4)
                RAK3             = RA(KADR1 + IND3 + NP0 - 4)
                RA(JADR1 + IND2 + NP0 - 4) = CPH * RAK2 + SPH * RAK3
                RA(JADR1 + IND3 + NP0 - 4) =
     1              - SPH * RAK2 + CPH * RAK3
              ENDIF
              IF (RA(KADR + NP0) .GT. 9999.0) THEN
                CALL PLUT31 (KADR, DELCOL)
                IF (IPR(116) .NE. 0) WRICOL = IPR(144)
                CALL PLUT31 (JADR, WRICOL)
                IF (IPR(116) .NE. 0) THEN
                  CALL PLUT31 (KADR1, DELCOL)
                  CALL PLUT31 (JADR1, FLOAT (IPR(143)))
                ENDIF
              ENDIF
              JADR    = JADR + NP0
              KADR    = KADR + NP0
              IF (IPR(116) .NE. 0) THEN
                JADR1  = JADR1 + NP0
                KADR1  = KADR1 + NP0
              ENDIF
   40       CONTINUE
            IRADR = IRADR + IDF
            JRADR = JRADR + IDF
            IDF   = - IDF
            GOTO 20
          ENDIF
        ENDIF
        IF (IPR151 .GT. 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) .NE. 0) THEN
            IDL1 = JRADR + NINT(RA(IADR + 1) * NP0)
            NDL1 = JRADR + NINT(RA(IADR + 2) * NP0)
            IDR1 = IDL1 + IDF
            NDR1 = NDL1 + IDF
          ENDIF
          IF (IPR151 .LT. 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) .EQ. 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)
            ENDIF
            CALL GGIP (RAXPL, RAYPL, 0.0, 2)
            IF (IPR(116) .NE. 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)
            ENDIF
          ENDIF
          CALL GGIP (RA(IDR - 3), RA(IDR - 2), 0.0, 3)
          RAXPL = RA(NDR - 3)
          RAYPL = RA(NDR - 2)
          IF (IPR(336) .EQ. 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 .GT. 0)  JCOL = IACL(JCOL)
            IF (JCOL .EQ. 0 .OR. JCOL .EQ. 17) JCOL = IPR(19)
            ICOL = ICOL / 32
            ICOL = IPR(19)
            IF (ICOL .GT. 0)  ICOL = IACL(ICOL)
            IF (ICOL .EQ. 0 .OR. ICOL .EQ. 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)
          ENDIF
          IF (IPR(116) .NE. 0)
     1        CALL GGIP (0.0, FLOAT(IPR(144)), 0.0, 0)
          CALL GGIP (RAXPL, RAYPL, 0.0, 2)
          IF (IPR(116) .NE. 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)
          ENDIF
          GOTO 30
        ENDIF
        IPR(67) = 0
        CALL PLUT16 (IPR(56), I1, I, N, RBO, NBLNE)
        IF (I .EQ. 0) STOP ' KAN NIET GOTO 30'
        IF (NBLNE .LT. 0) THEN
          NBLNE = IABS(NBLNE)
          IDASH = 1
        ELSE
          IDASH = 0
        ENDIF
        PAR(37) = RBO * PAR(24)
        NN      = I
        IPR(67) = 5
        IF (IPR(82) .NE. 0 .AND. IPR(116) .LE. 0) THEN
          III = IPR(125) + I * 4
          IIN = IPR(125) + N * 4
          IF (IPR(10) .EQ. 0) THEN
            IB1 = NINT(RA(III - 3))
            IB2 = NINT(RA(IIN - 3))
            WRITE (LU25, 99999) IB1, IB2
          ELSE
            IF (IPR(4) .EQ. 0) THEN
              IF (I .LE. IPR(69)) THEN
                CALL GEN040 (I, NQ1, IYANK)
              ELSE
                CALL PLUT25 (1, I, IYANK)
              ENDIF
              IF (N .LE. IPR(69)) THEN
                CALL GEN040 (N, NQ2, IYANK)
              ELSE
                CALL PLUT25 (2, N, IYANK)
              ENDIF
              IF (IPR(10) .EQ. 1) THEN
                WRITE (LU28, 99997)  NQ1, NQ2, RA(III - 2) - PAR(67),
     1                                     RA(III - 1) - PAR(68),
     2                                    -RA(III)     + PAR(69),
     3                                     RA(IIN - 2) - PAR(67),
     4                                     RA(IIN - 1) - PAR(68),
     5                                    -RA(IIN)     + PAR(69),
     6                                     MAX (RBO, 0.05)
              ENDIF
            ENDIF
          ENDIF
        ENDIF
        IF (IPR(4) .GT. 0) THEN
          IF (IGBL(25) * IGBL(32) .EQ. 1) THEN
            XG = 0.0
            YG = 0.0
            ZG = 0.0
            IG = 9
            CALL GGIP (XG, YG, ZG, IG)
            IF (IG .EQ. 3) THEN
              IPR(45) = 1
              GOTO 120
            ENDIF
          ENDIF
          CALL PLUT18 (IPR(40) + 1, IPR(40) + 2)
          IF (IPR(78) .LT. 0)  GOTO 30
        ELSE
          IPR(78) = 0
        ENDIF
        IF (NBLNE .GT. 1) THEN
          DELT = GL(6) / (2 * FLOAT(NBLNE - 1))
        ELSE
          DELT = 0.0
        ENDIF
        IF (IPR(4) .EQ. 0) THEN
          IF (IPR(346) .EQ. 1) THEN
            NBLNE = 2
            IF (IPR(477) .EQ. 0 .AND. IPR(120) .NE. 0) THEN
              ICOL = IACL(IPR(120) / 32)
              IF (ICOL .EQ. 17) ICOL = IPR(19)
              JCOL = IACL(MOD(IPR(120), 32))
              IF (JCOL .EQ. 17) JCOL = IPR(19)
            ELSE
              ICOL = IPR(120)
              JCOL = IPR(120)
            ENDIF
          ENDIF
        ENDIF
        ZU(4) = 0.0
        ZU(5) = 0.0
        ZU(6) = 1.0
        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 .EQ. 1) THEN
          ISTK1 = ISTK + 2 * NP0
          ISTK2 = ISTK + 4 * NP0
          DO 50 L = 1, 3
            L4 = NP0 + L - 4
            DIST = DIST + (RA(ISTK + NP0 + L4)
     1           - RA(ISTK + L4)) ** 2
   50     CONTINUE
          IDELD = NINT(3.0 * SQRT(DIST) / PAR(24)) * 2 + 1
          DO 60 L = 1, 3
            L4 = NP0 + L - 4
            RA(ISTK2 + L4) = (RA(ISTK + NP0 + L4)
     1                     - RA(ISTK + L4)) / IDELD
   60     CONTINUE
          RA(ISTK2 + NP0) = (RA(ISTK + 2 * NP0)
     1                    - RA(ISTK + NP0)) / IDELD
        ENDIF
   70   L0 = L0 + 2
        IF (L0 .GE. IDELD) GOTO 30
        IF (IDASH .EQ. 1) THEN
          DO 80 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)
   80     CONTINUE
        ENDIF
        IF (IPR(10) .EQ. 1 .AND. IPR(4) .NE. 0) THEN
          IF (I .LE. IPR(69)) THEN
            CALL GEN040 (I, NQ1, IYANK)
          ELSE
            CALL PLUT25 (1, I, IYANK)
          ENDIF
          IF (N .LE. IPR(69)) THEN
            CALL GEN040 (N, NQ2, IYANK)
          ELSE
            CALL PLUT25 (2, N, IYANK)
          ENDIF
          WRITE (LU28, 99997)  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)
        ENDIF
        NN    = I
        THETA = 0.0
        NLIN  = 0
   90   CT = COS(THETA)
        ST = SIN(THETA)
        DO 100 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)
  100   CONTINUE
        NLIN = NLIN + 1
        IF (IPR(4) .EQ. 0) THEN
          IF (IPR(346) .EQ. 1) THEN
            IF (NN .GT. 0) THEN
              ICOL1 = ICOL
            ELSE
              ICOL1 = JCOL
            ENDIF
            IF (ICOL1 .EQ. 0) ICOL1 = IPR(19)
            CALL GGIP (0.0, FLOAT(ICOL1), 0.0, 0)
          ENDIF
        ENDIF
        IF (IPR(10) .LE. 0) CALL PLUT19 (0, NN)
        IF (NLIN .GE. NBLNE)  GOTO 70
        NN    = - NN
        THETA = THETA + DELT
        GOTO 90
      ENDIF
  110 IF (IPR(82) .NE. 0 .AND. IPR(116) .LE. 0) THEN
        IF (IPR(10) .EQ. 0) THEN
          WRITE (LU25, 99998)
        ELSE IF (IPR(10) .EQ. 1) THEN
          WRITE (LU28, 99996) PAR(24) * 0.16
          IPR(10) = 0
        ELSE IF (IPR(10) .EQ. 2) THEN
          IPR(10) = 0
        ENDIF
      ENDIF
  120 IF (PAR(146) .NE. 0) THEN
        CALL GEN043 (IPR(155), A, PAR(146) / GL(5))
        CALL GEN004 (A, R, R)
        PAR(146) = 0
        IPR(151) = -1
      ENDIF
      RETURN
99999 FORMAT (I4, 1X, I4)
99998 FORMAT ('END', /, 'END')
99997 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 } } }')
99996 FORMAT ('scale', F7.3, /, 'rotate y*180', /, 'translate y*-0.25',
     1 /, '}', /, '// End-of-Plot')
      END
      SUBROUTINE PLUT11
      PARAMETER (NP9=118,NP10=16,NP12=600,NP13=500,NP14=64,
     1 NP17=99,NPVD=40000000,NP23=18000,NP32=63,NP38=125,NP43=12,
     2 NP39=30)
      COMMON // MOL(2, NP23), RA(NPVD)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLUTO/ IPPR(129, 3), IBT(32), TRL(3), ROM(3, 3), R(3, 3),
     1 RP(NP14), XJX(12), XXX(12), YYY(12), TMX(3, 3), SHFT(3),
     2 XYZOR(3), XYZR(3),  ZU(15), OM(3, 3), RCG(4, NP32), TMY(3, 3),
     3 XYZPL(6), A(3, 3), XYZK(8), KRS(NP32), NCRS(9), NPRS(17)
      COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9),
     1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10),
     2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10),
     3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770)
      NAB   = IPR(37) - IPR(69)
      NATOT = IPR(62)
      ILPB  = IPR(69) + 1
      IF (IPR(4) .NE. 0) THEN
        DO 170 K = ILPB, NATOT
          IO = MOD(K - ILPB, NAB) + ILPB
          CALL PLUT15 (-1, IO, 27, NINCL)
          IF (NINCL .NE. 0) THEN
            IF (IGBL(25) * IGBL(32) .EQ. 1) THEN
              XG = 0.0
              YG = 0.0
              ZG = 0.0
              IG = 9
              CALL GGIP (XG, YG, ZG, IG)
              IF (IG .EQ. 3) THEN
                IPR(45) = 1
                GOTO 180
              ENDIF
            ENDIF
            IF (K .LE. IPR(37)) THEN
              IF (IPR(130) .EQ. 0) THEN
                IVAL = 1
                CALL PLUT15 (1, K, 45, IVAL)
              ENDIF
            ENDIF
            IPR(67) = 0
            CALL PLUT14 (-1, K, IASU, NPROP, XYZK(1), XYZK(2), XYZK(3),
     1                                 XYZK(4))
            IF (XYZK(4) .LT. 0 .OR. XYZK(4) .GT. 999.9)  GOTO 170
            CALL PLUT18 (K, 0)
            IF (IPR(78) .LT. 0) THEN
              IF (K .LE. IPR(37)) THEN
                IVAL = 0
                CALL PLUT15 (1, K, 45, IVAL)
              ENDIF
            ELSE
              NEL    = INT(RA(IO * NP43 + 7) / 32000) + 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
              IF (IPR(346) .EQ. 1) THEN
                ISHADE  = 1
                PAR(6)  = PAR(23)
                IF (IPR(477) .EQ. 0) THEN
                  ICOL0   = IACL(NEL)
                  IF (ICOL0 .GT. 8) ICOL0 = 0
                ELSE IF (IPR(477) .EQ. -1) THEN
                  CALL PLUT15 (-6, IO, 5, NRS)
                  IF (NRS .GT. 0 .AND. NRS .LE. 8) THEN
                    ICOL0 = NCRS(NRS)
                  ELSE
                    ICOL0 = 0
                  ENDIF
                ELSE
                  CALL GEN048 (-5, NPROP, 1, ICOL0)
                ENDIF
                IPR(88) = ICOL0
                IF (ICOL0 .EQ. 0) THEN
                  IF (IABS(IPR(477)) .NE. 1) THEN
                    ICOL0 = IPR(19)
                  ELSE
                    ISHADE = 0
                  ENDIF
                ENDIF
              ENDIF
              PAR(130) = 0.0
              PAR(131) = 0.0
              IF (IPR(345) .EQ. 1) THEN
                PAR(6) = 2.0 * XYZK(4) / (IPR(54) + 1)
                IF (IPR(478) .EQ. 0) THEN
                  IF (IPR(461) .EQ. 0) THEN
                    IPR(162) = IBCL(NEL)
                  ELSE
                    IPR(162) = IPR(139)
                  ENDIF
                ELSE IF (IPR(478) .LT. 0) THEN
                  CALL PLUT15 (-6, IO, 5, NRS)
                  IF (NRS .GT. 0 .AND. NRS .LE. 16) THEN
                    IPR(162) = NPRS(NRS)
                  ELSE
                    IPR(162) = 0
                  ENDIF
                ELSE
                  CALL GEN048 (-5, NPROP, 6, IPR(162))
                ENDIF
              ELSE
                IPR(162) = IPR(139)
              ENDIF
              IF (IPR(162) .EQ. 1) THEN
                NPRC   = NINT(IPR(8) * PAR(24) / 4) + 1
                ISHADE = 0
              ENDIF
              IF (IPR(162) .EQ. 2) THEN
                IF (IPR(4) .EQ. 3) THEN
                  NPRH = IPR(85) + 10
                  NPRV = IPR(86) + 10
                ELSE
                  NPRH = IPR(85)
                  NPRV = IPR(86)
                ENDIF
                NPRH = NINT(NPRH * PAR(24) / 4)
                NPRV = NINT(NPRV * PAR(24) / 4)
                ISHADE = 0
              ELSE IF (IPR(162) .EQ. 7) THEN
                NPRH   = 3
                NPRV   = 3
                NPRHM  = 2
                NPRVM  = 2
                ISHADE = 0
              ELSE IF (IPR(162) .EQ. 8) THEN
                IF (IPR(4) .EQ. 3) THEN
                  NPRC = IPR(112) * 2
                  NPRV = IPR(132) * 2
                ELSE
                  NPRC = IPR(112)
                  NPRV = IPR(132)
                ENDIF
                NPRC     = NINT(NPRC * PAR(24) / 4)
                NPRV     = NINT(NPRV * PAR(24) / 4)
                PAR(130) = -45.0
                PAR(131) = -35.0
                ISHADE   = 0
                IF (IPR(96) .EQ. 1) THEN
                  ISHADE = 1
                  PAR(6) = 0.075
                  PAR(7) = 145.0
                  PAR(8) = -55.0
                ENDIF
              ELSE IF (IPR(162) .EQ. 9) THEN
                NPRC     = NINT(IPR(112) * PAR(24) / 4)
                NPRV     = 0
                ISHADE   = 0
                PAR(130) = -45.0
                PAR(131) = -35.0
              ELSE IF (IPR(162) .EQ. 10) THEN
                NPRC     = 0
                NPRV     = NINT(IPR(132) * PAR(24) / 4)
                ISHADE   = 0
                PAR(130) = -45.0
                PAR(131) = -35.0
              ENDIF
              IF (IPR(162) .EQ. 3) THEN
                ISHADE = 1
                PAR(6) = PAR(134)
                PAR(7) = PAR(135)
                PAR(8) = PAR(136)
              ELSE IF (IPR(162) .EQ. 11) THEN
                ISHADE = 1
                PAR(6) = 2.0 * XYZK(4) / (IPR(54) + 1)
                PAR(8) = 0.0
              ELSE IF (IPR(162) .EQ. 12) THEN
                ISHADE = 1
                PAR(6) = 2.0 * XYZK(4) / (IPR(54) + 1)
                PAR(8) = 90.0
              ELSE IF (IPR(162) .EQ. 13) THEN
                ISHADE = 2
                PAR(6) = 2.0 * XYZK(4) / (IPR(54) + 1)
                PAR(8) = 0.0
              ELSE IF (IPR(162) .EQ. 14) THEN
                ISHADE = 1
                PAR(6) = 2.0 * XYZK(4) / (IPR(54) + 1)
                PAR(8) = -45.0
              ELSE IF (IPR(162) .EQ. 15) THEN
                ISHADE = 1
                PAR(6) = 2.0 * XYZK(4) / (IPR(54) + 1)
                PAR(8) = 45.0
              ELSE IF (IPR(162) .EQ. 16) THEN
                ISHADE = 2
                PAR(6) = 2.0 * XYZK(4) / (IPR(54) + 1)
                PAR(8) = -45.0
              ELSE IF (IPR(162) .EQ. 6 .AND. NEL .NE. 1) THEN
                ISHADE = 1
                PAR(6) = PAR(23)
              ENDIF
              IF (IPR(162) .EQ. 4) THEN
                ISEGM  = 1
                NPRC   = 3
                ISHADE = 0
              ENDIF
              IF (IPR(162) .EQ. 5) THEN
                NDOTS  = 1
                ISHADE = 0
              ENDIF
              IF (NEL .EQ. 1) THEN
                IF (IPR(162) .EQ. 0) THEN
                  NPRH  = 0
                  NPRV  = 0
                  NPRC  = 0
                  ISEGM = 0
                  NDOTS = 0
                ENDIF
              ENDIF
              IF (NPRH .GT. 0) THEN
                PDTHH = 180.0 / (NPRH * GL(5))
              ELSE
                PDTHH = 0.0
              ENDIF
              IF (NPRV .GT. 0) THEN
                PDTHV = 180.0 / (NPRV * GL(5))
              ELSE
                PDTHV = 0.0
              ENDIF
              IF (NPRC .GT. 0) THEN
                CDTH = 90.0 / (NPRC * GL(5))
              ELSE
                CDTH =  0.0
              ENDIF
              IF (IPR(346) .GT. 0 .OR. NEL .NE. 1 .OR.
     1           IABS(IPR(4)) .GE. 3) THEN
                IF (ISHADE .GT. 0 .AND. IPR(78) .GE. 0) THEN
                  CALL PLUT36 (K, ISHADE)
                ENDIF
              ENDIF
              IF (NDOTS .GT. 0) THEN
                NPNT = NINT(IPR(124) * RADR(NEL, 1)**2)
                IF (IPR(346) .EQ. 1 .AND. IPR(139) .EQ. 5) THEN
                  CALL GGIP (0.0, FLOAT(ICOL0), 0.0, 0)
                ENDIF
                PI    = GL(6) / 2.0
                IDUM  = -1
                DO 10 J = 1, NPNT
                  PHI  = GEN036 (IDUM) * 2 * PI
                  CHI  = SQRT(GEN036 (IDUM) * GEN036 (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)
                  IF (IPR(346) .EQ. 1 .AND. IPR(139) .EQ. 0) THEN
                    CALL GGIP (0.0, FLOAT(ICOL0), 0.0, 0)
                  ENDIF
                  NN = 1
                  CALL PLUT19 (K, NN)
   10           CONTINUE
              ENDIF
              DO 20 I = 1, 4
                PAR(70 + I) = XYZK(I)
   20         CONTINUE
              MP = MAX (NINT(PAR(125) * SQRT(PAR(74) * 10.0)), 5)
              IF (IPR(78) .EQ. 0) THEN
                IPR(91) = MP
              ELSE
                IPR(91) = MAX (NINT(GL(6) * PAR(74) * IPR(111) /
     1                    (4 * PAR(5)) + 1), 5)
              ENDIF
              PAR(55) = GL(6) / FLOAT(IPR(91) * 2)
              PAR(56) = GL(6) / FLOAT(MP * 2)
              IF (ABS(PAR(130)) + ABS(PAR(131)) .LT. 0.001) THEN
                NTRCE = 0
              ELSE
                NTRCE = - NPRC
              ENDIF
              IPR(87) = 2
              PAR(57) = 0.0
              CALL GEN074 (ZU, 0.0, 2, 15)
              IF (ISEGM .EQ. 1 .AND. NEL .GT. 1) THEN
                PAR(57) = 180.0 / GL(5)
                IPR(114) = INT(GL(6) / (3.0 * PAR(55)))
              ENDIF
   30         NTRCE = NTRCE + 1
              IF (NTRCE .GE. NPRC)  GOTO 50
              IF (IPR(346) .EQ. 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)
              IF (IPR(162) .EQ. 8 .OR. IPR(162) .EQ. 9) THEN
                ANG = ANG + 90.0
              ENDIF
              CALL GEN043 (1, A, ANG / GL(5))
              CALL GEN002 (1, A, ZU(10), ZU(4), XLNG)
              CALL GEN002 (1, A, ZU(13), ZU(7), XLNG)
              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) / GL(5))
              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 40 I = 1, 3
                PAR(70 + I) = XYZK(I) + ZU(6 + I)
   40         CONTINUE
              CALL PLUT19 (0, 0)
              GOTO 30
   50         IPR(114) = 0
              DO 60 I = 1, 4
                PAR(70 + I)  = XYZK(I)
   60         CONTINUE
              IPR(87)  = 1
   70         NPRV     = NPRV - 1
              IF (NPRV .LT. NPRVM)  GOTO 80
              IF (NPRV .EQ. 0) THEN
                IF (ABS(PAR(130)) + ABS(PAR(131)) .LT. 0.001) GOTO 80
              ENDIF
              IF (IPR(346) .EQ. 1) THEN
                CALL GGIP (0.0, FLOAT(ICOL0), 0.0, 0)
              ENDIF
              ANG    = NPRV * PDTHV - PAR(131) / GL(5)
              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) / GL(5))
              CALL GEN002 (1, A, ZU(10), ZU(4), XLNG)
              CALL GEN002 (1, A, ZU(13), ZU(7), XLNG)
              CALL GEN043 (2, A, PAR(131) / GL(5))
              CALL GEN002 (1, A, ZU(4), ZU(1), XLNG)
              CALL GEN002 (1, A, ZU(7), ZU(4), XLNG)
              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)) - GL(6) / 2.0
              CALL PLUT19 (0, 0)
              GOTO 70
   80         IPR(87) = 1
   90         NPRH = NPRH - 1
              IF (NPRH .LT. NPRHM)  GOTO 100
              IF (NPRH .EQ. 0) THEN
                IF (ABS(PAR(130)) + ABS(PAR(131)) .LT. 0.001) GOTO 100
              ENDIF
              IF (IPR(346) .EQ. 1) THEN
                CALL GGIP (0.0, FLOAT(ICOL0), 0.0, 0)
              ENDIF
              ANG = NPRH * PDTHH + PAR(130) / GL(5)
              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) / GL(5))
              CALL GEN002 (1, A, ZU(10), ZU(4), XLNG)
              CALL GEN002 (1, A, ZU(13), ZU(7), XLNG)
              CALL GEN043 (2, A, PAR(131) / GL(5))
              CALL GEN002 (1, A, ZU(4), ZU(1), XLNG)
              CALL GEN002 (1, A, ZU(7), ZU(4), XLNG)
              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)) - GL(6) / 2.0
              CALL PLUT19 (0, 0)
              GOTO 90
  100         IF (IPR(346) .GT. 0) THEN
                IF (IPR(139) .EQ. 1) THEN
                  CALL GGIP (0.0, FLOAT(ICOL0), 0.0, 0)
                ELSE
                  CALL GGIP (0.0, FLOAT(IPR(19)), 0.0, 0)
                ENDIF
              ENDIF
              DO 110 I = 1, 4
                PAR(70 + I) = XYZK(I)
  110         CONTINUE
              IPR(87) = 2
              PAR(57) = 0.0
              CALL GEN074 (ZU, 0.0, 1, 15)
              ZU(1) = 1.0
              ZU(5) = 1.0
              IPR(129) = 0
              CALL PLUT19 (0, 0)
              IF (IPR(129) .EQ. 0) THEN
                IF (K .LE. IPR(37)) THEN
                  IVL = 0
                  CALL PLUT15 (1, K, 45, IVL)
                ENDIF
              ENDIF
              MODE = 0
  120         MODE = MODE - 1
              IF (MODE + IPR(78) .LT. 0) GOTO 170
              IPOP = IPR(66) + MODE * 13
              NJ = NINT(RA(IPOP + 1))
              IF (NJ .GT. 0) GOTO 120
              NL = NINT(RA(IPOP + 2))
              DO 130 JJJ = 5, 8
                XYZK(JJJ) = RA(IPOP + JJJ - 2)
  130         CONTINUE
              DMARG  = RA(IPOP + 13)
              DMG    = 0.0
  140         RJB    = XYZK(8) + DMG
              ZU(10) = 0.0
              ZU(11) = 0.0
              ZU(12) = 1.0
              DSQ    = 0
              DO 150 M = 1, 3
                ZU(6 + M) = XYZK(M + 4) - XYZK(M)
                DSQ       = DSQ + ZU(6 + M)**2
  150         CONTINUE
              IF (NL .EQ. 0) THEN
                IF (ZU(9) .GT. 0.0)  GOTO 120
              ENDIF
              DKJ = SQRT(DSQ)
              IF (DKJ .LT. 0.0001) GOTO 120
              RKK = XYZK(4)**2
              RJK = RJB**2
              DIN = (RKK + DSQ - RJK) / (2.0 * DKJ)
              RIN = RKK - DIN**2
              IF (RIN .LT. 0.0) GOTO 120
              PAR(74) = SQRT(RIN)
              DO 160 KK = 7, 9
                ZU(KK)       = ZU(KK) / DKJ
                PAR(64 + KK) = XYZK(KK - 6) + ZU(KK) * DIN
  160         CONTINUE
              IF (ZU(9) .LT. 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) .GT. 0 .AND. NL .NE. 0) THEN
                IF (DMARG .GT. 0.0 .AND. IPR(88) .GT. 0) THEN
                  DMG   = DMARG
                  DMARG = 0.0
                  GOTO 140
                ENDIF
              ENDIF
              GOTO 120
            ENDIF
          ENDIF
  170   CONTINUE
      ENDIF
  180 IF (IPR(346) .GT. 0 .OR. IPR(477) .LT. 0)
     1        CALL GGIP (0.0, FLOAT(IPR(19)), 0.0, 0)
      RETURN
      END
      SUBROUTINE PLUT12
      PARAMETER (NP4=9,NP9=118,NP10=16,NP12=600,NP13=500,
     1 NP14=64,NP17=99,NPVD=40000000,NP22=256,NP23=18000,NP32=63,
     2 NP37=175,NP38=125,NP39=30,NP43=12)
      COMMON // MOL(2, NP23), RA(NPVD)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLUTO/ IPPR(129, 3), IBT(32), TRL(3), ROM(3, 3), R(3, 3),
     1 RP(NP14), XJX(12), XXX(12), YYY(12), TMX(3, 3), SHFT(3),
     2 XYZOR(3), XYZR(3),  ZU(15), OM(3, 3), RCG(4, NP32), TMY(3, 3),
     3 XYZPL(6), A(3, 3), XYZK(8), KRS(NP32), NCRS(9), NPRS(17)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9),
     1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10),
     2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10),
     3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770)
      COMMON /CHDAT/ CRD(NP37), LABP(16), COLR(NP10 + 1), BWCT(NP10 + 1)
      CHARACTER CRD*4, LABP*2, LFIX*1, JIN*1, J3*1, J5*1, J6*1, J7*1,
     1 COLR*10, BWCT*10, ATPR1*11, ATPR2*5, PARAM*6
      COMMON /CGGT/ IGGT
      CHARACTER IGGT*80
      CHARACTER ICH*1
      COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0
      IPR(21) = IPR(90)
      NSPEC   = IPR(41)
      NC      = IPR(52)
      NSYM    = IPR(48)
      KL      = IPR(220)
      DO 10 I = 1, 9
        K           = 2**(10 - I)
        IPR(31 - I) = IPR(21) / K
        IPR(21)     = IPR(21) - IPR(31 - I) * K
   10 CONTINUE
      IF (IPR(22) .EQ. 1 .AND. IPR(50) .EQ. 0) CALL PLA299
      IPV1  = 0
      IPV2  = 0
      IPR90 = IPR(90)
      IF (IGBL(31) .EQ. 1) KL = 2
      IF (IPR(147) .GT. 0) KL = 2
      IF (IABS(IPR90 - 6) .EQ. 2 .AND. KL .GT. 2) THEN
        CALL PLUT13 (0, -3, IPV1, XDUM)
        IF (IPR90 .EQ. 8 .AND. KL .GT. 3) THEN
          CALL PLUT13 (0, -4, IPV2, XDUM)
        ENDIF
      ENDIF
      IF (IPR(23) .NE. 0) THEN
        WRITE (LINE, 99991)
        IF (IGBL(25) * IGBL(32) .EQ. 1) THEN
          CALL GGIP (HORS, VERT, 0.0, 1)
          VRT = VERT - 0.4
          CALL GGIP20 (0.0, LINE, 80, 0.35, 5 + IGBL(68), 2, 1.0, VRT)
          VRT = VRT - 0.4
        ELSE
          WRITE (LU6, '(//, A, /)') LINE
        ENDIF
        IF (IPV1 .GT. 0) THEN
          I1 = IPV1
          I2 = IPV1
        ELSE
          IF (IGBL(31) .EQ. 0) THEN
            IF (IPR(46) .EQ. 0) THEN
              I1 = IPR(69) + 1
            ELSE
              I1 = 1
            ENDIF
          ELSE
            I1 = IPR(38) + 1
          ENDIF
          I2 = IPR(37)
        ENDIF
        DO 20 I = I1, I2
          CALL PLUT15 (-6, I, 5, NRES)
          IF (IPR(147) .GT. 0) THEN
            IF (IPR(147) .NE. NRES) GOTO 20
          ENDIF
          CALL PLUT25 (1, I, J4)
          IAIO = - J4
          IF (IPV1 .LT. 0 .AND. IAIO .NE. IPV1)  GOTO 20
          CALL PLUT15 (-1, I, 46, JDOAC)
          CALL PLUT15 (-1, I, 32, IDH)
          IF (JDOAC .EQ. 0 .AND. IDH .EQ. 0) THEN
            J6 = ' '
            J7 = ' '
          ELSE
            J6 = 'D'
            IF (IDH .EQ. 1) THEN
              J7 = 'H'
            ELSE
              J7 = 'A'
            ENDIF
          ENDIF
          NEL = INT(RA(I * NP43 + 7) / 32000) + 1
          CALL PLUT15 (-6, I, 18, JINC)
          CALL PLUT15 (-1, I, 27, J1)
          IF (J1 .GT. 0) THEN
            JIN = '*'
          ELSE
            JIN  = ' '
          ENDIF
          IF (JINC .GE.  2) THEN
            J3 = 'S'
          ELSE
            J3 = ' '
          ENDIF
          CALL PLUT15 (-4, I, 37, ILB)
          J2   = ILB + 1
          CALL PLUT15 (-1, I, 42, JF)
          IF (JF .EQ. 1) THEN
            LFIX = '*'
          ELSE
            LFIX = '-'
          ENDIF
          CALL PLUT15 (-1, I, 43, IMV)
          IF (IMV .GT. 0) THEN
            J5 = 'M'
          ELSE
            J5 = ' '
          ENDIF
          XTRF = RA(I * NP43 + 12)
          IF (I .LE. IPR(69)) THEN
            NQ1(1:1) = 'O'
            IF (I .EQ. 1) THEN
              NQ1(2:2) = 'R'
            ELSE IF (I .EQ. 2) THEN
              NQ1(2:2) = 'C'
            ELSE IF (I .EQ. 3) THEN
              NQ1(2:2) = 'B'
            ELSE IF (I .EQ. 5) THEN
              NQ1(2:2) = 'A'
            ELSE
              NQ1(1:2) = '  '
            ENDIF
            WRITE (LINE, 99981) NQ1(1:2),
     1      (RA(I * NP43 + K), K = 1, 3), JIN, LABP(J2), LFIX
          ELSE
            IF (JINC .NE. 0) THEN
              MULT = NSYM / JINC
            ELSE
              MULT = NSYM
            ENDIF
            WRITE (LINE, 99990) NQ1, (RA(I * NP43 + K), K = 1, 3),
     1        (RADR(J4, 5 - K), K = 1, 4), MULT, J3, JIN, XTRF,
     2        J5, LABP(J2), LFIX, NRES, NEL, J6, J7
          ENDIF
          IF (IGBL(25) * IGBL(32) .EQ. 1) THEN
            IF (VRT - 0.4 .LT. 0) THEN
              CALL PLA013 (1, 1)
              ICH = IGGT(1:1)
              CALL GGIP (HORS, VERT, 0.0, 1)
              IF (ICH .NE. 'Y' .AND. ICH .NE. '!') GOTO 25
                VRT = VERT
            ENDIF
            VRT = VRT - 0.4
            CALL GGIP20 (0.0, LINE, 80, 0.35, 1, 2, 1.0, VRT)
          ELSE
            WRITE (LU6, 99993) LINE
          ENDIF
   20   CONTINUE
        GOTO 90
      ENDIF
   25 IF (IPR(24) .NE. 0) THEN
        IF (NC .GT. IPR(68)) THEN
          WRITE (LINE, 99989)
          IF (IGBL(25) * IGBL(32) .EQ. 1) THEN
            CALL GGIP (HORS, VERT, 0.0, 1)
            VRT = VERT - 0.4
            CALL GGIP20 (0.0, LINE, 80, 0.35, 5 + IGBL(68), 2,
     1                   1.0, VRT)
            VRT = VRT - 0.4
          ELSE
            WRITE (LU6, '(//, A, /)') LINE
          ENDIF
          NRBO = 0
          IF (IPV1 .GT. 0) THEN
            I1 = IPV1
            I2 = IPV1
          ELSE
            IF (IPR(46) .EQ. 0) THEN
              I1 = IPR(69) + 1
            ELSE
              I1 = 1
            ENDIF
            I2 = IPR(39)
          ENDIF
          DO 40 I0 = I1, I2
            IF (IPV1 .LT. 0) THEN
              I4 = INT(RA(I0 * NP43 + 7) / 32000)
              IF (IPV1 + I4 + 1 .NE. 0)  GOTO 40
            ENDIF
            IF (IPR(147) .GT. 0) THEN
              CALL PLUT15 (-6, I0, 5, NRES)
              IF (IPR(147) .NE. NRES) GOTO 40
            ENDIF
            IF (IPV2 .GT. 0) THEN
              J1 = IPV2
              J2 = IPV2
            ELSE
              IF (IGBL(31) .EQ. 0) THEN
                IF (IPV2 .EQ. 0) THEN
                  J1 = I0 + 1
                ELSE
                  J1 = 1
                ENDIF
              ELSE
                J1 = IPR(38) + 1
              ENDIF
              J2 = IPR(37)
            ENDIF
            DO 30 J0 = J1, J2
              IF (IPV2 .LT. 0) THEN
                J4 = INT(RA(J0 * NP43 + 7) / 32000)
                IF (IPV2 + J4 + 1 .NE. 0)  GOTO 30
              ENDIF
              CALL PLUT16 (-4, K, I0, J0, DUM1, IDUM2)
              IF (K .GT. IPR(68)) THEN
                CALL PLUT16 (0, K, I, J, RBO, NLI)
                IF (NLI .LT. 0) THEN
                  NLI   = IABS(NLI)
                  IDASH = 1
                ELSE
                  IDASH = 0
                ENDIF
                IF (I .NE. 0) THEN
                  CALL PLUT25 (1, I, IDUM)
                  CALL PLUT25 (2, J, IDUM)
                  CALL PLUT15 (-6, I, 5, NRI)
                  CALL PLUT15 (-6, J, 11, NS2)
                  ARU = MOL(1, NS2 + 1) / PAR(42)
                  CALL PLUT22 (I, J, D)
                  NRBO = NRBO + 1
                  WRITE (LINE, 99988) NRBO, NRI, NQ1, NQ2,
     1                                   ARU, D, RBO, NLI, IDASH
                  IF (IGBL(25) * IGBL(32) .EQ. 1) THEN
                    IF (VRT - 0.4 .LT. 0) THEN
                      CALL PLA013 (1, 1)
                      ICH = IGGT(1:1)
                      CALL GGIP (HORS, VERT, 0.0, 1)
                      IF (ICH .NE. 'Y' .AND. ICH .NE. '!') GOTO 45
                      VRT = VERT
                    ENDIF
                    VRT = VRT - 0.4
                    CALL GGIP20 (0.0, LINE, 80, 0.35, 1, 2, 1.0, VRT)
                  ELSE
                    WRITE (LU6, 99993) LINE
                  ENDIF
                ENDIF
              ENDIF
   30       CONTINUE
   40     CONTINUE
        ENDIF
        GOTO 90
      ENDIF
   45 IF (IPR(25) .NE. 0) THEN
        IF (IPR(12) .LT. 0) THEN
          IDASH = 1
        ELSE
          IDASH = 0
        ENDIF
        WRITE (LINE, 99987)
        IF (IGBL(25) * IGBL(32) .EQ. 1) THEN
          CALL GGIP (HORS, VERT, 0.0, 1)
          VRT = VERT - 1.5
          CALL GGIP20 (0.0, LINE, 80, 0.35, 5 + IGBL(68), 2, 1.0, VRT)
          VRT = VRT - 0.8
        ELSE
          WRITE (LU6, 99992) LINE
        ENDIF
        WRITE (LINE, 99986) PAR(38), IABS(IPR(12)), IDASH
        IF (IGBL(25) * IGBL(32) .EQ. 1) THEN
          VRT = VRT - 0.6
          CALL GGIP20 (0.0, LINE, 80, 0.35, 1, 2, 1.0, VRT)
        ELSE
          WRITE (LU6, 99993) LINE
        ENDIF
        DO 50 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 .LT. 0) THEN
            IDASH = 1
          ELSE
            IDASH = 0
          ENDIF
          IF (N1 .LT. 0) THEN
            WRITE (LINE, 99985) RB, I, IDASH
            IF (IGBL(25) * IGBL(32) .EQ. 1) THEN
              VRT = VRT - 0.6
              CALL GGIP20 (0.0, LINE, 80, 0.35, 1, 2, 1.0, VRT)
            ELSE
              WRITE (LU6, 99993) LINE
            ENDIF
          ELSE IF (N1 .EQ. 0) THEN
            N2 = NINT(RA(NRF - 1))
            IF (N2 .LE. 0) THEN
              N2 = IEL(IEN( - N2))
              N1 = N2 / 100 + ICHAR('A') - 1
              N2 = MOD(N2, 100)
              IF (N2 .EQ. 0) THEN
                N2 = ICHAR(' ')
              ELSE
                N2 = N2 + ICHAR('a') - 1
              ENDIF
              NQ1 = CHAR(N1)//CHAR(N2)//'     '
            ELSE
              CALL PLUT25 (1, N2, IATK)
            ENDIF
            WRITE (LINE, 99983) NQ1, RB, I, IDASH
            IF (IGBL(25) * IGBL(32) .EQ. 1) THEN
              VRT = VRT - 0.6
              CALL GGIP20 (0.0, LINE, 80, 0.35, 1, 2, 1.0, VRT)
            ELSE
              WRITE (LU6, 99993) LINE
            ENDIF
          ELSE
            CALL PLUT25 (1, N1, IATK)
            CALL PLUT25 (2, N2, IATK)
            WRITE (LINE, 99982) NQ1, NQ2, RB, I, IDASH
            IF (IGBL(25) * IGBL(32) .EQ. 1) THEN
              VRT = VRT - 0.6
              CALL GGIP20 (0.0, LINE, 80, 0.35, 1, 2, 1.0, VRT)
            ELSE
              WRITE (LU6, 99993) LINE
            ENDIF
          ENDIF
   50   CONTINUE
        WRITE (LINE, 99980)
        IF (IGBL(25) * IGBL(32) .EQ. 1) THEN
          VRT = VRT - 1.0
          CALL GGIP20 (0.0, LINE, 80, 0.35, 1, 2, 1.0, VRT)
        ELSE
          WRITE (LU6, '(/, A)') LINE
        ENDIF
        GOTO 90
      ENDIF
      IF (IPR(26) .NE. 0) THEN
        IF (IGBL(25) * IGBL(32) .EQ. 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)
  110     READ (LU61, '(A)', END = 120) LINE
          VRT = VRT - 0.5
          CALL GGIP20 (0.0, LINE, 80, 0.35, 1, 2, 1.0, VRT)
          GOTO 110
  120     CLOSE (LU61, STATUS = 'DELETE')
          GOTO 90
        ELSE
          CALL PLUT17 (0.0, 1004, MADDR, LU6)
        ENDIF
      ENDIF
      IF (IPR(27) .NE. 0) THEN
        CALL GEN096 (R, IROTX, IROTY, IROTZ, IDET, XYZOR, PHI, ROM)
        WRITE (LU6, 99997) IROTX, IROTY, IROTZ, IDET,
     1    ((R(I, J), J = 1, 3), I = 1, 3)
      ENDIF
      IF (IPR(28) .NE. 0) THEN
        WRITE (LU6, 99996) IPR(39), IPR(38), IPR(37), IPR(53),
     1   IPR(52), IPR(75), IPR(42), IPR(43)
        WRITE (LU6, 99995) IPR(46), IPR(116), NINT(PAR(48)), IPR(4),
     1   IPR(9), IGBL(67), IGBL(75), IPR(77), IPR(346), IPR(19),
     2   IPR(63)
        WRITE (LU6, 99994) PAR(24), PAR(15), VERT,
     1   PAR(48), PAR(13), PAR(36), PAR(39), PAR(5), PAR(3), PAR(44),
     2   PAR(41), PAR(49)
      ENDIF
      IF (IPR(29) .NE. 0) THEN
        WRITE (LINE, 99999)
        IF (IGBL(25) * IGBL(32) .EQ. 1) THEN
          CALL GGIP (HORS, VERT, 1.0, 1)
          VRT = VERT - 0.8
          CALL GGIP20 (0.0, LINE, 80, 0.35, 5 + IGBL(68), 2, 1.0, VRT)
          VRT = VRT - 0.3
        ELSE
          WRITE (LU6, 99992) LINE
        ENDIF
        WRITE (LINE, 99977)
        IF (IGBL(25) * IGBL(32) .EQ. 1) THEN
          VRT = VRT - 0.4
          CALL GGIP20 (0.0, LINE, 80, 0.35, 1, 2, 1.0, VRT)
        ELSE
          WRITE (LU6, 99993) LINE
        ENDIF
        WRITE (LINE, 99976)
        IF (IGBL(25) * IGBL(32) .EQ. 1) THEN
          VRT = VRT - 0.8
          CALL GGIP20 (0.0, LINE, 80, 0.35, 6, 2, 1.0, VRT)
        ELSE
          WRITE (LU6, '(/, A)') LINE
        ENDIF
        WRITE (LINE, 99975)
        IF (IGBL(25) * IGBL(32) .EQ. 1) THEN
          VRT = VRT - 0.8
          CALL GGIP20 (0.0, LINE, 80, 0.35, 1, 2, 1.0, VRT)
        ELSE
          WRITE (LU6, '(/, A)') LINE
        ENDIF
        WRITE (LINE, 99974)
        IF (IGBL(25) * IGBL(32) .EQ. 1) THEN
          VRT = VRT - 0.8
          CALL GGIP20 (0.0, LINE, 80, 0.35, 6, 2, 1.0, VRT)
        ELSE
          WRITE (LU6, '(/, A)') LINE
        ENDIF
        WRITE (LINE, 99973)
        IF (IGBL(25) * IGBL(32) .EQ. 1) THEN
          VRT = VRT - 0.8
          CALL GGIP20 (0.0, LINE, 80, 0.35, 1, 2, 1.0, VRT)
        ELSE
          WRITE (LU6, 99992) LINE
        ENDIF
        WRITE (LINE, 99972)
        IF (IGBL(25) * IGBL(32) .EQ. 1) THEN
          VRT = VRT - 0.6
          CALL GGIP20 (0.0, LINE, 80, 0.35, 1, 2, 1.0, VRT)
        ELSE
          WRITE (LU6, 99993) LINE
        ENDIF
        WRITE (LINE, 99971) PAR(1)
        IF (IGBL(25) * IGBL(32) .EQ. 1) THEN
          VRT = VRT - 1.0
          CALL GGIP20 (0.0, LINE, 80, 0.35, 5 + IGBL(68), 2, 1.0, VRT)
          VRT = VRT - 0.2
        ELSE
          WRITE (LU6, 99992) LINE
        ENDIF
        DO 70 I = 1, IAN
          N2 = IEL(IEN(I))
          N1 = N2 / 100 + ICHAR('A') - 1
          N2 = MOD(N2, 100)
          IF (N2 .EQ. 0) THEN
            N2 = ICHAR(' ')
          ELSE
            N2 = N2 + ICHAR('a') - 1
          ENDIF
          N3 = IATPR(IEN(I))
          ATPR1 = '           '
          IF (N3 .LE. 0) THEN
            N3 = - N3
            ATPR2 = '     '
          ELSE
            ATPR2 = 'Metal'
          ENDIF
          IF (N3 .EQ. 2) THEN
            ATPR1 = 'Lanthanide '
          ELSE IF (N3 .EQ. 3) THEN
            ATPR1 = 'Actinide   '
          ELSE IF (N3 .EQ. 4) THEN
            ATPR1 = 'Transition '
          ELSE IF (N3 .EQ. 5) THEN
            ATPR1 = 'Alkali     '
          ELSE IF (N3 .EQ. 6) THEN
            ATPR1 = 'AlkaliEarth'
          ELSE IF (N3 .EQ. 7) THEN
            ATPR1 = 'Halogen    '
          ENDIF
          PARAM = '      '
          IF (BWCT(IBCL(I))(1:3)  .EQ. 'NET') THEN
            WRITE (PARAM, 99984) IPR(85), IPR(86)
          ELSE IF (BWCT(IBCL(I))(1:3) .EQ. 'GLO') THEN
            WRITE (PARAM, 99984) IPR(112), IPR(132)
          ENDIF
          WRITE (LINE, 99998) CHAR(N1), CHAR(N2), COLR(IACL(I)),
     1      BWCT(IBCL(I)), PARAM, (RADR(I, 5 - J), J = 1, 4),
     2      ATPR1, ATPR2
          IF (IGBL(25) * IGBL(32) .EQ. 1) THEN
            VRT = VRT - 0.6
            CALL GGIP20 (0.0, LINE, 80, 0.35, 1, 2, 1.0, VRT)
          ELSE
            WRITE (LU6, 99993) LINE
          ENDIF
   70   CONTINUE
        GOTO 90
      ENDIF
      IF (IPR(30) .EQ. 1) THEN
        WRITE (LINE, 99978)
        IF (IGBL(25) * IGBL(32) .EQ. 1) THEN
          CALL GGIP (HORS, VERT, 0.0, 1)
          VRT = VERT - 0.8
          CALL GGIP20 (0.0, LINE, 80, 0.35, 5 + IGBL(68), 2, 1.0, VRT)
          VRT = VRT - 0.3
        ELSE
          WRITE (LU6, 99992) LINE
        ENDIF
        DO 80 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) NQ1, N1, N2, N3, N6, N16, N10,
     1     N11, N12, N13, N14, N15, N5, N4, N7, N8, N9
          IF (IGBL(25) * IGBL(32) .EQ. 1) THEN
            IF (VRT - 0.4 .LT. 0) THEN
              CALL PLA013 (1, 1)
              ICH = IGGT(1:1)
              CALL GGIP (HORS, VERT, 0.0, 1)
              IF (ICH .NE. 'Y' .AND. ICH .NE. '!') GOTO 45
              VRT = VERT
            ENDIF
            VRT = VRT - 0.4
            CALL GGIP20 (0.0, LINE, 80, 0.35, 1, 2, 1.0, VRT)
          ELSE
            WRITE (LU6, 99993) LINE
          ENDIF
   80   CONTINUE
        GOTO 90
      ENDIF
      GOTO 100
   90 IF (IGBL(25) * IGBL(32) .EQ. 1) CALL PLA297 (1)
  100 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/'TIMING-PLOT', F8.2,
     5 ' TIME-TOTAL ', 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    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)')
      END
      SUBROUTINE PLUT13 (MODE, KK, IAT, XMOL)
      PARAMETER (NP4=9,NP9=118,NP10=16,NP12=600,NP13=500,NP17=99,
     1 NPVD=40000000,NP22=256,NP23=18000,NP38=125,NP39=30,NP45=2048)
      COMMON // MOL(2, NP23), RA(NPVD)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /Q/ ICL, IFL(NP17)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      CHARACTER ICH*1
      NQ1 = IFL(IABS(KK))
      XMOL = 0.0
      IF (NQ1(1:3) .EQ. 'REN') THEN
        IAT  = 0
        WRITE (LU6, 99999) NQ1
        GOTO 60
      ENDIF
      N = INDEX(NQ1, '_')
      IF (N .NE. 0) THEN
        ICH = NQ1(N+1:N+1)
        DO 10 I = 1, 10
          IF (ICH .EQ. CHAR(ICHAR('0') + I - 1)) THEN
            N = 0
            GOTO 30
          ENDIF
   10   CONTINUE
      ENDIF
   30 CALL PLA046 (8, NQ1, NE1, NA1, NAX1, NS1, XPK1, XPK2, NIEN)
      IF (NE1 .EQ. 0) THEN
        IAT = 0
      ELSE IF (NE1 .LT. NP9 - 3) THEN
        IF (KK .LT. 0) THEN
          IF (NA1 .LT. 0) THEN
            IAT = - NE1
            GOTO 50
          ENDIF
        ENDIF
        DO 40 IAT = IPR(69) + 1, IPR(37)
           CALL PLUT25 (2, IAT, IATK)
           CALL PLA046 (8, NQ2, NE2, NA2, NAX2, NS2, XPK1, XPK2, NIEN)
           IF (NE1 .EQ. NE2) THEN
             IF (NA1 .EQ. NA2 .OR. (NA1 .EQ. 0 .AND. NA2 .EQ. -1)) THEN
               IF (NAX1 .EQ. NAX2) THEN
                 IF (MODE .LT. 0) THEN
                   IF (NS1 .GT. 0) XMOL =
     1                  MOL(1, NS1 + IPR(75)) / PAR(42)
                   GOTO 50
                 ELSE
                   IF (NS1 .EQ. NS2) GOTO 50
                 ENDIF
               ENDIF
             ENDIF
           ENDIF
   40   CONTINUE
        IF (NA1 .GT. 0) THEN
          IAT = 0
          GOTO 50
        ENDIF
        IAT = - NE1
      ELSE IF (NE1 .EQ. NP9 - 3) THEN
        IAT = 1
      ELSE IF (NE1 .EQ. NP9 - 2) THEN
        IAT = 5
      ELSE IF (NE1 .EQ. NP9 - 1) THEN
        IAT = 3
      ELSE IF (NE1 .EQ. NP9) THEN
        IAT = 2
      ELSE
        IAT = 0
      ENDIF
   50 IF (MODE .LE. 0 .AND. IAT .EQ. 0 .AND. KK .GT. 0) THEN
        WRITE (LU6, 99999) NQ1
      ENDIF
   60 RETURN
99999 FORMAT (':: ATOM Name/Type ERROR for: ', A)
      END
      SUBROUTINE PLUT14 (MODE, J, IASU, NPROP, X, Y, Z, S)
      PARAMETER (NP0=6,NP12=600,NP13=500,NP17=99,NPVD=40000000,
     1 NP23=18000,NP38=125,NP39=30)
      COMMON // MOL(2, NP23), RA(NPVD)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      I = J * NP0 + IPR(158)
      IF (MODE .LT. 0) THEN
        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
        IF (MODE .EQ. 0) THEN
          IPR(67) = IPR(67) + 1
          J       = IPR(40) + IPR(67)
          I       = J * NP0 + IPR(158)
          IF (I .GE. IPR(66) - IPR(78) * 13) THEN
            IPR(101) = IPR(101) + 1
            J        = 0
            IPR(67)  = IPR(67) - 1
            RETURN
          ENDIF
        ENDIF
        RA(I - 5) = IASU
        RA(I - 4) = NPROP
        RA(I - 3) = X
        RA(I - 2) = Y
        RA(I - 1) = Z
        RA(I)     = S
      ENDIF
      RETURN
      END
      SUBROUTINE PLUT15 (IKEY, IAT, IBITN, IVL)
      PARAMETER (NP14=64,NPVD=40000000,NP23=18000,NP32=63,NP43=12)
      COMMON // MOL(2, NP23), RA(NPVD)
      COMMON /PLUTO/ IPPR(129, 3), IBT(32), TRL(3), ROM(3, 3), R(3, 3),
     1 RP(NP14), XJX(12), XXX(12), YYY(12), TMX(3, 3), SHFT(3),
     2 XYZOR(3), XYZR(3),  ZU(15), OM(3, 3), RCG(4, NP32), TMY(3, 3),
     3 XYZPL(6), A(3, 3), XYZK(8), KRS(NP32), NCRS(9), NPRS(17)
      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 .LT. 0) THEN
        IVL = INH
      ELSE
        RA(IX) = IFLI + (IVL - INH) * IBIT
      ENDIF
      RETURN
      END
      SUBROUTINE PLUT16 (MODE, IAJAT, IAT, JAT, RBO, NLI)
      PARAMETER (NP0=6,NP9=118,NP10=16,NP12=600,NP13=500,NP14=64,
     1 NP17=99,NPVD=40000000,NP23=18000,NP32=63,NP33=15,NP38=125,
     2 NP39=30,NP43=12)
      COMMON // MOL(2, NP23), RA(NPVD)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLUTO/ IPPR(129, 3), IBT(32), TRL(3), ROM(3, 3), R(3, 3),
     1 RP(NP14), XJX(12), XXX(12), YYY(12), TMX(3, 3), SHFT(3),
     2 XYZOR(3), XYZR(3),  ZU(15), OM(3, 3), RCG(4, NP32), TMY(3, 3),
     3 XYZPL(6), A(3, 3), XYZK(8), KRS(NP32), NCRS(9), NPRS(17)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9),
     1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10),
     2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10),
     3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770)
      RA12  = 0.0
      MD    = MODE
      ILPB  = IPR(69) + 1
      NAB   = IPR(37) - IPR(69)
      IPR58 = IPR(158)
      NSK   = 0
      IF (MD .GT. 0) THEN
        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 + IPR58
        J        = JAT * NP0 + IPR58
        IF (IPR(477) .EQ. 1) THEN
          IPR(120)  = MAX (NINT(RA(I - 4)), NINT(RA(J - 4)))
        ENDIF
        ISTK     = IPR58 + (IPR(40) + IPR(67)) * NP0
        IPR(67)  = IPR(67) + 2
        IF (NLN .LT. 0) NLI = - NLI
        IF (RBO .LT. 0.0) RBO = ABS(RBO)
        IF (ISTK + 2 * NP0 .GE. IPR(66) - IPR(78) * 13)
     1    CALL PLUT38 (3, 1, LU6)
        DK = 0
        DO 10 K = 1, 3
          ZU(K + 6) = RA(J + K - 4) - RA(I + K - 4)
          DK        = DK + ZU(K + 6)**2
   10   CONTINUE
        IF (DK .NE. 0.0) THEN
          DXYZ = SQRT(DK)
        ELSE
          DXYZ = 1.0
        ENDIF
        RI   = AMOD(ABS(RA(I)), 1000.0)
        RJ   = AMOD(ABS(RA(J)), 1000.0)
        RB   = RBO * PAR(24)
        RA4  = RB
        RA8  = RB
        IF (PAR(48) .EQ. 0.0) THEN
          IF (PAR(44) .NE. 0.0 .AND. IPR(4) .NE. 4) THEN
            RB9 = RB * ABS(PAR(44) * ZU(9) / DXYZ)
            RA4 = RB + RB9
            RA8 = RB - RB9
          ENDIF
        ELSE
          RA4 = RB * PAR(48) / (PAR(48) - RA(I - 1))
          RA8 = RB * PAR(48) / (PAR(48) - RA(J - 1))
        ENDIF
        RA4 = MAX (MIN (RA4, RI - 0.001), 0.0)
        RA8 = MAX (MIN (RA8, RJ - 0.001), 0.0)
        IF (IPR(4) .GT. 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
        ENDIF
        DO 20 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)
   20   CONTINUE
        RA(ISTK + NP0)     = RA4 + AL * RA12
        RA(ISTK + 2 * NP0) = RA8 - BE * RA12
        DO 30 K = 7, 9
          ZU(K) = ZU(K) / DXYZ
   30   CONTINUE
      ELSE IF (MD .LT. 0) THEN
        IF (MD .EQ. -6) THEN
          IADR    = IPR(79)
          IPR(97) = 0
          NML     = IPR(142)
          NC      = IPR(52)
          NCU     = IPR(53)
          DISK    = PAR(35)**2
          IF (IPR(46) .GT. 0) THEN
            IBNB = 1
          ELSE
            IBNB = IPR(68) + 1
          ENDIF
          IF (NC .GE. IBNB) THEN
            DO 50 IBN = IBNB, NC
              ICMD = NINT(RA(IPR(64) + 1 - IBN * 2))
              IF (ICMD .GT. 0) THEN
                IAT    = ICMD
                JAT    = NINT(RA(IPR(64) + 2 - IBN * 2))
                NRINCL = 2
                IF (IAT .GE. ILPB) THEN
                  ITYPE = INT(RA(IAT * NP43 + 7) / 32000) + 1
                  IF (IAT .LE. IPR(39)) THEN
                    CALL PLUT15 (-1, IAT, 27, NINCL)
                    NRINCL = NRINCL - 1 + NINCL
                  ENDIF
                  IENITP = IEN(ITYPE)
                ELSE
                  ITYPE  = 0
                  IENITP = 0
                ENDIF
                IF (JAT .GE. ILPB) THEN
                  JTYPE = INT(RA(JAT * NP43 + 7) / 32000) + 1
                  IF (JAT .LE. IPR(39)) THEN
                    CALL PLUT15 (-1, JAT, 27, NINCL)
                    NRINCL = NRINCL - 1 + NINCL
                  ENDIF
                  IENJTP = IEN(JTYPE)
                ELSE
                  JTYPE  = 0
                  IENJTP = 0
                ENDIF
                IF (NRINCL .GE. IPR(165)) THEN
                  CALL PLUT15 (-6, IAT, 11, IARU)
                  CALL PLUT15 (-6, JAT, 11, JARU)
                  CALL PLUT27 (IBN, IAT, JAT, RBO, NLI)
                  IF (IBN .GT. IPR(68)) THEN
                    MNML = NML
                  ELSE
                    MNML = 1
                  ENDIF
                  IAT0 = IAT - NAB
                  JAT0 = JAT - NAB
                  DO 40 ML = 1, MNML
                    IAT0 = IAT0 + NAB
                    JAT0 = JAT0 + NAB
                    IF (IBN .GT. NCU) THEN
                      NRJT = 2
                    ELSE
                      NRJT = 3 - IPR(165)
                    ENDIF
                    I   = IAT0 * NP0 + IPR(158)
                    J   = JAT0 * NP0 + IPR(158)
                    NSK = 2
                    RAI = ABS(RA(I))
                    IF (RAI .GT. 999.9) THEN
                      NSK = NSK - 1
                      RAI = RAI - 1000.0
                    ENDIF
                    RAJ = ABS(RA(J))
                    IF (RAJ .GT. 999.9) THEN
                      NSK = NSK - 1
                      RAJ = RAJ - 1000.0
                    ENDIF
                    IF (NSK .LT. 2) THEN
                      IF (IPR(15) .LT. 0) THEN
                        NSK = 0
                      ELSE
                        NSK = 2
                      ENDIF
                    ENDIF
                    IF (NSK .GT. 0) THEN
                      IF (ITYPE .NE. 0 .AND. JTYPE .NE. 0) THEN
                        IF (IENITP .NE. 106 .AND.
     1                      IENJTP .NE. 106) THEN
                          IF (IARU .NE. JARU) NRJT = 1
                        ELSE
                          NRJT = 2
                        ENDIF
                      ENDIF
                      IF (ITYPE .NE. 0 .AND. JTYPE .NE. 0)THEN
                        IF (RA(I) .LT. 0.0) NRJT = NRJT - 1
                        IF (RA(J) .LT. 0.0) NRJT = NRJT - 1
                      ENDIF
                      IF (NRJT .GT. 0) THEN
                        IF (NLI .NE. 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
                          IF (DZ .LT. 0.0) THEN
                            CALL GEN014 (IAT0, JAT0)
                            CALL GEN014 (ITYPE, JTYPE)
                          ENDIF
                          IF (IPR(4) .GT. 0) DK = DK - RAI**2 - RAJ**2
                          IF (DK .GT. 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
                          ENDIF
                        ENDIF
                      ENDIF
                    ENDIF
   40             CONTINUE
                ENDIF
              ENDIF
   50       CONTINUE
          ENDIF
        ELSE IF (MD .EQ. -2) THEN
          DO 70 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
   70     CONTINUE
          IPR(68) = 12
          IPR(52) = IPR(68)
          IPR(53) = IPR(68)
        ELSE
          IAT0 = IAT
          JAT0 = JAT
          IF (MD .EQ. -5) THEN
            JAT0 = MOD(JAT - ILPB, NAB) + ILPB
            IAT0 = MOD(IAT - ILPB, NAB) + ILPB
          ENDIF
          IF (JAT0 .NE. IAT0) THEN
            IF (JAT0 .LT. IAT0) CALL GEN014 (IAT0, JAT0)
            IF (MD .EQ. -3) THEN
              MDD = -1
            ELSE
              MDD = 1
            ENDIF
            IJAT = IAT0 * MDD
            NC    = IPR(52)
            NC0   = IPR(68) + 1
            IF (NC .GE. NC0) THEN
              DO 80 I = NC0, NC
                ICI = NINT(ABS(RA(IPR(64) + 1 - I * 2)))
                JCI = NINT(RA(IPR(64) + 2 - I * 2))
                IF (ICI .EQ. IABS(IJAT) .AND. JCI .EQ. JAT0)  GOTO 90
   80         CONTINUE
            ENDIF
            I = -1
            IF (MD .EQ. -1) THEN
              IPR(52) = IPR(52) + 1
              IF (((IPR(37) + 1) * NP43) .GT. (IPR(64) - IPR(52) * 2))
     1          CALL PLUT38 (3, 1, LU6)
              I   = IPR(52)
              IM2 = I * 2
              IF (IPR(35) .GE. 0) THEN
                IF (JAT0 .LE. IPR(38)) THEN
                  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)
                ENDIF
                CALL PLUT15 (-4, IAT, 33, IVAL)
                IF (IVAL .LT. NP33) THEN
                  IVAL = IVAL + 1
                  CALL PLUT15 (4, IAT, 33, IVAL)
                ENDIF
                CALL PLUT15 (-4, JAT, 33, IVAL)
                IF (IVAL .LT. NP33) THEN
                  IVAL = IVAL + 1
                  CALL PLUT15 (4, JAT, 33, IVAL)
                ENDIF
              ENDIF
            ELSE
              GOTO 100
            ENDIF
   90       IF (IABS(MD + 2) .EQ. 1) THEN
              RA(IPR(64) + 1 - I * 2) = IAT0 * MDD
              RA(IPR(64) + 2 - I * 2) = JAT0
            ENDIF
  100       IAJAT = I
          ELSE
            IAJAT = -1
          ENDIF
        ENDIF
      ELSE IF (MD .EQ. 0) THEN
        ICMD = NINT(RA(IPR(64) + 1 - IAJAT * 2))
        IF (ICMD .LT. 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 .EQ. 0) THEN
            IAT = 0
            JAT = 0
          ENDIF
        ENDIF
      ENDIF
      RETURN
      END
      SUBROUTINE PLUT17 (XMOLE, MODE, MADDR, LUNIT)
      PARAMETER (NP10=16,NP12=600,NP13=500,NP14=64,NP17=99,
     1 NPVD=40000000,NP23=18000,NP32=63,NP37=175,NP38=125,NP39=30,
     2 NP45=2048)
      COMMON // MOL(2, NP23), RA(NPVD)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLUTO/ IPPR(129, 3), IBT(32), TRL(3), ROM(3, 3), R(3, 3),
     1 RP(NP14), XJX(12), XXX(12), YYY(12), TMX(3, 3), SHFT(3),
     2 XYZOR(3), XYZR(3),  ZU(15), OM(3, 3), RCG(4, NP32), TMY(3, 3),
     3 XYZPL(6), A(3, 3), XYZK(8), KRS(NP32), NCRS(9), NPRS(17)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /Q/ ICL, IFL(NP17)
      CHARACTER ICL*(NP45), IFL*7
      COMMON /CHDAT/ CRD(NP37), LABP(16), COLR(NP10 + 1), BWCT(NP10 + 1)
      CHARACTER CRD*4, LABP*2, BWCT*10,
     1          COLR*10
      CHARACTER N1*3, ARU1*10, ARU2*10, ARU3*10
      KL    = IPR(220)
      NSYM  = IPR(48)
      NRES  = IPR(75)
      NMOL  = IPR(42)
      MADDR = 0
      IF (IABS(MODE) .LE. 1000) THEN
        IPR(130) = 0
        IF (MODE .GT. 0) THEN
          NMA = MODE / 32
          NMA = NMA * 5 + 1
          NMB = MOD(MODE, 32)
        ENDIF
        XML = XMOLE
        IF (XML .EQ. 0.0) THEN
          IF (NMOL .GT. 0) THEN
            DO 10 I = 1, NMOL
              IF (MOL(1, I) .GT. 0.0) THEN
                GOTO 150
              ENDIF
   10       CONTINUE
          ENDIF
          XML = 1555.00
        ENDIF
        MXL = INT(ABS(XML))
        IF (MXL .LE. NRES) THEN
          IF (NMOL .GT. 0) THEN
            DO 15 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 .EQ. NR2) THEN
                MOL(1, L) = NINT(SIGN(XMOLL, XML) * PAR(42))
              ENDIF
   15       CONTINUE
          ENDIF
          IF (MODE .GT. 0) THEN
            IF (NMA .EQ. 1) THEN
              NCRS(NINT(XML)) = NMB
            ELSE
              NPRS(NINT(XML)) = NMB
            ENDIF
          ENDIF
          GOTO 150
        ELSE IF (MXL .LT. 100) THEN
          WRITE (LUNIT, 99992)
          GOTO 150
        ENDIF
        MPM = NINT (XML * PAR(42))
        CALL GEN098 (MPM, PAR(42), NSLM, ITX, ITY, ITZ, NR)
        IF (NSLM .GT. NSYM .OR. NSLM .EQ. 0) THEN
          WRITE (LUNIT, 99999) XML, NSLM
          GOTO 150
        ENDIF
        XXX(4) = ITX
        XXX(5) = ITY
        XXX(6) = ITZ
        IF (NR .GT. 0) THEN
          IF (NR .GT. NRES) THEN
            WRITE (LUNIT, 99998) XML, NR
            GOTO 150
          ENDIF
          NR1 = NR
          NR2 = NR
        ELSE
          NR1 = 1
          NR2 = NRES
        ENDIF
        DO 100 NR = NR1, NR2
          IF (XML .GT. 0) THEN
            XML =   MXL + NR / PAR(42)
          ELSE
            XML = - MXL - NR / PAR(42)
          ENDIF
          IF (IPR(20) .GT. 0) THEN
            DO 30 I = 1, 3
              XXX(I) = RCG(I, NR)
   30       CONTINUE
            CALL SGSM (ICL, NSLM, XXX, LU6, 3, IERR)
            IF (IPR(36) .NE. 0) THEN
              DPLN = - RA(IPR(80) + 4)
              DO 40 I = 1, 3
                DPLN = DPLN + XXX(I + 6) * RA(IPR(80) + I)
   40         CONTINUE
              IF (DPLN .GT. RA(IPR(80) + 6))  GOTO 150
              IF (DPLN .LT. RA(IPR(80) + 5))  GOTO 150
            ENDIF
          ENDIF
          NMOL = IPR(42)
          IF (NMOL .GT. 0) THEN
            DO 70 L = 1, NMOL
              XMOLL = ABS(MOL(1, L) / PAR(42))
              IF (ABS(ABS(XML) - XMOLL) .LT. 0.005) GOTO 90
              IF (IPR(20) .GT. 0) THEN
                MPM = NINT (XMOLL * PAR(42))
                CALL GEN098 (MPM, PAR(42), NSL2, ITX, ITY, ITZ, NR2)
                YYY(4) = ITX
                YYY(5) = ITY
                YYY(6) = ITZ
                DO 50 I = 1, 3
                  YYY(I) = RCG(I, NR2)
   50           CONTINUE
                CALL SGSM (ICL, NSL2, YYY, LU6, 3, IERR)
                DO 60 I = 7, 9
                  IF (ABS(XXX(I) - YYY(I)) .GT. 0.001) GOTO 70
   60           CONTINUE
                GOTO 90
              ENDIF
   70       CONTINUE
          ENDIF
          L       = IPR(42)
          IPR(42) = IPR(42) + 1
          IF (MODE .LT. 0) THEN
            MOL(1, L + 1) = MOL(1, IPR(44) + 1)
            L             = IPR(44)
            IPR(44)       = IPR(44) + 1
          ELSE
            LDIF = IPR(42) - IPR(75)
            IF (LDIF .GT. 0) THEN
              IF (NINT((XML - 1555.0) * PAR(42)) .EQ. IPR(75)) THEN
                DO 85 L0 = 1, LDIF
                  MOL(1, L + 1) = MOL(1, L)
                  L = L - 1
   85           CONTINUE
                DO 86 L0 = IPR(39) + 1, IPR(37) + IPR(55)
                  CALL PLUT15 (-6, L0, 11, LRES)
                  IF (LRES .GT. IPR(75) - 2) THEN
                    IVAL = LRES + 1
                    CALL PLUT15 (6, L0, 11, IVAL)
                  ENDIF
   86           CONTINUE
              ENDIF
            ENDIF
          ENDIF
          MOL(1, L + 1) = NINT(XML * PAR(42))
          IF (MODE .GT. 0) THEN
            CALL GEN048 (5, MOL(2, L + 1), NMA, MAX (0, NMB))
          ENDIF
          GOTO 95
   90     L    = L - 1
          OXML = MOL(1, L + 1) / PAR(42)
          IF (MODE .LT. 0 .AND. L .GE. IPR(44)) THEN
            MOL(1, L + 1) = MOL(1, IPR(44) + 1)
            L             = IPR(44)
            IPR(44)       = IPR(44) + 1
          ENDIF
          IF (XML .LT. 0) THEN
            MOL(1, L + 1) = - NINT(ABS(OXML) * PAR(42))
          ELSE
            MOL(1, L + 1) =   NINT(ABS(OXML) * PAR(42))
            IF (MODE .GT. 0)
     1         CALL GEN048 (5, MOL(2, L + 1), NMA, NMB)
          ENDIF
   95     MADDR = L
  100   CONTINUE
      ELSE IF (MODE .EQ. 1001) THEN
          IPR(130) = 0
          IF (IPR(17) .EQ. 0) THEN
            CALL PLUT05
          ENDIF
          IF (KL .GT. 1) THEN
            N1 = IFL(2)(1:3)
C * ARU NONE CASE
            IF (N1 .EQ. 'NON') THEN
              ILAST = 0
C * ARU UNIQUE
            ELSE IF (N1 .EQ. 'UNI') THEN
              ILAST = IPR(43)
C * ARU INTER
            ELSE IF (N1 .EQ. 'INT') THEN
              ILAST = IPR(44)
C * ARU RESTORE
            ELSE IF (N1 .EQ. 'RES') THEN
              ILAST =  NMOL
            ELSE
              GOTO 150
            ENDIF
            DO 110 I = 1, NMOL
              XNM = ABS(MOL(1, I) / PAR(42))
              IF (I .GT. ILAST) THEN
                MOL(1, I) = - NINT(XNM * PAR(42))
              ELSE
                MOL(1, I) =   NINT(XNM * PAR(42))
              ENDIF
  110       CONTINUE
        ENDIF
      ELSE IF (MODE .EQ. 1002) THEN
        IPR(159) = IPR(64) - IPR(52) * 2
        NML      = 0
        DO 130 I = 1, NMOL
          XNM = INT(MOL(1, I) / PAR(42))
          IF (XNM .GT. 0) THEN
            RA(IPR(159) - NML) = XNM
            IF (NML .GT. 0) THEN
              DO 120 J = 1, NML
                IF (RA(IPR(159) + 1 - J) .EQ. XNM) GOTO 130
  120         CONTINUE
            ENDIF
            NML = NML + 1
          ENDIF
  130   CONTINUE
        IPR(142) = NML
      ELSE IF (MODE .EQ. 1003) THEN
        IPR(42) = IPR(44)
        NMOL    = IPR(42)
        DO 140 K = 1, NMOL
          MOL(1, K)  = - IABS(MOL(1, K))
  140   CONTINUE
      ELSE IF (MODE .EQ. 1004) THEN
        WRITE (LUNIT, 99997) IPR(43), IPR(44) - IPR(43), NMOL, NRES
        IF (NMOL .NE. 0) THEN
          DO 145 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 .GT. 0) ARU1 = COLR(NARU1)
            CALL GEN048 (-5, MOL(2, I),  6, NARU2)
            IF (NARU2 .GT. 0) ARU2 = BWCT(NARU2)
            CALL GEN048 (-5, MOL(2, I), 11, NARU3)
            IF (NARU3 .GT. 0) ARU3 = COLR(NARU3)
            CALL GEN048 (-5, MOL(2, I), 15, NARU4)
            IF (I .EQ. 1) WRITE (LUNIT, 99991)
            NRESA = 9
            NRESB = 17
            IF (NR .LT. 9)  NRESA = NCRS(NR)
            IF (NR .LT. 17) NRESB = NPRS(NR)
            IF (IPR(134) .GT. 9) THEN
              WRITE (LUNIT, 99996) I, MOL(1, I) / PAR(42), ARU1, ARU2,
     1               ARU3, NARU4, COLR(NRESA), BWCT(NRESB)
            ELSE
              WRITE (LUNIT, 99995) I, MOL(1, I) / PAR(42), ARU1, ARU2,
     1               ARU3, NARU4, COLR(NRESA), BWCT(NRESB)
            ENDIF
  145     CONTINUE
          IF (IPR(130) .EQ. 1) THEN
            WRITE (LUNIT, 99993) IPR(142)
            IM2 = IPR(159)
            IM1 = IM2 + 1 - IPR(142)
            WRITE (LUNIT, 99994) (RA(IM2 + IM1 - I), I = IM1, IM2)
          ENDIF
        ENDIF
      ELSE IF (MODE .EQ. 1005) THEN
        L = NINT(XMOLE)
        IF (L .GT. 0) THEN
          MOL(1, L) = - IABS(MOL(1, L))
        ELSE
          WRITE (LU6, '(''Cannot exclude #'', I3)') L
        ENDIF
      ENDIF
  150 CONTINUE
      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')
      END
      SUBROUTINE PLUT18 (IAT, JAT)
      PARAMETER (NP0=6,NP12=600,NP13=500,NP14=64,NP17=99,NPVD=40000000,
     1 NP23=18000,NP32=63,NP38=125,NP39=30)
      COMMON // MOL(2, NP23), RA(NPVD)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLUTO/ IPPR(129, 3), IBT(32), TRL(3), ROM(3, 3), R(3, 3),
     1 RP(NP14), XJX(12), XXX(12), YYY(12), TMX(3, 3), SHFT(3),
     2 XYZOR(3), XYZR(3),  ZU(15), OM(3, 3), RCG(4, NP32), TMY(3, 3),
     3 XYZPL(6), A(3, 3), XYZK(8), KRS(NP32), NCRS(9), NPRS(17)
      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
      J       = 0
      DMARG   = 0.0
      NDUM    = 0
      ZU7     = 0.0
      ZU8     = 0.0
      ZU9     = 0.0
      MNRB    = 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
      NRBD    = 0
      IASU    = 0
      PHIQ    = 0.0
      XQ12    = 0.0
      YQ12    = 0.0
      ZIJMIN  = 0.0
      ZJ      = 0.0
      ZQ12    = 0.0
      XMARG   = PAR(36)
      IPR(78) = 0
      ILPB    = IPR(69) + 1
      NAB     = IPR(37) - IPR(69)
      NPA     = IPR(62)
      JMAX    = NPA
      NP      = IPR(40)
      M       = IAT
      MA      = M
      N       = JAT
      IF (N .GT. 0) THEN
        MODE = 2
      ELSE
        MODE = 1
      ENDIF
      RTEST = PAR(149) * PAR(24)
      LRET  = 1
      CALL PLUT14 (-1, M, IASU, NPROP, XM, YM, ZM, RM)
      LABI = 0
      IF (M .LE. NP) THEN
        IF (M .GT. NPA) THEN
           LABI  = M - NPA
           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
           GOTO 20
        ENDIF
      ENDIF
   10 IF (MODE .GT. 1) THEN
        III  = N * NP0 + IPR(158)
        ZN   = RA(III - 1)
        RN   = RA(III)
        IF (MODE .EQ. 4) THEN
          ZMAX = MAX (ZM + RM, ZN + RN)
          IF (ZMAX .LT. ZIJMIN) GOTO 100
        ENDIF
        XN   = RA(III - 3)
        YN   = RA(III - 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
        XP12 = (XM + XN) / 2
        YP12 = (YM + YN) / 2
        ZP12 = (ZM + ZN) / 2
        IF (DL21 .NE. 0.0) THEN
          ZRMN = ZMN * RN / DL21
          PHIP = ATAN2(YMN, XMN)
          CPHI = -XMN / DL21
          SPHI = -YMN / DL21
        ELSE
          ZRMN = RN
          PHIP = 0.0
          CPHI = 1.0
          SPHI = 0.0
        ENDIF
        CSPHP = COS(PHIP)
        SNPHP = SIN(PHIP)
        IF (MODE .EQ. 4) THEN
          PHIQX =   PHIQ - PHIP
          PHIPX = - PHIQX
          XT12  =   XP12 - XQ12
          YT12  =   YP12 - YQ12
          XT    =   XT12 * CSPHQ + YT12 * SNPHQ
          YT    = - XT12 * SNPHQ + YT12 * CSPHQ
          ZT    =   ZP12 - ZQ12
          CALL PLUT20 (DL1 + ZRIJ , RJ, RI, DL2 + ZRMN, RM, RN,
     1      PHIPX, XT, YT, IT, XMARG)
          IF (IT .EQ. 0) THEN
            GOTO 100
          ELSE
            XTA   = - XT12 * CSPHP - YT12 * SNPHP
            YTA   =   XT12 * SNPHP - YT12 * CSPHP
            CALL PLUT20 (DL2 + ZRMN, RM, RN, DL1 + ZRIJ, RJ, RI,
     1        PHIQX, XTA, YTA, IT, XMARG)
            IF (IT .EQ. 0) GOTO 100
          ENDIF
          IPHI = MOD(NINT(ABS(PHIQX * GL(5) * 10.0)), 1800)
          ALF  = 0.0
          BET  = 0.0
          IF (IPHI .EQ. 0) THEN
            IF (ABS(ZT) .GT. 0.001)  THEN
              IF (ZT .LT. 0.0) THEN
                GOTO 100
              ELSE
                GOTO 50
              ENDIF
            ENDIF
            IF (IPR(56) .GE. NRBD)    GOTO 100
            IF (IPR(56) .LE. IPR(68)) GOTO 100
            GOTO 110
          ELSE IF (IPHI .EQ. 900) THEN
            IF (DL2 .GT. 0.0) ALF = -YT / DL2
            IF (DL1 .GT. 0.0) BET =  XT / DL1
          ELSE
            TANP =  TAN(PHIPX)
            XS   =  (XT * TANP - YT) / TANP
            DL2C = DL2 * COS(PHIPX)
            IF (DL2C .GT. 0.0) ALF = (XS - XT) / DL2C
            IF (DL1  .GT. 0.0) BET =  XS / DL1
          ENDIF
          ZSJI  = (ZJ - ZQ12) * BET
          ZSMN  = (ZM - ZP12) * ALF + ZT
          ZMNJI = ZSMN - ZSJI
          CRADP = (RM + RN) / 2.0
          CRADQ = (RJ + RI) / 2.0
          IF (ABS(ZMNJI) .GT. 0.01) THEN
            IF (ABS(ALF) .LT. 1.0 .AND. ABS(BET) .LT. 1.0) THEN
              IF (ZMNJI .LT. + (CRADP + CRADQ)) GOTO 100
            ELSE
              IF (ZT .LT. (CRADP + CRADQ)) GOTO 100
            ENDIF
          ELSE
            IF (ZT .LT. 0.0) GOTO 100
          ENDIF
          GOTO 50
        ELSE IF (MODE .EQ. 3) THEN
          GOTO 40
        ENDIF
      ENDIF
   20 NL = 0
      J  = IPR(69)
      IF (LABI .GT. 0) THEN
        IF (IPR(4) .LE. 0) THEN
          J = NPA
        ENDIF
      ENDIF
      IF (MODE .EQ. 1) THEN
        IF (IPR(96) .EQ. 1) THEN
          ANG1 = PAR(51) / GL(5)
          ANG2 = PAR(52) / GL(5)
          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
          GOTO 50
        ENDIF
      ENDIF
   30 J = J + 1
      IF (J .GT. JMAX)  GOTO 80
      IF (MODE .LT. 3) THEN
        IF (J .EQ. MA)  GOTO 30
        IF (LABI .GT. 0) THEN
          IF (IGBL(75) .EQ. 1) THEN
             IF (LABI .LE. IPR(37)) THEN
               IF (LABI .EQ. J) GOTO 30
             ELSE
               IF ((LABI - NAB) .EQ. J) GOTO 30
             ENDIF
          ELSE
             IF (LABI .EQ. (J - IPR(69))) GOTO 30
          ENDIF
        ENDIF
      ENDIF
      JLAB = J - NPA
      IF (JLAB .LE. 0) THEN
        JO = MOD(J - ILPB, NAB) + ILPB
        CALL PLUT15 (-1, JO, 27, NINCL)
        IF (NINCL .EQ. 0) GOTO 30
      ENDIF
      III = J * NP0 + IPR(158)
      XJ  = RA(III - 3)
      YJ  = RA(III - 2)
      ZJ  = RA(III - 1)
      RJ  = RA(III    )
      IF (JLAB .GT. 0) THEN
        IF (JLAB .LE. (IPR(37) * IGBL(75))) THEN
          IF (IPR(46) .EQ. 0 .AND. JLAB .LE. IPR(69)) GOTO 30
          CALL PLUT15 (-4, JLAB, 37, IVAL)
          IF (IVAL .LE. 1) GOTO 30
        ELSE
          IF (J .GT. MA) GOTO 30
        ENDIF
        BX = ABS(XP12 - XJ)
        BY = ABS(YP12 - YJ)
        IF ((BY .LT. 2.0 * PAR(28)) .AND. (BX .LT. DL2 + RJ)) GOTO 110
      ENDIF
      IF (ABS(RJ - 500.0) .GT. 499.99)  GOTO 30
      RSV1 = RJ
   40 BX   = XJ - XM
      BY   = YJ - YM
      BZ   = ZJ - ZM
      JEQM = 0
      BSQ2 = BX**2 + BY**2
      BSQ3 = BSQ2  + BZ**2
      IF (BSQ3 .LT. RTEST) JEQM = 1
      IF (MODE .EQ. 1) THEN
        IF (JEQM .NE. 0) THEN
          IF (M .LE. J)  GOTO 30
          GOTO 110
        ENDIF
        IF (BZ .LT. - RJ)  GOTO 30
        RMJ   = RM + RJ
        IF (BSQ2 .LT. PAR(24) * 0.01) THEN
        ENDIF
        RMJSQ = RMJ**2
        IF (BSQ2 .GT. RMJSQ)  GOTO 30
        IF (BSQ3 .LT. RMJSQ) THEN
          NJ = - J
        ELSE
          NJ = J
        ENDIF
      ELSE
        CX = XJ - XN
        CY = YJ - YN
        CZ = ZJ - ZN
        JEQN = 0
        CSQ3 = CX**2 + CY**2 + CZ**2
        IF (CSQ3 .LT. RTEST) JEQN = 1
        IF (MODE .EQ. 3) THEN
          IF (BZ .GT. RJ)  GOTO 100
          RSV1 = RN
          IF (JEQN .NE. 0 .OR. JEQM .NE. 0) THEN
            IF (JEQN .NE. 1) THEN
              NJ = - N + 1
              NL = N
              IF (ZMN .GE. 0.0001 .AND. RM .GT. 0.001) THEN
                RATIO = RN * SQRT(RMNS) / (RM * ZMN)
                IF (RATIO .LE. 1)  GOTO 100
              ENDIF
            ELSE
              NL   = N - 1
              NJ   = - N
              CPHI = - CPHI
              SPHI = - SPHI
            ENDIF
            GOTO 50
          ENDIF
        ELSE IF (LABI .LE. 0) THEN
          IF (JEQN .EQ. 1)  GOTO 30
          IF (CZ .LT. 0)  GOTO 30
        ENDIF
        CALL PLUT20 (-1.0, RJ, 0.0, DL2, RM, RN, PHIP, XP12 - XJ,
     1   YP12 - YJ, IT, XMARG)
        IF (IT .EQ. 0)  THEN
          IF (LRET .EQ. 1) THEN
            GOTO 30
          ELSE IF (LRET .EQ. 2) THEN
            GOTO 100
          ENDIF
        ENDIF
        XT12  = XJ - XP12
        YT12  = YJ - YP12
        ZT12  = ZJ - ZP12
        XT    = XT12 * CSPHP + YT12 * SNPHP
        ZTEST = ZT12
        IF (DL2 .GT. 0.0) ZTEST = ZTEST + (ZP12 - ZM) * XT / DL2
        RTST = (RM + RN) / 2.0 + RJ
        IF (MODE .EQ. 2) THEN
          NJ = J
          IF (BSQ3 .LT. RJ**2) THEN
            NJ = - IABS(J)
          ELSE
            IF (JEQN .EQ. 0) THEN
              IF (ZTEST .LT. RTST) GOTO 30
            ENDIF
          ENDIF
        ELSE
          IF (JEQN + JEQM .EQ. 0) THEN
            IF (ZTEST + RTST .GE. 0.0) GOTO 100
          ENDIF
        ENDIF
      ENDIF
   50 IABSNJ = IABS(NJ)
      CALL PLUT14 (-1, IABSNJ, IASU, NPROP, X1, Y1, Z1, RSV1)
      NOBSC = IPR(78)
      IPOP  = IPR(66)
      IF (NOBSC .GT. 0) THEN
        DO 60 INOBS = 1, NOBSC
          IPOP = IPOP - 13
          IF (ABS(RA(IPOP + 3) - X1) + ABS(RA(IPOP + 4) - Y1) +
     1          ABS(RA(IPOP + 5) - Z1) .LT. 0.01) GOTO 70
   60   CONTINUE
      ENDIF
      IPR(78) = IPR(78) + 1
      IPOP    = IPR(66) - IPR(78) * 13
      IF (IPOP .GE. 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 .NE. 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
        ENDIF
        IF (MODE .LT. 4) THEN
          IF (NJ .GT. 0) THEN
            DMARG = XMARG
          ELSE
            IF (MODE .EQ. 2) THEN
              DMARG = 0.0
            ELSE IF (MODE .EQ. 3) THEN
              IF (Z2 .GT. Z1) THEN
                IF (DL2 .GT. 0.0) THEN
                  ALFA  = ATAN((Z2 - Z1) / (DL2 * 2.0))
                ELSE
                  ALFA  = 90.0 / GL(5)
                ENDIF
                DMARG = PAR(58) * SIN(ALFA)
              ELSE
                DMARG = 0.0
              ENDIF
            ELSE
              DMARG = XMARG
            ENDIF
          ENDIF
        ELSE IF (MODE .EQ. 4) THEN
          DMARG = XMARG
        ENDIF
        IF (PAR(48) .GT. 0.0) DMARG = DMARG * PAR(48) / (PAR(48) - Z1)
        RA(IPOP + 13) = DMARG
      ELSE
        IPR(78) = IPR(78) - 1
      ENDIF
      NDUM = 0
   70 IF (LABI .NE. 0) THEN
        IF (IPR(78) .GE. 2) GOTO 120
      ENDIF
      IF (LRET .EQ. 1) THEN
        GOTO 30
      ELSE IF (LRET .EQ. 2) THEN
        GOTO 100
      ENDIF
   80 IF (LABI .LE. 0) THEN
        IF (IPR(77) .EQ. 0)  GOTO 120
        IF (MODE .EQ. 2 .AND. IABS(IPR(77)) .GT. 1)  GOTO 90
        IF (IABS(IABS(IPR(77)) - 2) .NE. MODE)  GOTO 120
      ENDIF
   90 MODE = MODE + 2
      XJ   = XM
      YJ   = YM
      ZJ   = ZM
      RJ   = RM
      LRET = 2
      IF (MODE .EQ. 3) THEN
        J      = M
        RTEST  = RJ**2
      ELSE IF (MODE .EQ. 4) THEN
        RI     = RN
        PHIQ   = PHIP
        CSPHQ  = CSPHP
        SNPHQ  = SNPHP
        DL1    = DL2
        XQ12   = XP12
        YQ12   = YP12
        ZQ12   = ZP12
        ZIJMIN = ZMIN
        ZRIJ   = ZRMN
        ZU7    = ZU(7)
        ZU8    = ZU(8)
        ZU9    = ZU(9)
      ENDIF
      NRBD = 0
      NDUM = 0
      IF (IPR(4) .GT. 0) THEN
        MNRB = IPR(97)
      ELSE
        MNRB = 0
      ENDIF
  100 NRBD = NRBD + 1
      IF (NRBD .GT. MNRB) THEN
        IF (MODE .EQ. 4) THEN
          ZU(7) = ZU7
          ZU(8) = ZU8
          ZU(9) = ZU9
        ENDIF
        GOTO 120
      ENDIF
      IPR(67) = IPR(67) - NDUM
      CALL PLUT16 (NRBD, II, M, N, RBO, NLI)
      IF (NLI .LT. 0) NLI = IABS(NLI)
      NDUM = 2
      IF (MODE .EQ. 4) THEN
        IF (IPR(56) .EQ. NRBD) GOTO 100
      ENDIF
      IF (M .EQ. 0) GOTO 100
      N   = IPR(67) + NP
      M   = N - 1
      NJ  = M
      NL  = N
      III = M * NP0 + IPR(158)
      XM  = RA(III - 3)
      YM  = RA(III - 2)
      ZM  = RA(III - 1)
      RM  = RA(III    )
      GOTO 10
  110 IPR(78) = -1
  120 RETURN
      END
      SUBROUTINE PLUT19 (M, MODE)
      PARAMETER (NP12=600,NP13=500,NP14=64,NP17=99,NPVD=40000000,
     1 NP23=18000,NP32=63,NP38=125,NP39=30)
      COMMON // MOL(2, NP23), RA(NPVD)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLUTO/ IPPR(129, 3), IBT(32), TRL(3), ROM(3, 3), R(3, 3),
     1 RP(NP14), XJX(12), XXX(12), YYY(12), TMX(3, 3), SHFT(3),
     2 XYZOR(3), XYZR(3),  ZU(15), OM(3, 3), RCG(4, NP32), TMY(3, 3),
     3 XYZPL(6), A(3, 3), XYZK(8), KRS(NP32), NCRS(9), NPRS(17)
      DELX    = 0.0
      DELY    = 0.0
      DELZ    = 0.0
      DL      = 0.0
      NINC    = 0
      DZS     = 0.0
      RADIUS  = 0.0
      CX      = 0.0
      SX      = 0.0
      CY      = 0.0
      SY      = 0.0
      IUP     = 0
      IPP     = 0
      RNL     = 0.0
      DL2     = 0.0
      CPHI    = 0.0
      SPHI    = 0.0
      XP12    = 0.0
      YP12    = 0.0
      ISLOW   = 0
      DYM     = 0.0
      DXM     = 0.0
      RMS     = 0.0
      ZM      = 0.0
      NOBSC   = IPR(78)
      IPR(98) = 0
      IDOWN   = 3
      LDRAW   = 0
      IDRAW   = 3
      ISTEP   = 1
      IF (MODE .NE. 0) THEN
        IF (MODE .LT. 0) THEN
          NRF  = 3
          NRF1 = 0
        ELSE
          NRF  = 0
          NRF1 = 3
        ENDIF
        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
        IF (IPR(4) .EQ. 0) THEN
          IF (IPR(346) .EQ. 1) THEN
            DELX = DELX / 2.0
            DELY = DELY / 2.0
            DELZ = DELZ / 2.0
          ENDIF
        ENDIF
        DL = SQRT(DELX ** 2 + DELY ** 2)
        IF (NOBSC .GT. 0) THEN
          NINC = (INT(DL / PAR(5)) + 1) * IPR(111)
          DELX = DELX / NINC
          DELY = DELY / NINC
          DELZ = DELZ / NINC
        ELSE
          NINC  = 1
        ENDIF
        IF (NOBSC .GT. 0) THEN
          IF (M .NE. 0) THEN
            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
          ENDIF
        ENDIF
        GOTO 50
      ELSE
        NPP = IPR(91) * IPR(87)
        IF (NOBSC .EQ. 0 .AND. IPR(139) .EQ. 0 .AND.
     1      IPR(162) .NE. 8 .AND. IPR(162) .NE. 9) THEN
           CALL PLUT30 (0, NPP)
           GOTO 100
        ELSE
          RADIUS = PAR(74)
          CX     = COS(PAR(55))
          SX     = SIN(PAR(55))
          CY     = COS(PAR(57))
          SY     = SIN(PAR(57))
          IUP    = 1
          ITS    = 0
          ITF    = 0
          IPP    = -1
          GOTO 40
        ENDIF
      ENDIF
   10 IF (IUP .EQ. 0) ITF = IPP - 1
      IUP = 1
      GOTO 30
   20 IF (IUP .EQ. 1) THEN
        CALL PLUT30 (ITS, ITF)
        ITS = IPP
      ENDIF
      ITF = IPP
      IUP = 0
   30 DUM = CY * CX - SY * SX
      SY  = SY * CX + CY * SX
      CY  = DUM
   40 IPP = IPP + 1
      IF (IPP .GT. NPP) THEN
        CALL PLUT30 (ITS, ITF)
        GOTO 100
      ENDIF
      XX = CY * RADIUS
      YY = SY * RADIUS
      Z  = ZU(3) * XX + ZU(6) * YY + PAR(73)
      IF (XYZK(3) .GT. Z) GOTO 10
      X = ZU(1) * XX + ZU(4) * YY + PAR(71)
      Y = ZU(2) * XX + ZU(5) * YY + PAR(72)
   50 JMODE = - 1
      IPOP  = IPR(66)
   60 IF (JMODE + NOBSC .GE. 0) THEN
        IPOP  = IPOP  - 13
        JMODE = JMODE - 1
        J     = NINT(RA(IPOP + 1))
        IF (J .GT. 0) THEN
          K   = J
          JNL = 1
        ELSE
          K   = - J
          JNL = 0
        ENDIF
        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 .GT. 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)
        ENDIF
        DMARG = RA(IPOP + 13)
        IF (JNL .LT. 3) THEN
          DXK = X - XK
          DYK = Y - YK
          DZK = Z - ZK
          DSQ = DXK**2 + DYK**2
          IF (MODE .EQ. 0) THEN
            IF (JNL .EQ. 1 .AND. M .EQ. 0) THEN
              RK = RK + DMARG
            ELSE IF (JNL .GT. 0) THEN
              IF (M .NE. 0) THEN
                RK = RK + DMARG
              ELSE
                DMARG = 0.0
              ENDIF
            ENDIF
          ELSE
            RK = RK + DMARG
          ENDIF
          RKS = RK**2
          IF (DSQ .LT. RKS) THEN
            IF (MODE .NE. 0 .AND. J .LT. 0) THEN
              IF (DZK .LT. 0.0) GOTO 70
            ELSE IF (J .GT. 0 .OR. MODE .EQ. 0) THEN
              IF (DZK .LE. 0.0)  GOTO 70
            ELSE
              D3SQ = DSQ + DZK**2
              IF (D3SQ .LT. RKS)  GOTO 70
            ENDIF
          ENDIF
          IF (MODE .NE. 0) THEN
            IF (M .NE. 0) THEN
              IF (RKS .GE. DSQ) THEN
                IF (DZS .LT. 0)  GOTO 70
                DZK = SQRT(DZS) + ZM - ZK
                DSQ = DSQ + DZK**2
                IF (DSQ .LT. RKS)  GOTO 70
              ENDIF
            ENDIF
          ELSE
            IF (J .LT. 0) THEN
              IF (K .NE. M) THEN
                DZK = Z - ZK
                DSQ = DSQ + DZK**2
                IF (DSQ .LT. RKS)  GOTO 70
              ENDIF
            ENDIF
          ENDIF
          IF (NL .EQ. 0)  GOTO 60
        ENDIF
        IF (M .GT. 0 .OR. J .LT. 0) THEN
          IF (XYZK(3) .GE. ZK)  GOTO 60
        ENDIF
        X0  = X - XP12
        Y0  = Y - YP12
        XA0 = CPHI * X0 + SPHI * Y0
        IF (ABS(XA0) .GT. DL2)  GOTO 60
        YA0 = -SPHI * X0 + CPHI * Y0
        IF (DL2 .NE. 0) THEN
          RBND = ((RKB + RNL) + (RNL - RKB) * XA0 / DL2) / 2.0 + DMARG
        ELSE
          RBND = DMARG
        ENDIF
        IF (ABS(YA0) .GT. RBND)  GOTO 60
   70   IF (JMODE .LT. -2) THEN
          IF (M .LE. 0) THEN
            IP1 = IPR(66) - 13
            IP2 = IPR(66) + (JMODE + 1) * 13
            DO 75 JJ = 1, 13
              DUM          = RA(IP1 + JJ)
              RA(IP1 + JJ) = RA(IP2 + JJ)
              RA(IP2 + JJ) = DUM
   75       CONTINUE
          ENDIF
        ENDIF
        IF (MODE .EQ. 0) GOTO 10
        IDRAW = 3
      ELSE
        IF (MODE .EQ. 0) GOTO 20
        IDRAW = 2
      ENDIF
      IF (LDRAW .NE. IDRAW) THEN
        IF (LDRAW .NE. 0) THEN
          IF (ISTEP .GT. 1) THEN
            ISTEP = 1 - ISTEP
            ISLOW = - ISTEP
            NINC  = NINC - ISTEP
            DELXN = DELX * ISTEP
            DELYN = DELY * ISTEP
            DELZN = DELZ * ISTEP
            GOTO 90
          ELSE
            ISTEP = 1
            IF (ISLOW .GT. 0) ISLOW = ISLOW - 1
          ENDIF
        ELSE
          LDRAW = IDRAW
          IF (DL .LT. PAR(5)) THEN
            IF (IDRAW .EQ. 3 .AND. ABS(DL) .LT. 0.0001) THEN
              GOTO 100
            ELSE
              ISLOW = IPR(111) - 1
              ISTEP = 1
            ENDIF
          ELSE
            ISLOW = 0
            ISTEP = IPR(111)
          ENDIF
          IF (ISTEP .GT. NINC) ISTEP = NINC
        ENDIF
      ELSE
        IF (ISLOW .GT. 0) THEN
          ISTEP = 1
          ISLOW = ISLOW -1
        ELSE
          ISTEP = IPR(111)
          IF (ISTEP .GT. NINC) ISTEP = NINC
        ENDIF
      ENDIF
      IF (NINC .EQ. 0) IDRAW = 3
      LDRAW = IDRAW
      IF (IDRAW .EQ. 2) THEN
        IF (IDOWN .EQ. 3) THEN
          XA = X
          YA = Y
          IF (MODE .EQ. 0 .OR. M .EQ. 0) THEN
            ZA = Z
          ELSE
            ZA = ZM
          ENDIF
          IDOWN = 2
        ENDIF
      ELSE
        IF (IDOWN .EQ. 2) THEN
          CALL GGIP (XA, YA, ZA, 3)
          CALL GGIP (X,  Y,  Z,  2)
          IDOWN = 3
        ENDIF
        IF (NINC .LE. 0) GOTO 100
      ENDIF
      IF (NINC .EQ. 1) THEN
        NINC  = 0
        DELXN = DELX
        DELYN = DELY
        DELZN = DELZ
      ELSE
        NINC  = NINC - ISTEP
        DELXN = DELX * ISTEP
        DELYN = DELY * ISTEP
        DELZN = DELZ * ISTEP
      ENDIF
   90 X = X + DELXN
      Y = Y + DELYN
      IF (M .NE. 0) THEN
        DXM = DXM + DELXN
        DYM = DYM + DELYN
        DZS = RMS - DXM**2 - DYM**2
        Z   = ZM  + SQRT(ABS(DZS))
      ELSE
        Z = Z + DELZN
      ENDIF
      GOTO 50
  100 RETURN
      END
      SUBROUTINE PLUT20 (XDL1, XRJ, XRI, XDL2, XRM, XRN, XPHI, XXT,
     1                   XYT, IT, XOVRL)
      X0CSPH = 0.0
      X0SNPH = 0.0
      IX     = 0
      IY     = 0
      IT     = 1
      IBX    = 0
      IBY    = 0
      IF (ABS(XPHI) .LT. 0.0001) THEN
        CSPH = 1.0
        SNPH = 0.0
      ELSE
        CSPH = COS(XPHI)
        SNPH = SIN(XPHI)
      ENDIF
      DO 40 LL = 1, 3, 2
        IF (LL .EQ. 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
        ENDIF
        DO 30 KK = 1, 3, 2
          IF (KK .EQ. 1) THEN
            X = X0CSPH - Y0SNPH + XXT
            Y = X0SNPH + Y0CSPH + XYT
          ELSE
            X = X0CSPH + Y0SNPH + XXT
            Y = X0SNPH - Y0CSPH + XYT
          ENDIF
          IF (XDL1 .LT. 0.0) THEN
            BX = XRJ
            BY = XRJ
            IF (ABS(X) .LT. XRJ .AND. ABS(Y) .LT. XRJ) THEN
              IF (X**2 + Y**2 .GT. XRJ**2) THEN
                IF (X .GT. 0) THEN
                  IBX = 2
                ELSE
                  IBX = -2
                ENDIF
                IF (Y .GT. 0) THEN
                  IBY = 2
                ELSE
                  IBY = -2
                ENDIF
              ELSE
                IBX = 0
                IBY = 0
                GOTO 40
              ENDIF
            ENDIF
          ELSE
            BX = XDL1
            BY = ((XRJ + XRI) + (XRJ - XRI) * X / XDL1) / 2.0 + XOVRL
            IF (BY .LT. 0.0) BY = 0.0
          ENDIF
          IF (X .GT. BX) THEN
            IX = IX + 1
          ELSE IF (X + BX .LT. 0.0) THEN
            IX = IX - 1
          ENDIF
          IF (Y .GT. BY) THEN
            IY = IY + 1
          ELSE IF (Y + BY .LT. 0.0) THEN
            IY = IY - 1
          ENDIF
   30   CONTINUE
   40 CONTINUE
      IF (IBX .EQ. 0) THEN
        IF (IABS(IX) .EQ. 4 .OR. IABS(IY) .EQ. 4) IT = 0
      ELSE
        IF (IX .EQ. IBX .AND. IY .EQ. IBY) IT = 0
      ENDIF
      RETURN
      END
      SUBROUTINE PLUT21 (MODE)
      PARAMETER (NP9=118,NP10=16,NP12=600,NP13=500,NP17=99,
     1 NPVD=40000000,NP23=18000,NP38=125,NP39=30,NP43=12,NP45=2048)
      COMMON // MOL(2, NP23), RA(NPVD)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /Q/ ICL, IFL(NP17)
      CHARACTER ICL*(NP45), IFL*7
      COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9),
     1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10),
     2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10),
     3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770)
      CHARACTER J212*2, JJ13*3, J313*3
      N1     = 0
      N2     = 0
      ITOH   = 0
      ITOMET = 0
      ITOCG  = 0
      KL = IPR(220)
      KN = IPR(221)
      IPR(72) = 0
      MODR    = MODE
      IF (MODR .EQ. 0) THEN
        IPR(130) = 0
        IF (KL .LT. 3) THEN
          IPR(72) = 32
          GOTO 120
        ENDIF
        N = 0
        J212 = IFL(2)(1:2)
        IF (J212 .EQ. 'BO') THEN
          IDASH = 1
          DO 10 J = 3, KL
            JJ13 = IFL(J)(1:3)
            IF (JJ13 .EQ. 'DAS') THEN
              IDASH = -1
              GOTO 10
            ENDIF
            IF (JJ13 .EQ. 'TAP') THEN
              IF (KN .EQ. 0) THEN
                IPR(72) = 33
              ELSE
                PAR(44) = FN(1)
              ENDIF
               GOTO 120
            ENDIF
            IF (JJ13 .EQ. 'ALL') THEN
              IF (KN .EQ. 0) THEN
                IPR(72) = 34
              ELSE
                IPR(41) = 0
                PAR(38) = FN(1)
                IF (KN .GE. 2) IPR(12) = NINT(ABS(FN(2)) * IDASH)
              ENDIF
               GOTO 120
            ENDIF
            IF (JJ13 .EQ. 'NOR') THEN
              IF (KN .EQ. 0) THEN
                IPR(72) = 35
              ELSE
                PAR(38) = FN(1)
                IF (KN .GE. 2) IPR(12) = NINT(ABS(FN(2)) * IDASH)
              ENDIF
              GOTO 120
            ENDIF
            IF (JJ13 .EQ. 'TO') THEN
              JPL = - J - 1
              CALL PLUT13 (0, JPL, M, XDUM)
              IF (M .EQ. 0) THEN
                IPR(72) = 36
              ELSE
                N1 = 0
                N2 = M
              ENDIF
              GOTO 15
            ELSE IF (JJ13 .EQ. 'INT') THEN
              N1 = -1
              N2 = 0
              GOTO 15
            ELSE
              JP1 = J + 1
              CALL PLUT13 (0, J ,IAT, XDUM)
              CALL PLUT13 (0, JP1, JAT, XDUM)
              IF (IAT .GT. 0 .AND. JAT .GT. 0) THEN
                N1 = MIN (IAT, JAT)
                N2 = MAX (IAT, JAT)
                GOTO 15
              ELSE
                IPR(72) = 37
              ENDIF
            ENDIF
   10     CONTINUE
   15     IF (IPR(72) .EQ. 0) THEN
            IF (KN .GT. 0) THEN
              RB = FN(1)
            ELSE
              RB = PAR(38)
            ENDIF
            IF (KN .EQ. 2) THEN
              L = NINT(FN(2))
            ELSE
              L = IPR(12)
            ENDIF
            L = IABS(L) * IDASH
            IF (L .EQ. 1) THEN
              IRB = 1
            ELSE
              IRB = NINT(RB * 1000.0)
            ENDIF
            N3    = ISIGN(1000 * IABS(L) + IRB, L)
            NSPEC = IPR(41)
            NRF   = IPR(80)
            DO 20 I = 1, NSPEC
              N10 = NINT(RA(NRF))
              N20 = NINT(RA(NRF - 1))
              IF (N1 .EQ. N10 .AND. N2 .EQ. N20)  GOTO 30
              NRF = NRF - 3
   20       CONTINUE
            IF (IPR(41) .GE. IPR(76)) THEN
              WRITE (LU6, 99999)
              GOTO 120
            ENDIF
            IPR(41)     = IPR(41) + 1
            RA(NRF)     = N1
            RA(NRF - 1) = N2
   30       RA(NRF - 2) = N3
            IF (NRF .EQ. IPR(80)) THEN
              IF (IPR(4) .EQ. 1) THEN
                IPR(103) = N3
              ELSE IF (IPR(4) .EQ. 2) THEN
                IPR(104) = N3
              ELSE IF (IPR(4) .EQ. 4) THEN
                IPR(106) = N3
              ENDIF
            ENDIF
          ENDIF
        ELSE IF (J212 .EQ. 'AT') THEN
          J313  = IFL(3)(1:3)
          IF (KL .LT. 3) THEN
            GOTO 80
          ELSE IF (KL .GT. 3) THEN
            GOTO 60
          ENDIF
          IF (J313 .EQ. 'ALL') THEN
            IF (KN .EQ. 0) THEN
              IPR(72) = 38
            ELSE
              DO 50 I = 1, IAN
                 IF (KN .GE. 1) THEN
                   RADR(I, 1) = FN(1)
                 ELSE
                   RADR(I, 1) = PAR(70)
                 ENDIF
   50         CONTINUE
              IPR(99) = 1
            ENDIF
             GOTO 120
          ENDIF
          IPR(99) = 2
          IF (J313 .EQ. 'AUT') THEN
            IF (IABS(IPR(4)) .EQ. 3) THEN
              MODR   = 1
            ELSE
              MODR   = -1
              IPR(4) = 1
            ENDIF
             GOTO 80
          ELSE IF (J313 .EQ. 'COV') THEN
            MODR   = -1
            IPR(4) = 1
            GOTO 80
          ELSE IF (J313 .EQ. 'CPK')  THEN
            MODR   = 1
            GOTO 80
          ENDIF
   60     DO 70 K = 3, KL
            CALL PLUT13 (0, -K, IAT, XDUM)
            IF (IAT .LT. 0) THEN
              M = - IAT
              N = N + 1
              IF (N .GT. KN) THEN
                IPR(72) = 39
                GOTO 120
              ELSE
                RADR(M, 1) = FN(N)
              ENDIF
            ELSE
              N = N + 1
              IF (N .GT. KN) THEN
                IPR(72) = 39
                GOTO 120
              ENDIF
              RA(IAT * NP43 + 11) = FN(N)
            ENDIF
   70     CONTINUE
          IPR(99) = 2
        ELSE
          IPR(72) = 41
        ENDIF
      ENDIF
   80 IF (MODR .LT. 0) THEN
        RA(IPR(80)    ) = -1
        RA(IPR(80) - 1) = 0
        RA(IPR(80) - 2) = -5020
        IPR(41)         = 1
        IF (IPR(4) .EQ. 0) THEN
          CALL GEN074 (RADR, 0.0, 1, IAN)
        ELSE
          IF (IPR(4) .EQ. 1) THEN
            PAR(38)     = 0.05
            IPR(12)     = 30
            PAR(21)     = PAR(351)
            ITOH        = IPR(103)
            ITOMET      = 2040
            ITOCG       = -6040
          ELSE IF (IPR(4) .EQ. 2) THEN
            PAR(38)     = 0.2
            IPR(12)     = 8
            PAR(21)     = PAR(352)
            ITOH        = IPR(104)
            ITOMET      = 2040
            ITOCG       = -6040
          ELSE IF (IPR(4) .EQ. 4) THEN
            PAR(38)     = 0.12
            IPR(12)     = 2
            PAR(21)     = PAR(354)
            ITOH        = IPR(106)
            ITOMET      = -6040
            ITOCG       = -6040
          ENDIF
          RMIN            = MOD(ITOH, 1000) / 1000.0
          DO 100 I = 1, IAN
            IF (IEN(I) .EQ. 106) THEN
              ITO = ITOCG
            ELSE IF (IEN(I) .EQ. 111) THEN
              ITO = 1010
            ELSE IF (IATPR(IEN(I)) .GE. 0) THEN
              ITO = ITOMET
            ELSE
              ITO = 0
            ENDIF
            IF (ITO .NE. 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
            ENDIF
            RADR(I, 1) = MAX (PAR(21) * RADR(I, 3), RMIN)
  100     CONTINUE
          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) PAR(21)
        ENDIF
      ELSE IF (MODR .GT. 0) THEN
        DO 110 I = 1, IAN
          RADR(I, 1) = ABS(VDWR(IEN(I)))
  110   CONTINUE
        WRITE (LU6, 99997)
        PAR(38) = 0.0
        IPR(12) = 0
        IPR(4)  = 3
        IPR(77) = 3
        IPR(41) = 0
      ENDIF
  120 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 PLUT22 (I, J, D)
      PARAMETER (NPVD=40000000,NP23=18000,NP43=12)
      COMMON // MOL(2, NP23), RA(NPVD)
      D = 0
      DO 10 L = 4, 6
        D = D + (RA(I * NP43 + L) - RA(J * NP43 + L))**2
   10 CONTINUE
      D = SQRT(ABS(D))
      RETURN
      END
      SUBROUTINE PLUT23 (MODE)
      PARAMETER (NP4=9,NP10=16,NP12=600,NP13=500,NP14=64,NP17=99,
     1 NPVD=40000000,NP22=256,NP23=18000,NP32=63,NP38=125,NP39=30,
     2 NP43=12)
      COMMON // MOL(2, NP23), RA(NPVD)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLUTO/ IPPR(129, 3), IBT(32), TRL(3), ROM(3, 3), R(3, 3),
     1 RP(NP14), XJX(12), XXX(12), YYY(12), TMX(3, 3), SHFT(3),
     2 XYZOR(3), XYZR(3),  ZU(15), OM(3, 3), RCG(4, NP32), TMY(3, 3),
     3 XYZPL(6), A(3, 3), XYZK(8), KRS(NP32), NCRS(9), NPRS(17)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      IF (MODE .GE. 0) THEN
        I = MODE * NP43
        DO 110 II = 1, 3
          RA(I + II + 3) = 0.0
          DO 100 JJ = II, 3
             RA(I + II + 3) = RA(I + II + 3) + OM(II, JJ) * RA(I + JJ)
  100     CONTINUE
  110   CONTINUE
      ELSE
        IF (IABS(IPR(50)) .EQ. 1) THEN
          IF (IPR(50) .EQ. 1) THEN
            WRITE (LU6, 99997)
          ELSE
            IPR(50) = 1
          ENDIF
          IPR(37)  = 0
          IPR(52)  = 0
          IPR(53)  = 0
          IPR(68)  = 0
          IPR(69)  = 0
          IGBL(30) = 1
          IGBL(33) = 0
          CALL GEN074 (PAR, 1.0, 101, 103)
          PAR(148) = 90.0
        ENDIF
        IPR(51) = 1
        IF (PAR(104) .EQ. 0.0) PAR(104) = 90.0
        IF (PAR(105) .EQ. 0.0) PAR(105) = 90.0
        IF (PAR(106) .EQ. 0.0) PAR(106) = PAR(148)
        CALL GEN026 (1, OM, PAR(101), GL(5))
        IF (IPR(127) .GT. 0) THEN
          CALL GEN001 (1, TMX, OM, ROM)
          CALL GEN026 (-1, ROM, PAR(101), GL(5))
          WRITE (LU6, 99998) (PAR(II), II = 101, 106)
        ENDIF
        CALL GEN066 (0, PAR(101), PAR(107), SPGRNM(1)(12:12))
        CALL GEN044 (PAR(101), OM)
        CALL GEN003 (OM, ROM, DET, 0)
        ARG = 1.0
        DO 40 II = 4, 6
          PAR(115 + II) = PAR(100 + II)
          PAR(103 + II) = SIN(PAR(100 + II) / GL(5))
          PAR(100 + II) = COS(PAR(100 + II) / GL(5))
          ARG           = ARG - PAR(100 + II)**2
   40   CONTINUE
        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))
        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 50 I = 7, 9
          PAR(100 + I) = 1.0 / PAR(106 + I)**2
   50   CONTINUE
        DO 51 I = 1, 3
          PAR(97 + I) = PAR(100 + I)
   51   CONTINUE
        IF (PAR(101) .EQ. PAR(102) .OR. PAR(101) .EQ. PAR(103))
     1    PAR(98) = PAR(101) + 0.0002
        IF (PAR(102) .EQ. 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 80 K = 1, 3
          IF (PAR(97 + K) .EQ. AXHI) THEN
            IPR(120 + K) = 1
          ELSE IF (PAR(97 + K) .EQ. AXLO) THEN
            IPR(120 + K) = 3
          ELSE
            IPR(120 + K) = 2
          ENDIF
   80   CONTINUE
      ENDIF
      RETURN
99998 FORMAT (':: New Cell', 3F8.4, 3F7.2)
99997 FORMAT (':: No CELL card given, Angstrom data assumed')
      END
      SUBROUTINE PLUT24 (NRA, JATM, MNCODE)
      PARAMETER (NP4=9,NP9=118,NP10=16,NP12=600,NP13=500,NP14=64,
     1 NP17=99,NPVD=40000000,NP22=256,NP23=18000,NP32=63,NP38=125,
     2 NP39=30,NP45=2048)
      COMMON // MOL(2, NP23), RA(NPVD)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLUTO/ IPPR(129, 3), IBT(32), TRL(3), ROM(3, 3), R(3, 3),
     1 RP(NP14), XJX(12), XXX(12), YYY(12), TMX(3, 3), SHFT(3),
     2 XYZOR(3), XYZR(3),  ZU(15), OM(3, 3), RCG(4, NP32), TMY(3, 3),
     3 XYZPL(6), A(3, 3), XYZK(8), KRS(NP32), NCRS(9), NPRS(17)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9),
     1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10),
     2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10),
     3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770)
      COMMON /Q/ ICL, IFL(NP17)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /GEO/ GEOM(10)
      CHARACTER GEOM*80
      COMMON /CGG11/ BCD, SBCD
      CHARACTER BCD*132, SBCD*132
      IF (NRA .EQ. -3) THEN
        DO 10 I = 1, 10
          CALL GGIP20 (0.0, GEOM(I), 80, 0.3, 0, 2, -PAR(64) + 1.0,
     1             PAR(65) - 1.0 - I * 0.5)
   10   CONTINUE
      ELSE IF (NRA .EQ. -2) THEN
        DO 20 I = 2, 10
          CALL GEN038 (GEOM(I), 1, 80)
   20   CONTINUE
      ELSE
        IF (IPR(17) .EQ. 0) THEN
          CALL PLUT05
          IF (IPR(72) .NE. 0) STOP '311'
        ENDIF
        IF (ABS(NRA) .EQ. IPR(220) - 1) THEN
          CALL PLUT13 (0, 2, IAT, XDUM)
          CALL PLUT25 (1, IAT, IATK)
          IF (IAT .GT. 0) THEN
            IF (ABS(NRA) .EQ. 1) THEN
              NB   = 0
              SANG = 0.0
              ANGM = 0.0
              NMET = 0
              DO 30 I = 2, 10
                CALL GGIP20 (0.0, GEOM(I), 80, 0.3, 0, 2, -PAR(64)
     1               + 1.0, PAR(65) - 1.0 - I * 0.5)
   30         CONTINUE
              WRITE (GEOM(1), 99999)
              NG = 1
              DO 40 I = 2, 10
                CALL GEN038 (GEOM(I), 1, 80)
   40         CONTINUE
              DO 60 JAT = IPR(69) + 1, JATM
                CALL PLUT15 (-1, JAT, 27, JNCL)
                IF (JNCL .EQ. 1 .OR. IPR(163) .EQ. 1
     1               .OR. JAT .GT. IPR(39)) THEN
                  CALL PLUT16 (-5, IDUM, IAT, JAT, DUMMY, IDUM1)
                  IF (IDUM .GT. 0) THEN
                    NB = NB + 1
                    CALL PLUT22 (IAT, JAT, D)
                    IF (NB .EQ. 1) D1 = D
                    IF (NB .EQ. 2) THEN
                      D2 = D
                      IF (D2 .LT. D1) CALL GEN018 (D1, D2)
                    ENDIF
                    CALL PLUT25 (2, JAT, JATK)
                    CALL PLUT15 (-1, JAT, 17, MET)
                    NMET = NMET + MET
                    CALL PLUT15 (-6, JAT, 11, MADDR)
                    XMOL = MOL(1, MADDR + 1) / PAR(42)
                    NA   = 0
                    IF (NB .GT. 1) THEN
                      MJAT = MIN (JAT - 1, IPR(38))
                      DO 50 KAT = IPR(69) + 1, MJAT
                        CALL PLUT15 (-1, KAT, 27, KNCL)
                        IF (KNCL .EQ. 1 .OR. IPR(163) .EQ. 1
     1                      .OR. KAT .GT. IPR(39)) THEN
                          CALL PLUT16 (-5, IDUM, IAT, KAT, DUMMY, IDUM1)
                          IF (IDUM .GT. 0) THEN
                            CALL PLUT37 (KAT, IAT, JAT, 0, ANG)
                            ANGM = MAX (ANGM, ANG)
                            IF (NA .LT. 12) THEN
                              NA      = NA + 1
                              XXX(NA) = ANG
                              SANG    = SANG + ANG
                            ENDIF
                          ENDIF
                        ENDIF
   50                 CONTINUE
                    ENDIF
                    IF (NG .LT. 10) THEN
                      NG = NG + 1
                      WRITE (GEOM(NG), 99998) NQ1, NQ2, XMOL, D,
     1                      (XXX(I), I = 1, NA)
                    ENDIF
                  ENDIF
                ENDIF
   60         CONTINUE
              DO 70 I = 1, NG
                CALL GGIP20 (0.0, GEOM(I), 80, 0.3, 5 + IGBL(68), 2,
     1               - PAR(64) + 1.0, PAR(65) - 1.0 - I * 0.5)
   70         CONTINUE
C * HFIX
              IF (NRA .EQ. -1) THEN
                IF (NB .EQ. 0) THEN
                  MNCODE = -1
                ELSE
                  IATK   = IATNR(IEN(IATK))
                  JATK   = IATNR(IEN(JATK))
                  MNCODE = 0
                  IF (IATK .EQ. 5) THEN
                    IF (NB .EQ. 4) THEN
                      IF (ANGM .LT. 130) THEN
                        MNCODE = -1
                      ELSE
                        MNCODE = 153
                      ENDIF
                    ELSE IF (NB .EQ. 5) THEN
                      MNCODE = 153
                    ENDIF
                  ELSE IF (IATK .EQ. 6) THEN
                    IF (NB .EQ. 4) THEN
                      MNCODE = -1
                    ELSE IF (NB .EQ. 3) THEN
                      IF (SANG .LT. 340.0) THEN
                        IF (NMET .EQ. 1) THEN
                          MNCODE = 43
                        ELSE
                          MNCODE = 13
                        ENDIF
                      ELSE IF (SANG .GT. 350) THEN
                        MNCODE = -1
                      ENDIF
                    ELSE IF (NB .EQ. 2) THEN
                      IF (SANG .LT. 115) THEN
                        IF (D1 .GT. 1.45) THEN
                          MNCODE = 23
                        ELSE
                          MNCODE = 43
                        ENDIF
                      ELSE IF (SANG .GT. 150.0) THEN
                        MNCODE = -1
                      ELSE
                        IF (D1 .GT. 1.45 .AND. D2 .GT. 2.0) THEN
                          MNCODE = 23
                        ELSE
                          MNCODE = 43
                        ENDIF
                      ENDIF
                    ELSE IF (NB .EQ. 1) THEN
                      IF (D .GT. 1.4) THEN
                        MNCODE = 137
                      ELSE IF (D .GT. 1.25) THEN
                        MNCODE = 93
                      ELSE
                        MNCODE = 163
                      ENDIF
                    ENDIF
                  ELSE IF (IATK .EQ. 7) THEN
                    IF (NB .EQ. 1) THEN
                      IF (D .GT. 1.35) MNCODE = 93
                    ENDIF
                  ELSE IF (IATK .EQ. 8) THEN
                    IF (NB .EQ. 1) THEN
                      IF (JATK .EQ. 15) THEN
                        IF (D .GT. 1.5)  MNCODE = 83
                      ELSE
                        IF (D .GT. 1.27) MNCODE = 83
                      ENDIF
                    ELSE
                      MNCODE = -1
                    ENDIF
                  ELSE
                    MNCODE = -1
                  ENDIF
                ENDIF
              ENDIF
            ELSE
              CALL PLUT13 (0, 3, JAT, XDUM)
              IF (JAT .GT. 0) THEN
                IF (NRA .EQ. 2) THEN
                  IF (IPR(221) .EQ. 1) THEN
                    XNM = FN(1)
                    IF (XNM .LT. 0.0) THEN
                      M = - NINT(XNM)
                      XNM = NINT(RA(IPR(159) + 1  - M))
                    ENDIF
                    CALL PLUT28 (IAT, JAT, XNM)
                    CALL PLUT15 (4, JAT, 37, 1)
                  ENDIF
                  CALL PLUT22 (IAT, JAT, D)
                  WRITE (SBCD, 99997) (IFL(I), I = 1, 3), D, CHAR(0)
                  IF (IGBL(32) .EQ. 0) WRITE (LU6, 99994) SBCD
                ELSE
                  CALL PLUT13 (0, 4, KAT, XDUM)
                  IF (KAT .GT. 0) THEN
                    IF (NRA .EQ. 3) THEN
                      CALL PLUT37 (IAT, JAT, KAT, 0, ANGLE)
                      WRITE (SBCD, 99996) (IFL(I), I = 1, 4), ANGLE,
     1                       CHAR(0)
                      IF (IGBL(32) .EQ. 0) WRITE (LU6, 99994) SBCD
                    ELSE
                      CALL PLUT13 (0, 5, LAT, XDUM)
                      IF (LAT .GT. 0) THEN
                        IF (NRA .EQ. 4) THEN
                          CALL PLUT37 (IAT, JAT, KAT, LAT, OMEGA)
                          WRITE (SBCD, 99995) (IFL(I), I = 1, 5),
     1                           OMEGA * IPR(65), CHAR(0)
                          IF (IGBL(32) .EQ. 0) WRITE (LU6, 99994) SBCD
                        ENDIF
                      ELSE
                        IPR(72) = 42
                      ENDIF
                    ENDIF
                  ELSE
                    IPR(72) = 43
                  ENDIF
                ENDIF
              ELSE
                IPR(72) = 44
              ENDIF
            ENDIF
          ELSE
            IPR(72) = 45
          ENDIF
        ELSE
          IPR(72) = 46
        ENDIF
        IPR(163) = 0
      ENDIF
      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 PLUT25 (MD, IAT, IATK)
      PARAMETER (NP4=9,NP9=118,NP10=16,NP12=600,NP13=500,
     1 NP17=99,NPVD=40000000,NP22=256,NP23=18000,NP36=1000,NP38=125,
     2 NP39=30,NP43=12)
      COMMON // MOL(2, NP23), RA(NPVD)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9),
     1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10),
     2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10),
     3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770)
      DIMENSION NUM(3)
      CHARACTER NQ*7
      COMMON /ALIASES/ ALAB(NP36), BLAB(NP36)
      CHARACTER ALAB*7, BLAB*7
      IF (MD .GE. 0) THEN
        MODE = MD
        NPAR = IPR(71)
      ELSE
        MODE = - MD
        NPAR = 1
      END IF
      NAT = IABS(IAT)
      IF (NAT .GT. IPR(37)) THEN
        N = MOD(NAT - IPR(69) - 1, IPR(37) - IPR(69)) + IPR(69) + 1
      ELSE
        N = NAT
      ENDIF
      XNQNR = RA(N * NP43 + 7)
      CALL PLUT15 (-6, N, 11, JX3)
      IF (IPR(75) .GT. 0) THEN
        JX3 = JX3 - IPR(75) + 1
      ELSE
        JX3 = 0
      ENDIF
      IF (MODE .NE. 0) THEN
        KK = 1
        IF (XNQNR .GE. 0.0) THEN
          JX1 = INT(XNQNR / 32000)
          JX2 = INT(XNQNR - JX1 * 32000 )
          NSS = MOD(JX2, 32)
          JX2 = JX2 / 32
          JX0 = JX1 + 1
          JX1 = IEL(IEN(JX0))
          J1  = JX1 / 100
          J2  = JX1 - J1 * 100
          IF (IAT .GT. 0 .OR. JX0 .GT. 2) THEN
            NQ(KK:KK) = CHAR(ICHAR('A') - 1 + J1)
            KK = KK + 1
            IF (J2 .NE. 0) THEN
              NQ(KK:KK) = CHAR(ICHAR('a') - 1 + J2)
              KK = KK + 1
            ENDIF
          ENDIF
          IF (JX2 .EQ. 0) NPAR = 1
          IF (NPAR .EQ. 0) THEN
            NQ(KK : KK) = '('
            KK = KK + 1
          ENDIF
          J2 = JX2 / 10
          NUM(3) = MOD(JX2, 10)
          NUM(1) = J2 / 10
          NUM(2) = MOD(J2, 10)
          J2     = 0
          DO 10 J = 1, 3
            IF (NUM(J) .GT. 0 .OR. J2 .GT. 0) THEN
              NQ(KK : KK) = CHAR(ICHAR('0') + NUM(J))
              KK = KK + 1
              J2 = J2 + 1
            ENDIF
   10     CONTINUE
          IF (NSS .NE. 0) THEN
            IF (NSS .EQ. 1) THEN
              NQ(KK : KK) = ''''
            ELSE IF (NSS .EQ. 2) THEN
              NQ(KK : KK) = '"'
            ELSE IF (NSS .EQ. 3) THEN
              NQ(KK : KK) = '#'
            ELSE IF (NSS .GT. 3) THEN
              NQ(KK : KK) = CHAR(ICHAR('A') + NSS - 4)
            ENDIF
            KK = KK + 1
          ENDIF
          IF (NPAR .EQ. 0) THEN
            NQ(KK : KK) = ')'
            KK = KK + 1
          ENDIF
          IF (JX3 .GT. 0) THEN
            IF (NPAR .NE. 0) THEN
              NQ(KK : KK) = '_'
              KK = KK + 1
            ENDIF
            IF (JX3 .LT. 27) THEN
              NQ(KK : KK) = CHAR(ICHAR('a') - 1 + JX3)
            ELSE IF (JX3 .EQ. 27 .OR. JX3 .GT. 53) THEN
              NQ(KK : KK) = '*'
            ELSE
              NQ(KK : KK) = CHAR(ICHAR('a') + JX3 - 28)
            ENDIF
            KK = KK + 1
          ENDIF
        ENDIF
        IF (KK .LT. 8) THEN
          CALL GEN038 (NQ, KK, 7)
        ENDIF
        IF (IGBL(55) .EQ. 0) THEN
          IF (IGBL(71) .GT. 0) THEN
            DO 20 I = 1, IGBL(71)
              IF (NQ .EQ. BLAB(I)) NQ = ALAB(I)
   20       CONTINUE
          ENDIF
        ENDIF
        IF (MODE .NE. 2) THEN
          NQ1 = NQ
        ELSE
          NQ2 = NQ
        ENDIF
      ENDIF
      IATK = INT(XNQNR / 32000) + 1
      RETURN
      END
      SUBROUTINE PLUT26 (M, NATL, XI, YI, ZI, RI, XL, YL, ZL, RL, XSH)
      PARAMETER (NP12=600,NP13=500,NP17=99,NP38=125,NP39=30)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      XL = XI
      YL = YI
      IF (IPR(116) .NE. 0) THEN
        ZL = ZI
      ELSE
        IF (PAR(48) .NE. 0.0) THEN
          ZL = ZI
        ELSE
          ZL = ZI + PAR(60)
        ENDIF
      ENDIF
      RL = MAX (PAR(28), PAR(40))
      IF (M .LT. 10) THEN
        ANG = GL(6) * (M - 2) / 8
        CA  = COS(ANG)
        SA  = SIN(ANG)
        RIX = RI + XSH
        XL  = XL + RIX * CA
        YL  = YL + RIX * SA
        IF (ABS(CA) .GT. 0.1) XL = XL + PAR(40) * CA / ABS(CA)
        IF (ABS(SA) .GT. 0.1) YL = YL + PAR(28) * SA / ABS(SA)
      ENDIF
      NPROP = 0
      IASU  = 0
      CALL PLUT14 (1, NATL, IASU, NPROP, XL, YL, ZL, RL)
      RETURN
      END
      SUBROUTINE PLUT27 (IAJAT, IAT, JAT, RBO, NLI)
      PARAMETER (NP12=600,NP13=500,NP14=64,NP17=99,NPVD=40000000,
     1 NP23=18000,NP32=63,NP38=125,NP39=30,NP43=12)
      COMMON // MOL(2, NP23), RA(NPVD)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLUTO/ IPPR(129, 3), IBT(32), TRL(3), ROM(3, 3), R(3, 3),
     1 RP(NP14), XJX(12), XXX(12), YYY(12), TMX(3, 3), SHFT(3),
     2 XYZOR(3), XYZR(3),  ZU(15), OM(3, 3), RCG(4, NP32), TMY(3, 3),
     3 XYZPL(6), A(3, 3), XYZK(8), KRS(NP32), NCRS(9), NPRS(17)
      IF (IPR(4) .GT. 0) THEN
        IF (IAT .GT. IPR(69)) THEN
          CALL PLUT15 (-6, IAT, 5,  NRESI)
          CALL PLUT15 (-6, JAT, 5,  NRESJ)
          ITYPE = INT(RA(IAT * NP43 + 7) / 32000)
          JTYPE = INT(RA(JAT * NP43 + 7) / 32000)
          CALL PLUT15 (-1, IAT, 44, IHAT)
          CALL PLUT15 (-1, JAT, 44, JHAT)
          IF (IHAT .EQ. 1) ITYPE = 0
          IF (JHAT .EQ. 1) JTYPE = 0
          L     = -1
          NSPEC = IPR(41)
          NRF   = IPR(80) + 1
          DO 10 K = 1, NSPEC
            NRF = NRF - 3
            N1  = NINT(RA(NRF + 2))
            N2  = NINT(RA(NRF + 1))
            N3  = NINT(RA(NRF    ))
            IF (N1 .LT. 0) THEN
              IF (IAJAT .GT. IPR(53)) L = N3
              IF (NRESI .NE. NRESJ)   L = N3
            ELSE IF (N1 .EQ. 0) THEN
              IF (N2 .LT. 0) THEN
                IAIO = - ITYPE - 1
                IAJO = - JTYPE - 1
              ELSE
                IAIO = IAT
                IAJO = JAT
              ENDIF
              IF (IAIO .EQ. N2 .OR. IAJO .EQ. N2) THEN
                IF (L .EQ. -1) THEN
                  L = N3
                ENDIF
              ENDIF
            ELSE
              IF (N1 .EQ. IAT .AND. N2 .EQ. JAT) THEN
                L = N3
              ELSE IF (N1 .EQ. JAT .AND. N2 .EQ. IAT) THEN
                L = N3
              ENDIF
            ENDIF
   10     CONTINUE
          IF (L .NE. -1) THEN
            RBO = 0.001 * FLOAT(MOD(IABS(L), 1000))
            NLI = ISIGN(IABS(L) / 1000, L)
          ELSE
            RBO = PAR(38)
            NLI = IPR(12)
          ENDIF
          CALL PLUT15 (-4, IAT, 28, IDIS)
          CALL PLUT15 (-4, JAT, 28, JDIS)
          IDIS = IPPR(IDIS + 1, 1)
          JDIS = IPPR(JDIS + 1, 1)
          IF (IDIS .LT. 500 .OR. JDIS .LT. 500) NLI = - IABS(NLI)
        ELSE
          RBO = PAR(75)
          NLI = IPR(107)
        ENDIF
      ELSE
        NLI = 1
        RBO = 0.0
      ENDIF
      RETURN
      END
      SUBROUTINE PLUT28 (IAT, JAT, XML)
      PARAMETER (NP4=9,NP10=16,NP12=600,NP13=500,NP14=64,
     1 NP17=99,NPVD=40000000,NP22=256,NP23=18000,NP32=63,NP38=125,
     2 NP39=30,NP43=12,NP45=2048)
      COMMON // MOL(2, NP23), RA(NPVD)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLUTO/ IPPR(129, 3), IBT(32), TRL(3), ROM(3, 3), R(3, 3),
     1 RP(NP14), XJX(12), XXX(12), YYY(12), TMX(3, 3), SHFT(3),
     2 XYZOR(3), XYZR(3),  ZU(15), OM(3, 3), RCG(4, NP32), TMY(3, 3),
     3 XYZPL(6), A(3, 3), XYZK(8), KRS(NP32), NCRS(9), NPRS(17)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /Q/ ICL, IFL(NP17)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      IF (NINT(XML) .EQ. 0) GOTO 50
      CALL PLUT17 (XML, -1, MADDR, LU6)
      MPM = NINT (XML * PAR(42))
      CALL GEN098 (MPM, PAR(42), NS, ITX, ITY, ITZ, NR)
      XJX(4) = ITX
      XJX(5) = ITY
      XJX(6) = ITZ
      DO 10 I = 1, 3
        XJX(I) = RA(JAT * NP43 + I)
   10 CONTINUE
      CALL SGSM (ICL, NS, XJX, LU6, 3, IERR)
      DO 30 KAT = IPR(69) + 1, IPR(37)
        DO 20 J = 1, 3
          IF (ABS(RA(KAT * NP43 + J) - XJX(6 + J)) *
     1        PAR(100 + J) .GE. PAR(22)) GOTO 30
   20   CONTINUE
        JAT = KAT
        GOTO 50
   30 CONTINUE
      IPR(37) = IPR(37) + 1
      IPR(38) = IPR(38) + 1
      KAT     = JAT
      JAT     = IPR(37)
      DO 40 I = 1, 3
        RA(JAT * NP43 + I) = XJX(6 + I)
   40 CONTINUE
      CALL PLUT23 (JAT)
      RA(JAT * NP43 + 8)  = RA(KAT * NP43 + 8)
      RA(JAT * NP43 + 9)  = RA(KAT * NP43 + 9)
      RA(JAT * NP43 + 10) = RA(KAT * NP43 + 10)
      IF (IAT .GT. 0) THEN
        CALL PLUT15 (-6, IAT,  5, IVAL)
        CALL PLUT15 ( 6, JAT,  5, IVAL)
      ENDIF
      IVAL = 0
      CALL PLUT15 ( 1, JAT, 27, IVAL)
      RA(JAT * NP43 + 7) = RA(KAT * NP43 + 7)
      CALL PLUT15 (6, JAT, 11, MADDR)
      CALL PLUT25 (1, JAT, JDUM)
      WRITE (LU6, 99999) NQ1
      XM2 = RA(KAT * NP43 + 12) * 1000.0
      CALL PLA081 (28, XML, XM2, XM3)
      IF (IPR(2) .NE. 0) STOP '101'
      RA(JAT * NP43 + 12) = XM3 / 1000.0
      RA(JAT * NP43 + 11) = RA(IAT * NP43 + 11)
   50 RETURN
99999 FORMAT (':: ', A, ' added to coordinate list.')
      END
      SUBROUTINE PLUT29 (MODE, LINE, NQ, NRFIX)
      PARAMETER (NP12=600,NP13=500,NP17=99,NPVD=40000000,NP23=18000,
     1 NP38=125,NP39=30)
      COMMON // MOL(2, NP23), RA(NPVD)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /PLU99A/ SFC(16)
      COMMON /PLU99B/ NUNIT(16), NSF, NFHAT
      CHARACTER LINE*(*), LIN*80, NQ*(*), SFC*2, LTYPE*2, CRDT*4, SLT*2,
     1 KEY*4, RESD*4
      LENM = MIN (80, LEN(LINE))
      IF (MODE .EQ. 1) THEN
        IF (IPR(201) .GT. IPR(80) + 80) THEN
          LIN = LINE(1:LENM)
          CALL GEN020 (1, LIN, 1, 4)
          NBLK = -1
          DO 10 I = 1, 80
            IPR(201)     = IPR(201) - 1
            RA(IPR(201)) = ICHAR(LIN(I:I))
            IF (LIN(I:I) .NE. ' ') NBLK = 0
   10     CONTINUE
          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
          IF (LIN(1:1) .EQ. 'Q') IGBL(26) = IGBL(26) + IPR(176)
        ENDIF
C * RENAME - MODE
      ELSE IF (MODE .EQ. 2) THEN
        CALL GEN020 (1, LINE, 2, 2)
        CALL GEN020 (1, NQ, 1, 4)
        J1 = IPR(200)
   20   J2 = J1 - 83
        IF (J2 .GE. IPR(201)) THEN
          WRITE (KEY, 99994) (CHAR(NINT(RA(J1 - J))), J = 1, 4)
          IF (KEY .NE. LINE(1:4)) GOTO 100
          IGBL(26) = IGBL(26) + 1
          DO 40 J = 1, 4
            RA(J1 - J) = ICHAR(NQ(J:J))
   40     CONTINUE
          RA(J1 - 82) = 0
          CALL GEN020 (1, NQ, 1, 2)
          LTYPE = NQ(1:1)//' '
          DO 50 J =  ICHAR('A'), ICHAR('Z')
            IF (NQ(2:2) .EQ. CHAR(J)) THEN
              LTYPE = NQ(1:2)
              GOTO 60
            ENDIF
   50     CONTINUE
   60     DO 70 K = 1, NSF
            SLT = SFC(K)
            CALL GEN020 (1, SLT, 1, 2)
            IF (LTYPE .EQ. SLT) GOTO 80
   70     CONTINUE
          NSF      = NSF + 1
          K        = NSF
          SFC(K)   = LTYPE
          NUNIT(K) = 1
C * REPLACE SCATTERING TYPE
   80     ISF1 = K / 10
          ISF2 = MOD(K, 10)
          DO 90 J = 6, 20
            L = J
            IF (RA(J1 - J) .NE. ICHAR(' ')) THEN
                IF (RA(J1 - J + 1) .NE. ICHAR(' ')) THEN
                  RA(J1 - J) = ICHAR(' ')
                  L = L + 1
                ENDIF
                RA(J1 - L) = ICHAR('0') + ISF2
                IF (ISF1 .NE. 0) RA(J1 - L - 1) = ICHAR('1')
                GOTO 240
            ENDIF
   90     CONTINUE
          GOTO 240
  100     J1 = J2
          GOTO 20
        ENDIF
C * HFIX MODE
      ELSE IF (MODE .EQ. 3) THEN
        NRES = 0
        J1   = IPR(200)
  110   J2   = J1 - 83
        IF (J2 .GE. IPR(201)) THEN
          WRITE (KEY, 99994) (CHAR(NINT(RA(J1 - J))), J = 1, 4)
          IF (KEY .EQ. 'RESI') THEN
            WRITE (RESD, 99994) (CHAR(NINT(RA(J1 - J))), J = 5, 8)
            READ (RESD, *) NRES
            GOTO 130
          ENDIF
          IF (NRES .NE. 0) THEN
            N = INDEX (LINE, '_')
            IF (N .GT. 0) THEN
              READ (LINE(N +1:), *) LRES
              IF (LRES .NE. NRES) GOTO 130
              LINE(N:) = ' '
            ENDIF
          ENDIF
          IF (KEY .NE. LINE(1:4)) GOTO 130
          IGBL(26)     = IGBL(26) + 1
          RA(J1 - 81)  = NRFIX
          IF (NFHAT .EQ. 0) THEN
            NSF        = NSF + 1
            SFC(NSF)   = 'H '
            NUNIT(NSF) = 1
            NFHAT      = 1
          ENDIF
  130     J1 = J2
          GOTO 110
        ENDIF
C * DELETE ATOMS
      ELSE IF (MODE .EQ. 4) THEN
        CALL GEN020 (1, LINE, 1, 7)
        J1 = IPR(200)
  140   J2 = J1 - 83
        IF (J2 .GE. IPR(201)) THEN
          WRITE (KEY, 99994) (CHAR(NINT(RA(J1 - J))), J = 1, 4)
          IF (KEY .NE. LINE(1:4)) GOTO 170
          IGBL(26) = IGBL(26) + 1
          RA(J1 - 82)   = -1
C * HANDLE EXTENSIONS (INDICATED BY '=')
          DO 160 J = 1, 80
            IF (RA(J1 - J) .EQ. ICHAR('=')) THEN
              J1 = J2
              J2 = J1 - 83
              RA(J1 - 82) = -1
            ENDIF
  160     CONTINUE
  170     J1 = J2
          GOTO 140
        ENDIF
C * ANIS - MODE
      ELSE IF (MODE .EQ. 5) THEN
        J1 = IPR(200)
  180   J2 = J1 - 83
        IF (J2 .GE. IPR(201)) THEN
          WRITE (KEY, 99994) (CHAR(NINT(RA(J1 - J))), J = 1, 4)
          IF (KEY .NE. LINE(1:4)) GOTO 200
          IGBL(26)     = IGBL(26) + 1
          RA(J1 - 83)  = 1
  200     J1 = J2
          GOTO 180
        ENDIF
      ELSE IF (MODE .EQ. -1) THEN
        IDEL = 0
        NR0  = -1
        J1   = IPR(200)
  210   J2   = J1 - 83
        IF (J2 .GE. IPR(201)) THEN
          DO 220 J = 1, 80
            LIN(J:J) = CHAR(NINT(RA(J1 - J)))
  220     CONTINUE
          CRDT = LIN(1:4)
          IF (CRDT .EQ. 'SFAC') THEN
            IF (IDEL .EQ. 0) WRITE (LU26, 99999) (SFC(I), I = 1, NSF)
            IDEL = 1
          ELSE IF (CRDT .EQ. 'UNIT') THEN
            WRITE (LU26, 99998) (NUNIT(I), I = 1, NSF)
            IDEL = 0
          ELSE IF (CRDT .EQ. 'AFIX') THEN
            READ (LIN(5:80), *) NR0
          ELSE IF (CRDT .EQ. 'HKLF') THEN
            NR0 = 0
            WRITE (LU26, 99996) NR0
            WRITE (LU26, 99993) LIN
            NR0 = -1
          ELSE
            IF (NINT(RA(J1 - 82)) .NE. 0) GOTO 230
            IF (IPR(176) .EQ. 1 .AND.
     1          LIN(1:1) .EQ. 'Q') GOTO 230
            IF (IDEL .EQ. 0) THEN
              NR = NINT(RA(J1 - 83))
              IF (NR .NE. 0) THEN
                CALL PLA280 (LIN)
                CALL PLA006 (1, IS)
                WRITE (LIN (6:), 99995) NINT(FN(1)),
     1            (FN(I), I = 2, 6), FN(6), FN(6), 0.0, 0.0, 0.0
              ENDIF
              NR = NINT(RA(J1 - 81))
              IF (NR .NE. 0) WRITE (LU26, 99997) NR, LIN(1:4)
              IF (NR0 .GE. 0) THEN
                WRITE (LU26, 99996) NR0
                NR0 = -1
              ENDIF
              WRITE (LU26, 99993) LIN
            ELSE IF (IDEL .LT. 0) THEN
              IDEL = 0
            ENDIF
          ENDIF
  230     J1 = J2
          GOTO 210
        ENDIF
      ELSE IF (MODE .EQ. 0 .AND. LINE(1:3) .NE. 'END') THEN
        IPR(200) = NPVD - 6
        IPR(201) = IPR(200)
        IGBL(26) = 0
        NSF      = 0
      ENDIF
  240 IF (IABS(IGBL(8)) .EQ. 2 .AND. IPR(80) .GT. IPR(201)) THEN
        STOP 'PLUT29'
      ENDIF
      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)
      END
      SUBROUTINE PLUT30 (ITS, ITF)
      PARAMETER (NP12=600,NP13=500,NP14=64,NP17=99,NP32=63,NP38=125,
     1 NP39=30)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLUTO/ IPPR(129, 3), IBT(32), TRL(3), ROM(3, 3), R(3, 3),
     1 RP(NP14), XJX(12), XXX(12), YYY(12), TMX(3, 3), SHFT(3),
     2 XYZOR(3), XYZR(3),  ZU(15), OM(3, 3), RCG(4, NP32), TMY(3, 3),
     3 XYZPL(6), A(3, 3), XYZK(8), KRS(NP32), NCRS(9), NPRS(17)
      IF (IPR(114) .GT. 0) THEN
        ITFF = MIN (ITF, IPR(114))
      ELSE
        ITFF = ITF
      ENDIF
      IF (ITS .LT. ITFF) THEN
        DTH1     = PAR(57) + ITS  * PAR(55)
        DTH2     = PAR(57) + ITFF * PAR(55)
        N        = MAX (1, NINT((DTH2 - DTH1) / PAR(56)))
        DTHS     = (DTH2 - DTH1) / N
        IPR(129) = IPR(129) + N
        XO       = PAR(71)
        YO       = PAR(72)
        ZO       = PAR(73)
        RO       = PAR(74)
        IUP      = 1
   10   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
        DTH1     = DTH1 + DTHS
        IF (N .GT. 0) THEN
          N = N - 1
          GOTO 10
        ENDIF
      ENDIF
      RETURN
      END
      SUBROUTINE PLUT31 (K, COLR)
      PARAMETER (NP0=6, NPVD=40000000, NP23=18000)
      COMMON // MOL(2, NP23), RA(NPVD)
      DSH = 0.15
      K0  = K + NP0
      X   = RA(K0 - 3)
      Y   = RA(K0 - 2)
      Z   = RA(K0 - 1)
      COL = COLR
      IF (COL .GE. 0.0) CALL GGIP (0.0, COL, 0.0, 0)
      CALL GGIP (X,       Y + DSH, Z, 3)
      CALL GGIP (X + DSH, Y,       Z, 2)
      CALL GGIP (X,       Y - DSH, Z, 2)
      CALL GGIP (X - DSH, Y,       Z, 2)
      CALL GGIP (X,       Y + DSH, Z, 2)
      RETURN
      END
      SUBROUTINE PLUT32
      PARAMETER (NP4=9,NP9=118,NP10=16,NP12=600,NP13=500,NP17=99,
     1 NPVD=40000000,NP22=256,NP23=18000,NP38=125,NP39=30,NP43=12,
     2 NP45=2048)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON // MOL(2, NP23), RA(NPVD)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /Q/ ICL, IFL(NP17)
      COMMON /XCH/ LINE, IDM, JID, DID, NAMS, NQ1, NQ2, NQ3, NQ4,
     1 TKST(250), KRAD, JTP(8), LMT(NP10, 2), DATANM, CCIF, RLWS,
     2 CHSG, ISWS, PRBUF, SPGRNM, ZSPG, KRSYST, LAUEGR, DTYPE
      CHARACTER NAMS(NP4, 4)*8, NQ1*7, NQ2*7, NQ3*7, NQ4*7,
     1 DID*9, ICL*(NP45), IDM*80, JTP*2, LMT*2, LINE*80,  ISWS(NP22)*4,
     2 TKST*10, JID*80, DATANM*32, PRBUF*132, IFL*7, DTYPE(6)*5,
     3 KRSYST*12, LAUEGR*5, KRAD*4, CCIF(20)*17, RLWS(5)*80,
     4 CHSG*6, ZSPG*7, SPGRNM(4)*26
      COMMON /ATMDT/ IAN, ICLR, AMR(NP9, 3), IATPR(NP9), IATNR(NP9),
     1 ATWT(NP9), VDWR(NP9), IEL(NP9), REL(NP9), RNSCL(NP9), IACL(NP10),
     2 IEN(NP10), IBCL(NP10), IENS(NP10), IENLB(NP10), IDOAC(NP10),
     3 RADR(NP10, 4), SATWT(NP10), JACL(NP10), RGB(3, NP10), SFAC(1770)
      COMMON /CGGT/ IGGT
      CHARACTER IGGT*80
      COMMON /NKEYS/ NCNT
      COMMON /CGG11/ BCD, SBCD
      CHARACTER BCD*132, SBCD*132
      CHARACTER RIFL2*10, RIFL3*10
      COMMON /XWDW/ LRET, IWIN, HORS, VERT, HRT, VRT, VRTS, XSH0, YSH0
      KL        = IPR(220)
      IGBL(105) = 1
      IF (KL .GT. 2) THEN
        DO 20 I = 3, KL, 2
          CALL PLUT13 (0, I - 1, IAT, XDUM)
          IF (IAT .GT. 0) THEN
            CALL PLA046 (8, IFL(I - 1), NEI, NA, NAX, NS,
     1                   XPK1, XPK2, NIEN)
            CALL PLUT13 (1, I, JAT, XDUM)
            IF (JAT .LE. 0) THEN
              IF (IFL(I)(1:3) .EQ. 'REN') THEN
                WRITE (LU6, 99997) IFL(I)
                GOTO 100
              ELSE
                CALL PLA046 (9, IFL(I), NE, NQX, NSS, NQSM,
     1                       XNQNR, YNQNR, NIEN)
                IF (NE .NE. NEI) IPR(170) = 2
                YUNK = RA (IAT * NP43 + 7)
                DO 10 J = 1, IPR(37)
                  IF (RA(J * NP43 + 7) .EQ. YUNK)
     1                RA(J * NP43 + 7) = XNQNR
   10           CONTINUE
                IF (RADR(NE, 3) .LT. 0.001) RADR(NE, 3) =
     1              REL(IEN(NE))
                WRITE (LU27, 99972) IFL(I - 1), IFL(I)
                IF (IABS(IGBL(8)) .EQ. 2)
     1            CALL PLUT29 (2, IFL(I - 1), IFL(I), 0)
                CALL PLUT15 (1, IAT, 47, 1)
              ENDIF
            ELSE
                WRITE (LU6, 99969) IFL(I), IFL(I - 1)
                GOTO 100
            ENDIF
          ELSE
            WRITE (LU6, 99998) IFL(I)
            GOTO 100
          ENDIF
   20   CONTINUE
      ELSE IF (KL .LE. 2) THEN
        CALL PLUT24 (-2, IPR(38), IDUM)
        NCNT = 0
        IAT1 = 0
        IF (KL .EQ. 2) CALL PLUT13 (0, 2, IAT1, XDUM)
        IF (IAT1 .GT. 0) THEN
          IBEG = IAT1
          IEND = IAT1
        ELSE
          IBEG = IPR(69) + 1
          IEND = IPR(39)
        ENDIF
        DO 90 I = IBEG, IEND
          CALL PLUT15 (-4, I, 37, M)
          IF (M .GT. 1) THEN
            IF (IPR(140) .NE. 0) THEN
              CALL PLUT15 (-6, I, 5, IVAL)
              IF (IVAL .NE. IPR(140)) GOTO 90
            ENDIF
            IAT = I
            CALL PLUT25 (1, IAT, IATK)
            IF (IAT1 .GE. 0 .OR. -IAT1 .EQ. IATK) THEN
              CALL PLA046 (8, NQ1, NEI, NA, NAX, NS,
     1                     XPK1, XPK2, NIEN)
              IFL(2)   = NQ1
              IFL(3)   = NQ1
              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)
   30         IF (IGBL(25) * IGBL(32) .EQ. 1) THEN
                PAR40 = NE * PAR(349) * PAR(19) / 2.0
                NATL  = IPR(62) + I
                CALL PLUT14 (-1, NATL, IASU, NPROP, XL, YL, ZL, RL)
                CALL GGIP20 (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)
   40           CALL PLA013 (0, 1)
                IF (IGGT(1:3) .EQ. 'REN') THEN
                  IF (IGGT(8:8) .NE. ' ') GOTO 40
                  IGGT(1:5)   = '     '
                  IFL(3)(1:1) = IFL(2)(1:1)
                ELSE IF (IGGT(1:1) .EQ. '!') THEN
                  IF (LRET .EQ. 2) THEN
                    CALL PLUT02
                    GOTO 30
                  ENDIF
                ELSE IF (IGGT(1:4) .EQ. 'VIEW') THEN
                  CALL PLA006 (1, IS)
                  CALL PLUT06
                  CALL PLUT02
                  GOTO 30
                ELSE IF (IGGT(1:4) .EQ. 'PLOT') THEN
                  CALL PLUT02
                  GOTO 30
                ELSE IF (
     1            IGGT(1:3) .EQ. 'LAB' .OR. IGGT(1:3) .EQ. 'ARU' .OR.
     2            IGGT(1:3) .EQ. 'OMI' .OR. IGGT(1:3) .EQ. 'HFI') THEN
                  GOTO 30
                ELSE IF (IGGT(1:3) .EQ. 'END') THEN
                  IFL(3)(1:4) = 'QUIT'
                ELSE IF (IGGT(1:4) .EQ. 'EXIT') THEN
                  IFL(3)(1:4) = 'QUIT'
                ELSE
                  CALL GEN105 (3, IGGT(1:1), N)
                  IF (N .LT. 0) THEN
                    IFL(3) = IGGT(1:7)
                  ELSE
                    CALL GEN105 (3, IFL(2)(2:2), N)
                    IF (IFL(2)(2:2) .EQ. ' ' .OR. N .GE. 0) THEN
                      IFL(3) = IFL(2)(1:1)//IGGT(1:6)
                    ELSE
                      IFL(3) = IFL(2)(1:2)//IGGT(1:5)
                    ENDIF
                  ENDIF
                  CALL GEN038 (IGGT, 1, 80)
                ENDIF
              ELSE
                WRITE (LU6, 99965) IFL(2), IFL(2)
                READ  (LU5, 99995) IFL(3)
              ENDIF
              CALL GEN020 (1, IFL(3), 1, 7)
              IF (IFL(3)(1:4) .EQ. 'QUIT' .OR. IFL(3)(1:3) .EQ. 'END')
     1          THEN
                CALL PLA280 ('PLOT')
                IPR(335) = 1
                CALL PLA015 (335, 1)
                GOTO 100
              ENDIF
              CALL GEN020 (-1, IFL(3), 2, 2)
              NEE = NEI
              IF (IFL(3) .NE. IFL(2) .AND. IFL(3)(1:1) .NE. ' ') THEN
   50           CALL PLUT13 (1, 3, JAT, XDUM)
                CALL PLA046 (9, IFL(3), NEE, NQX, NSS, NQSM,
     1                       XNQNR, YNQNR, NIEN)
                IF (JAT .LE. 0) THEN
                  IF (NIEN .GE. 0) THEN
                    IF (NEE .NE. NEI) IPR(170) = 2
                    YUNK = RA (IAT * NP43 + 7)
                    DO 60 J = 1, IPR(37)
                      IF (RA(J * NP43 + 7) .EQ. YUNK)
     1                    RA(J * NP43 + 7) = XNQNR
   60               CONTINUE
                    IF (RADR(NEE, 3) .LT. 0.001)
     1                  RADR(NEE, 3) = REL(IEN(NEE))
                    WRITE (LU27, 99972) IFL(2), IFL(3)
                    IF (IABS(IGBL(8)) .EQ. 2)
     1                CALL PLUT29 (2, IFL(2), IFL(3), 0)
                    CALL GGIP20 (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
                    CALL PLA015 (0, 28)
                    GOTO 30
                  ENDIF
                ELSE
                  J1 = IEL(IEN(NEE)) / 100
                  J2 = MOD(IEL(IEN(NEE)), 100)
                  IF (J2 .EQ. 0) THEN
                    JM = 900
                  ELSE
                    JM = 90
                  ENDIF
                  DO 80 J = 1, JM
                    IF (J2 .EQ. 0) THEN
                      WRITE (IFL(4), 99999)
     1                  CHAR(ICHAR('A') + J1 - 1), 1000 - J
                    ELSE
                      WRITE (IFL(4), 99996)
     1                  CHAR(ICHAR('A') + J1 - 1),
     2                  CHAR(ICHAR('a') + J2 - 1), 100 - J
                    ENDIF
                    CALL PLUT13 (1, 4, KAT, XDUM)
                    IF (KAT .LE. 0) THEN
                      CALL PLA046 (9, IFL(4), NE4, NQX, NSS, NQSM,
     1                             XNQNR, YNQNR, NIEN)
                      YUNK = RA (JAT * NP43 + 7)
                      DO 70 K = 1, IPR(37)
                        IF (RA(K * NP43 + 7) .EQ. YUNK)
     1                      RA(K * NP43 + 7) = XNQNR
   70                 CONTINUE
                      WRITE (LU27, 99972) IFL(3), IFL(4)
                      IF (IABS(IGBL(8)) .EQ. 2)
     1                  CALL PLUT29 (2, IFL(3), IFL(4), 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,
     1                             ZL, RL)
                      CALL GGIP20 (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 GGIP20 (0.0, IFL(4), NE, PAR(349), 1, 2,
     1                             XLZ - PAR40, YLZ - PAR(28))
                      GOTO 50
                    ENDIF
   80             CONTINUE
                  CALL PLA015 (0, 8)
                  WRITE (LU6, 99969) IFL(3), IFL(2), CHAR(7)
                  GOTO 30
                ENDIF
              ENDIF
              IF (NEE .NE. NEI) THEN
                CALL PLUT02
              ELSE
                CALL GEN020 (-1, IFL(3), 2, 2)
                CALL PLUT15 (-1, IAT, 47, IREN)
                ICOL = 1
                IF (IREN .EQ. 1) ICOL = 3
                CALL GGIP20 (0.0, IFL(3), NE, PAR(349), ICOL, 2,
     1                       XL - PAR40, YL - PAR(28))
              ENDIF
            ENDIF
          ENDIF
   90   CONTINUE
        IF (IEND .GT. IBEG) THEN
          IPR(332)  = 1
          CALL PLA015 (335, 1)
          IF (IPR(308) .NE. 0) IGBL(3) = 8
        ENDIF
      ENDIF
  100 CONTINUE
      RETURN
99999 FORMAT (A, I3)
99998 FORMAT (':: No Substitution: Unsuitable Old Label: ', A)
99997 FORMAT (':: No Substitution: Unsuitable New Label: ', A)
99996 FORMAT (2A, I2)
99995 FORMAT (A)
99972 FORMAT ('RENAME', 2(1X, A))
99969 FORMAT (':: No Substitution: New Label: ', A, 'for: ', A,
     1        'conflicts with label in list', A)
99965 FORMAT (/, 'Rename ', A, ' (NewName/Quit[', A, '])', $)
      END
      SUBROUTINE PLUT33
      PARAMETER (NP12=600,NP13=500,NP17=99,NPVD=40000000,
     1 NP23=18000,NP38=125,NP39=30,NP43=12)
      COMMON // MOL(2, NP23), RA(NPVD)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      DIMENSION YANK(NP43)
      IPR(64)   = IPR(80) - IPR(76) * 3
      IPR(100)  = 1
      ID1       = 0
      ID2       = 0
      IF (IPR(50) .EQ. 0)
     1  CALL PLUT16 (-2, IDUM0, ID1, ID2, DUM1, IDUM2)
      IF (IGBL(33) .EQ. 1) THEN
        N0      = IPR(69) + 1
        N       = IPR(37)
        NEL     = N - N0 + 1
        IF (NEL .LE. 1) GOTO 50
        NN      = INT(ALOG(FLOAT(NEL)) / ALOG(2.0))
        ND      = 2**NN - 1
   10   IF (ND .LE. 0) GOTO 50
        I       = N0
   20   J       = I
        DO 25 K = 1, NP43
          YANK(K) = RA((I + ND) * NP43 + K)
   25   CONTINUE
   30   IF (YANK(6) .GE. RA(J * NP43 + 6)) GOTO 40
        DO 35 K = 1, NP43
          RA((J + ND) * NP43 + K) = RA(J * NP43 + K)
   35   CONTINUE
        J = J - ND
        IF (J .GE. N0) GOTO 30
   40   DO 45 K = 1, NP43
          RA((J + ND) * NP43 + K) = YANK(K)
   45   CONTINUE
        I = I + 1
        IF (I + ND .LE. N) GOTO 20
        ND = (ND - 1) / 2
        GOTO 10
      ENDIF
   50 CONTINUE
      RETURN
      END
      SUBROUTINE PLUT35 (XMOL, MODE)
      PARAMETER (NP12=600,NP13=500,NP17=99,NPVD=40000000,NP23=18000,
     1 NP38=125,NP39=30,NP45=2048)
      COMMON // MOL(2, NP23), RA(NPVD)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      DIMENSION XX(12)
      CHARACTER ICL*(NP45)
      IF (ABS(XMOL) .LE. IPR(75) .OR. IPR(73) .NE. 0) THEN
        CALL PLUT17 (XMOL, MODE, MADDR, LU6)
        GOTO 30
      ENDIF
      IF (XMOL .GT. 0) THEN
        MSGN = 1
      ELSE
        MSGN = -1
      ENDIF
      NMOL = NINT (ABS(XMOL) * PAR(42))
      CALL GEN098 (NMOL, PAR(42), MS1, MT1, MT2, MT3, MR1)
      IF (MR1 .NE. 0) THEN
        NB = MR1
        NE = MR1
      ELSE
        NB = 1
        NE = IPR(75)
      ENDIF
      DO 20 MR1 = NB, NE
        DO 10 I = 1, IPR(43)
          MPM = MOL(1, I)
          CALL GEN098 (MPM, PAR(42), MS2, ITX, ITY, ITZ, MR2)
          XX(6) = ITX
          XX(7) = ITY
          XX(8) = ITZ
          IF (MR2 .EQ. MR1) THEN
            XX(1) = MS1
            XX(2) = MT1
            XX(3) = MT2
            XX(4) = MT3
            XX(5) = MS2
            CALL SGSM (ICL, 0, XX, LU6, 8, IERR)
            IF (IERR .NE. 0) THEN
              WRITE (LU6, 99999) XMOL
              GOTO 30
            ENDIF
            MS3  = NINT(XX(9))
            MT13 = NINT(XX(10))
            MT23 = NINT(XX(11))
            MT33 = NINT(XX(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)
          ENDIF
   10   CONTINUE
   20 CONTINUE
   30 RETURN
99999 FORMAT ('Multiply Problem with ARU = ', F10.2)
      END
      SUBROUTINE PLUT36 (MODE, ISHADE)
      PARAMETER (NP12=600,NP13=500,NP14=64,NP17=99,NP32=63,NP38=125,
     1 NP39=30)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLUTO/ IPPR(129, 3), IBT(32), TRL(3), ROM(3, 3), R(3, 3),
     1 RP(NP14), XJX(12), XXX(12), YYY(12), TMX(3, 3), SHFT(3),
     2 XYZOR(3), XYZR(3),  ZU(15), OM(3, 3), RCG(4, NP32), TMY(3, 3),
     3 XYZPL(6), A(3, 3), XYZK(8), KRS(NP32), NCRS(9), NPRS(17)
      DO 20 ISH = 1, ISHADE
        ICOL2 = MOD(IPR(88), 100)
        IF (ICOL2 .GT. 8) ICOL2 = 0
        IANG2 = IPR(88) / 100
        ANG3  = PAR(8) + MOD(IANG2, 100)
        IANG2 = IANG2 / 100
        IHOR  = 1
        IF (ANG3 .NE. 0.0) THEN
          ANG3 = ANG3 / GL(5)
          CB   = COS (ANG3)
          SB   = SIN (ANG3)
          IHOR = 0
        ELSE
          CB   = 1.0
          SB   = 0.0
        ENDIF
        IF (PAR(7) .NE. 0.0) THEN
          CA   = COS (PAR(7) / GL(5))
          IHOR = 0
        ELSE
          CA = 1.0
        ENDIF
        NN    = 1
        DISP  = PAR(6)
        IF (PAR(48) .GT. 0.0)
     1    DISP = DISP * PAR(48) / (PAR(48) - XYZK(3))
        DISP = MAX (DISP, PAR(23))
        IF (IPR(346) .GT. 0) THEN
          CALL GGIP (0.0, FLOAT(ICOL2), 0.0, 0)
        ENDIF
        R0  = XYZK(4)
        R0K = R0**2
        YS = - R0
   10   RSQ = R0K - YS**2
        IF (RSQ .GT. 0.0001) THEN
          R1 = SQRT(RSQ)
          IF (IHOR .EQ. 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
          ENDIF
          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)
          CALL PLUT19 (MODE, NN)
          NN = - NN
        ENDIF
        YS = YS + DISP
        IF (YS .LT. R0)  GOTO 10
        IF (IPR(346) .GT. 0) CALL GGIP (0.0, FLOAT(IPR(19)), 0.0, 0)
        PAR(8) = PAR(8) + 90.0
   20 CONTINUE
      RETURN
      END
      SUBROUTINE PLUT37 (IAT, JAT, KAT, LAT, OMEGA)
      PARAMETER (NP12=600,NP13=500,NP14=64,NP17=99,NPVD=40000000,
     1 NP23=18000,NP32=63,NP38=125,NP39=30,NP43=12)
      COMMON // MOL(2, NP23), RA(NPVD)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLUTO/ IPPR(129, 3), IBT(32), TRL(3), ROM(3, 3), R(3, 3),
     1 RP(NP14), XJX(12), XXX(12), YYY(12), TMX(3, 3), SHFT(3),
     2 XYZOR(3), XYZR(3),  ZU(15), OM(3, 3), RCG(4, NP32), TMY(3, 3),
     3 XYZPL(6), A(3, 3), XYZK(8), KRS(NP32), NCRS(9), NPRS(17)
      IF (LAT .EQ. 0) THEN
        DAK = 0
        DBK = 0
        DAB = 0
        DO 10 KK = 4, 6
          VA  = RA(IAT * NP43 + KK) - RA(JAT * NP43 + KK)
          VB  = RA(KAT * NP43 + KK) - RA(JAT * NP43 + KK)
          DAK = DAK + VA**2
          DBK = DBK + VB**2
          DAB = DAB + VA*VB
   10   CONTINUE
        IF (DAK .LE. 0.0 .OR. DBK .LE. 0.0) THEN
          OMEGA = 0.0
        ELSE
          DAB   = MAX (-1.0, MIN (1.0, DAB / SQRT(DAK * DBK)))
          OMEGA = ACOS(DAB) * GL(5)
        ENDIF
      ELSE
        DO 20 N = 1, 3
          ZU(N)     = RA(JAT * NP43 + N + 3) - RA(IAT * NP43 + N + 3)
          ZU(N + 3) = RA(KAT * NP43 + N + 3) - RA(JAT * NP43 + N + 3)
          ZU(N + 6) = RA(LAT * NP43 + N + 3) - RA(KAT * NP43 + N + 3)
   20   CONTINUE
        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) * GL(5)
        IF (GEN009 (ZU(1), ZU(4)) .LT. 0.0) OMEGA = - OMEGA
      ENDIF
      RETURN
      END
      SUBROUTINE PLUT38 (NER, NERR, LU)
      IF (NER .EQ. 1) THEN
        WRITE (LU, 99999)
      ELSE IF (NER .EQ. 2) THEN
      ELSE IF (NER .EQ. 3) THEN
        WRITE (LU, 99997)
      ELSE IF (NER .EQ. 4) THEN
        WRITE (LU, 99996)
        WRITE (LU, 99995)
      ELSE IF (NER .EQ. 5) THEN
        WRITE (LU, 99994)
      ELSE IF (NER .EQ. 6) THEN
        WRITE (LU, 99993) CHAR(7)
      ELSE IF (NER .EQ. 7) THEN
        WRITE (LU, 99992)
      ELSE IF (NER .EQ. 8) THEN
      ELSE IF (NER .EQ. 9) THEN
      ELSE IF (NER .EQ. 10) THEN
      ENDIF
      IF (NERR .EQ. 1) STOP ' FATAL PROBLEM'
      RETURN
99999 FORMAT (/'>>> PROBLEM TOO LARGE; INCREASE ARRAY SIZE (NPVD) <<<')
99997 FORMAT (/'>>> STACK1 OVERFLOW;  INCREASE ARRAY SIZE (NPVD) <<<')
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)
99992 FORMAT (/':: Too Many FVAR - Parameters')
      END
      SUBROUTINE PLUT39
      PARAMETER (NP12=600,NP13=500,NP14=64,NP17=99,NPVD=40000000,
     1 NP23=18000,NP32=63,NP38=125,NP39=30,NP43=12,NP45=2048)
      COMMON // MOL(2, NP23), RA(NPVD)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLUTO/ IPPR(129, 3), IBT(32), TRL(3), ROM(3, 3), R(3, 3),
     1 RP(NP14), XJX(12), XXX(12), YYY(12), TMX(3, 3), SHFT(3),
     2 XYZOR(3), XYZR(3),  ZU(15), OM(3, 3), RCG(4, NP32), TMY(3, 3),
     3 XYZPL(6), A(3, 3), XYZK(8), KRS(NP32), NCRS(9), NPRS(17)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /Q/ ICL, IFL(NP17)
      CHARACTER ICL*(NP45), IFL*7
      COMMON /PLXXX/ DLIM(3), T(3), XJS(3), SEP(3), XYZJS(3)
      CHARACTER N1*1
      MODE     = 0
      IPR(130) = 0
      NSYM     = IPR(48)
      NRES     = IPR(75)
      KL       = IPR(220)
      KN       = IPR(221)
      CALL GEN074 (PAR, -0.01, 119, 121)
      CALL GEN074 (PAR,  0.01, 122, 124)
      RA(IPR(80) + 5) = -1.5
      RA(IPR(80) + 6) =  1.5
      LL  = 1
      KKK = 0
   20 LL  = LL + 1
      IF (LL .GT. KL)  GOTO 80
      N1 = IFL(LL)(1:1)
      IF (N1 .EQ. 'R') THEN
        DO 40 KK = 1, 3
          IF (KKK + 2 .LE. KN) THEN
            PAR(118 + KK) = FN(KKK + 1)
            PAR(121 + KK) = FN(KKK + 2)
          ENDIF
          KKK = KKK + 2
   40   CONTINUE
        IPR(126) = 1
      ELSE IF (N1 .EQ. 'P') THEN
        IPR(36) = 1
        IF ((KN - 3) .LT. KKK)  GOTO 20
        DO 60 K = 1, 3
          KKK = KKK + 1
          IPR(31 + K) = NINT(FN(KKK))
   60   CONTINUE
        IF ((KN - 2) .LT. KKK)  GOTO 20
        RA(IPR(80) + 5) = FN(KKK + 1)
        RA(IPR(80) + 6) = FN(KKK + 2)
        KKK = KKK + 2
      ELSE IF (N1 .EQ. 'C') THEN
        IPR(31) = 1
        CALL PLUT13 (0, KL, MODE, XDUM)
        IPR(220) = IPR(220) - 1
        KL       = IPR(220)
        IF (MODE .LE. 0)  GOTO 210
      ENDIF
      GOTO 20
   80 IF (IPR(126) .EQ. 0) THEN
        IF (IPR(36) .GT. 0) THEN
          CMIA = 0
        ELSE
          CMIA = 2
        ENDIF
        CMIN = -2
        CMAX =  3
        DO 90 K = 1, 3
          PAR(118 + K) = CMIN + CMIA
          PAR(121 + K) = CMAX - CMIA
   90   CONTINUE
      ENDIF
      CALL PLUT17 (0.0, 3, MADDR, LU6)
      DO 200 NRS = 1, NRES
        DO 110 K = 1, 3
          XJX(K + 3) = 0.0
          IF (MODE .EQ. 0) THEN
            XJX(K) = RCG(K, NRS)
          ELSE
            XJX(K) = RA(MODE * NP43 + K)
          ENDIF
          XXX(K) = XJX(K)
  110   CONTINUE
        IF (IPR(36) .GT. 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 120 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) * XXX(K)
  120     CONTINUE
        ENDIF
        DO 190 N = 1, NSYM
          CALL SGSM (ICL, N, XJX, LU6, 3, IERR)
          DO 130 K = 1, 3
            T(K)     = 0.0
            XYZOR(K) = XJX(K + 6)
  130     CONTINUE
          K = 1
  140     IF (XYZOR(K) .LT. PAR(K + 118))  GOTO 150
          XYZOR(K) = XYZOR(K) - 1.0
          T(K) = T(K) - 1.0
          GOTO 140
  150     XYZOR(K) = XYZOR(K) + 1.0
          T(K)     = T(K) + 1.0
          IF (XYZOR(K) .GT. PAR(K + 121))  GOTO 180
          K = K + 1
          IF (K .LE. 3)  GOTO 140
          DO 160 KK = 1, 3
            ITKK = NINT(T(KK))
            IF (ITKK .GT. 4 .OR. ITKK .LT. -5) GOTO 170
  160     CONTINUE
          MML = N * 1000 + NINT(T(1)) * 100 + NINT(T(2)) * 10
     1        + NINT(T(3)) + 555
          XML = MML + NRS / PAR(42)
          CALL PLUT35 (XML, 0)
  170     K = K - 1
          GOTO 150
  180     K = K - 1
          IF (K .GT. 0)  GOTO 150
  190   CONTINUE
  200 CONTINUE
  210 IPR(36) = 0
      RETURN
      END
      SUBROUTINE PLUT40 (I, J, N, ISW)
      PARAMETER (NP12=600,NP13=500,NP14=64,NP17=99,NPVD=40000000,
     1 NP23=18000,NP32=63,NP38=125,NP39=30,NP43=12,NP45=2048)
      COMMON // MOL(2, NP23), RA(NPVD)
      COMMON /P/ IPR(NP12), PAR(NP13), FN(NP17), GL(NP39), IGBL(NP38)
      COMMON /PLUTO/ IPPR(129, 3), IBT(32), TRL(3), ROM(3, 3), R(3, 3),
     1 RP(NP14), XJX(12), XXX(12), YYY(12), TMX(3, 3), SHFT(3),
     2 XYZOR(3), XYZR(3),  ZU(15), OM(3, 3), RCG(4, NP32), TMY(3, 3),
     3 XYZPL(6), A(3, 3), XYZK(8), KRS(NP32), NCRS(9), NPRS(17)
      COMMON /FILES/ LU1, LU2, LU3, LU4, LU5, LU6, LU7, LU8, LU9, LU10,
     1 LU11, LU12, LU13, LU14, LU15, LU16, LU17, LU18, LU19, LU20,
     2 LU21, LU22, LU23, LU24, LU25, LU26, LU27, LU28, LU29, LU30, LU31,
     3 LU60, LU61, LU62, LU63, LU64, LU65
      COMMON /Q/ ICL, IFL(NP17)
      CHARACTER ICL*(NP45), IFL*7
      COMMON /PLXXX/ DLIM(3), T(3), XJS(3), SEP(3), XYZJS(3)
      NATO = IPR(39)
      ISW  = -1
      CALL PLUT15 (-1, I, 44, IHAT)
      IF (IHAT .EQ. 1) THEN
        IF (IPR(109) .EQ. 1) THEN
          CALL PLUT15 (-1, I, 32, IDH)
        ELSE
          IDH = 1
        ENDIF
        IF (IDH .GT. 0) THEN
          DO 10 K = 1, 3
            XJX(K)     = RA(J * NP43 + K)
            XJX(K + 3) = T(IPR(120 + K))
   10     CONTINUE
          CALL SGSM (ICL, N, XJX, LU6, 3, IERR)
          DO 20 K = 1, 3
            RA(K) = XJX(K + 6)
   20     CONTINUE
          CALL PLUT23 (0)
          DO 30 I0 = IPR(69) + 1, NATO
            CALL PLUT22 (I0, I, D)
            IF (D .LT. 1.25) THEN
              CALL PLUT37 (I0, I, 0, 0, ANG)
              IF (ANG .GE. PAR(97)) ISW = 1
              GOTO 80
            ENDIF
  30      CONTINUE
        ENDIF
      ELSE
        CALL PLUT15 (-1, J, 32, JDH)
        IF (JDH .GT. 0) THEN
          XJX(1) = N
          DO 40 K = 1, 3
            XJX(K + 1) = T(IPR(120 + K))
  40      CONTINUE
          CALL SGSM (ICL, 0, XJX, LU6, 9, IERR)
          DO 50 K = 1, 3
            XJX(K)     = RA(I * NP43 + K)
            XJX(K + 3) = XJX(9 + K)
  50      CONTINUE
          M = NINT(XJX(9))
          CALL SGSM (ICL, M, XJX, LU6, 3, IERR)
          DO 60 K = 1, 3
            RA(K) = XJX(6 + K)
  60      CONTINUE
          CALL PLUT23 (0)
          DO 70 J0 = IPR(69) + 1, NATO
            CALL PLUT22 (J0, J, D)
            IF (D .LT. 1.25) THEN
              CALL PLUT37 (J0, J, 0, 0, ANG)
              IF (ANG .GE. PAR(97)) ISW = 1
              GOTO 80
            ENDIF
  70      CONTINUE
        ENDIF
      ENDIF
  80  CONTINUE
      RETURN
      END
      SUBROUTINE S
      RETURN
      END
      SUBROUTINE S931
      RETURN
      END
      SUBROUTINE SGSM (LIN, NRSYM, X, IOUT, ISWITS, IERROR)
      PARAMETER (NRSPGR = 336, NTRL = 174, NOPR = 18, NSITE = 70,
     1  NNH = 168)
C **********************************************************************
C *                   (C) 1980 - 2005, 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 *          CYBER       IMPLEMENTATION             AUG 1980           *
C *          MICROVAX-II IMPLEMENTATION             AUG 1986           *
C *          UNIX        IMPLEMENTATION                 1990           *
C *          DEC5000     IMPLEMENTATION                 1991           *
C *          LINUX/PC    IMPLEMENTATION                 1993           *
C *                                                                    *
C *          VERSION   6-04-2005                                       *
C **********************************************************************
C * ISW = 0  - ACTUAL SWITCH DERIVED FROM KEYWORD IN LINE              *
C * ISW = 1  - LATTICE INIT INSTRUCTION "LATT P A"                     *
C * ISW = 2  - LOAD SYMM.CODE IN STRING LINE FOR PRINTING OF SYMM OPER.*
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 - (ERROR) RETURN                                          *
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 * 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 *                                                                    *
C * ISW =      NEGATIVE: LAUE/PATT SYMMETRY                            *
      COMMON /CSPGR/ IS(3, 3, 48), ISBRV(4, 3), ISGNR, NSYMP, ICNTR,
     1 IBV, IKLS, LAUE, IR(3, 3, 195), ISV(3), IABC(6), JABC(6),
     2 R0(3, 3), R1(3, 3), R2(3, 4), R3(3, 3), T0(3), T3(3), OSFT(3),
     3 IINV, ISW, IBV0(7), IBV1(7), IBV2(18), ILAUE, IAXM, KSITE(NSITE),
     4 IOPR(NOPR), IORG(3, 3), JSMI, JSMX, NST, ISWD, JSWD, NSG(28),
     5 ITRNS, ICNTRX, IMPROP, IUIT, OCNT(3), NHRM(198), IHALL(9, 4),
     6 LRET, NSLOC(59), NSGF(230), NSGET, NTRNS, JLAUE, ISHEL, ITRL, IER
      COMMON /CSGSM/ ICH(43), SGT, NONST, NOSTP, SGSMC, YSPG, ZSPG,
     1 NHLA, NHLB, TRLTA, TRLTB, LINE, SHFL
      COMMON /SLAUE/ NLAUE, XSYST, IBVL, SITE
      CHARACTER SGT(NRSPGR)*32, LINE*80, LIN*(*), NONST(294)*9, ICH*1,
     1 IBRAV*1, NOSTP(6)*4, YSPG*9, ZSPG*13, NLAUE(14)*5, XSYST(8)*12,
     2 IBVL(8)*1, SGSMC*59, SITE(NSITE)*5, BLT*1, XCHAR*1, SHFL(230)*6,
     3 TRLTA(NTRL)*13, TRLTB(NTRL)*7, NHLA(NNH)*7, NHLB(NNH)*15
      DIMENSION X(12), XSAV(3), YAV(3)
      CHARACTER OLAT*2
      ILAUE = ISIGN (1, ISWITS)
      ISW   = IABS(ISWITS)
      IUIT  = IOUT
      LINM  = MIN (80, LEN(LIN))
      LINE  = LIN(1:LINM)
      NSM   = NRSYM
      IER   = 0
      NIC   = 3
      NICM  = 3
      FLT   = 0.0
      N     = 195
      ISWD  = 1
      NSLPM = 1
      ITRNS = 0
      NTRNS = 0
      ISHEL = 0
      ITRL  = 0
      ISNN  = 0
      IN    = 0
      JS    = 0
      NSLP  = 0
      KTRV  = 0
      NSGET = 0
      TRDET = 1.0
      LRET  = 3
C * HANDLE SPECIAL SWITCHES FIRST
C * ISW = 0 : INTERPRETE INFORMATION IN LINE FOR ISW = 0 CASE
   10 IF (ISW .EQ. 0) THEN
        CALL GEN020 (1, LINE, 1, 80)
        IF (LINE(1:4) .EQ. 'LATT') THEN
          CALL GEN038 (SGSMC, 1, 59)
          ISW = 10
        ELSE IF (LINE(1:4) .EQ. 'SYMM') THEN
          CALL GEN047 (LINE,   4, 80)
          CALL GEN038 (SGSMC,  1, 11)
          CALL GEN038 (SGSMC, 15, 59)
          ISW = 11
        ELSE IF (LINE(1:4) .EQ. 'SPGR') THEN
          ISW = 12
        ELSE IF (LINE(1:4) .EQ. 'HALL') THEN
          ISW = 21
        ELSE
          ISW = 13
          GOTO 510
        ENDIF
        GOTO 10
C * SWITCH SELECTION
C * ISW = 1, (GENERAL) LATTICE INIT ETC. - GET TRANSFORMATION MATRIX
      ELSE IF (ISW .EQ. 1) THEN
        CALL SG03 (X, TRDET, 1)
C * ISW = 2: PRINT SYMM (X,Y,Z)
      ELSE IF (ISW .EQ. 2) THEN
        GOTO 210
C * ISW = 3: COORDINATE TRANSFORMATION
      ELSE IF (ISW .EQ. 3) THEN
        ISWD = 1
        CALL SG09 (X, NSM)
C * ISW = 4: PRINT SYMM (H,K,L)
      ELSE IF (ISW .EQ. 4) THEN
        GOTO 210
C * ISW = 5: HKL TRANSFORMATION
      ELSE IF (ISW .EQ. 5) THEN
        ISWD = -1
        CALL SG09 (X, NSM)
C * ISW = 6 : LOAD ROTATION MATRIX IN X(1:9) AND TRANSLATION VECTOR
C *           IN X(10:12)
      ELSE IF (ISW .EQ. 6) THEN
        NSL = NSM
        CALL SG05 (N, NSL)
        IF (IER .EQ. 0) THEN
          DO 20 I = 1, 12
            IF (I .GT. 9) THEN
              X(I) = IR(3, I - 9, N) / 12.0
            ELSE
              X(I) = 0.0
            ENDIF
   20     CONTINUE
          DO 40 I = 1, 2
            DO 30 K = 1, 3
              IRIK = IR(I, K, N)
              IF (IRIK .NE. 0) THEN
                ISIK = 1
                IF (IRIK .LT. 0) ISIK = -1
                X((K - 1) * 3 + IABS(IRIK)) = ISIK
              ENDIF
   30       CONTINUE
   40     CONTINUE
        ENDIF
C * ISW = 7 : GET SYMMOP NR + UNITCELL TRANSLATIONS FOR GIVEN OPERATOR
      ELSE IF (ISW .EQ. 7) THEN
        CALL SG10 (X)
C * ISW = 8 : MULTIPLY EXTERNALLY SUPPLIED SYMM OP AND RETURN SYMM NR
C *           AND UNIT TRL
      ELSE IF (ISW .EQ. 8) THEN
        CALL SG11 (X)
C * ISW = 9 : CALCULATE INVERSE OPERATION FOR GIVEN OPERATION
C *           IN (X(1), ... X(4))
      ELSE IF (ISW .EQ. 9) THEN
        CALL SG11 (X)
C * ISW = 10 : LATTICE CARD (E.G. LATT -4 or LATT I A)
      ELSE IF (ISW .EQ. 10) THEN
        CALL SG03 (X, TRDET, 1)
        IF (IER .EQ. 0) THEN
          JJ = 0
          DO 60 I = 5, 80
            IF (LINE(I:I) .NE. ' ' .AND. LINE(I:I) .NE. '-') THEN
              DO 50 LL = 1, 7
                IF (LINE(I:I) .EQ. CHAR(ICHAR('0') + LL)) THEN
                  SGSMC(13:13) = ICH(36 + LL)
                  IF (LINE(I - 1:I - 1) .NE. '-') SGSMC(14:14) = 'C'
                  GOTO 70
                ENDIF
   50         CONTINUE
              JJ = JJ + 1
              SGSMC(JJ + 12:JJ + 12) = LINE(I:I)
            ENDIF
   60     CONTINUE
   70     IF (ITRNS .NE. 0) CALL SG08 (TRDET)
          CALL SG04
        ENDIF
C * ISW = 11 : READ SYMM LINE
      ELSE IF (ISW .EQ. 11) THEN
        DO 80 I = 4, 6
          IABC(I) = 1
          JABC(I) = I - 3
   80   CONTINUE
        IF (NST .EQ. 1) THEN
          CALL SG03 (X, TRDET, 0)
          IF (IER .NE. 0) GOTO 510
        ENDIF
        JB   = 5
        JE   = 80
        JSWD = 0
        GOTO 300
C * ISW = 12 : SEARCH FOR GENERATORS FOR SPECIFIED SPACE GROUP
      ELSE IF (ISW .EQ. 12) THEN
        CALL SG14 (X, TRDET)
        IF (LRET .EQ. 2) GOTO 270
C * ISW = 14 : HELP OPTION
      ELSE IF (ISW .EQ. 14) THEN
        IF (IUIT .NE. 0) WRITE (IUIT, 99993)
        IF (NRSYM .GT. 0) THEN
          IF (IUIT .NE. 0) WRITE (IUIT, 99995)
          READ  (NRSYM, 99989) XCHAR
        ENDIF
        IF (IUIT .NE. 0) THEN
          WRITE (IUIT, 99992)
          WRITE (IUIT, 99991)
        ENDIF
        IF (NRSYM .GT. 0) THEN
          IF (IUIT .NE. 0) WRITE (IUIT, 99995)
          READ  (NRSYM, 99989) XCHAR
        ENDIF
        IF (IUIT .NE. 0) THEN
          WRITE (IUIT, 99990)
          WRITE (IUIT, 99994) (SGT(I)(1:12),   I = 1, NRSPGR)
        ENDIF
        IF (NRSYM .GT. 0) THEN
          IF (IUIT .NE. 0) WRITE (IUIT, 99995)
          READ  (NRSYM, 99989) XCHAR
        ENDIF
        IF (IUIT .NE. 0) THEN
          WRITE (IUIT, 99999) (NOSTP(I), I = 1, 6)
          WRITE (IUIT, 99998) (NONST(I), I = 1, 294)
        ENDIF
C * ISW = 15 : HANDLE R/T - MATRIX INPUT THROUGH X
      ELSE IF (ISW .EQ. 15) THEN
        DO 90 I = 1, 3
          R0(1, I) = X(I)
          R0(2, I) = X(I + 3)
          R0(3, I) = X(I + 6)
          T0(I)    = X(I + 9)
   90   CONTINUE
        JB = 1
        JE = 20
        CALL SG02 (JB)
        IF (IER .NE. 0) GOTO 510
        DO 100 I = 4, 6
          IABC(I) = 1
          JABC(I) = I - 3
  100   CONTINUE
        JSWD = 0
        GOTO 300
C * ISW = 16: APPLY TRANSFORMATION IN X ON SYMMETRY IN LINE
      ELSE IF (ISW .EQ. 16) THEN
        ISW   = 0
        ITRNS = 1
        JB    = 5
        JE    = 80
        GOTO 10
C * ISW = 17: SHELX-STYLE SYMM CARDS
      ELSE IF (ISW .EQ. 17) THEN
        ISW   = 2
        ISHEL = 1
        GOTO 10
C * ISW = 18: INFO OPTION
      ELSE IF (ISW .EQ. 18) THEN
        GOTO 210
C * ISW = 19 : FIND OUT ABOUT SPECIAL POSITION
      ELSE IF (ISW .EQ. 19) THEN
        ISWD = 1
        ISYM = 0
        IF (X(10) .GT. 0.0) THEN
          TOL = X(10)
        ELSE
          TOL = 0.005
        ENDIF
        DO 110 L = 1, 3
          X(L + 3) = 0.0
          X(L + 6) = 0.0
          YAV(L)   = X(L)
  110   CONTINUE
        NSP  = 1
        IF (NST .GT. 1) THEN
          DO 160 L = 2, NST
            NSM = L
            CALL SG09 (X, NSM)
            IF (IER .NE. 0) GOTO 510
            DO 120 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 .GT. 0.5) THEN
                DIFF = 1.0 - DIFF
                X(6 + I) = X(6 + I) - 1.0
              ENDIF
              IF (DIFF .GT. TOL) GOTO 160
  120       CONTINUE
            NSP = NSP + 1
            YAV(1) = YAV(1) + X(7)
            YAV(2) = YAV(2) + X(8)
            YAV(3) = YAV(3) + X(9)
            K   = 0
            IRT = 0
            DO 140 I = 1, 2
              DO 130 J = 1, 3
                IRT = IRT + IR(I, J, NSM) * 7**K
                K   = K + 1
  130         CONTINUE
  140       CONTINUE
            DO 150 J = 1, NOPR
              IF (IRT .EQ. IOPR(J)) THEN
                ISYM = ISYM + 2**(J - 1)
                GOTO 160
              ENDIF
  150       CONTINUE
  160     CONTINUE
        ENDIF
        DO 165 I = 1, 3
          YUNK = MOD (100.0 + (YAV(I) / NSP), 1.0)
          X(6 + I) = YUNK - NINT(YUNK - X(I))
  165   CONTINUE
        DO 170 I = 1, NSITE
          IF (ISYM .EQ. KSITE(I)) GOTO 180
  170   CONTINUE
        I     = 1
  180   X(12) = I
        X(11) = ISYM
        X(10) = 1.0 / NSP
        IF (IKLS .EQ. 4) THEN
          IF (I .EQ. 3) THEN
            I = 12
          ELSE IF (I .EQ. 4) THEN
            I = 9
          ELSE IF (I .EQ. 5) THEN
            I = 15
          ELSE IF (I .EQ. 12) THEN
            I = 7
          ENDIF
        ENDIF
        LIN(1:5) = SITE(I)
C * ISW = 20 : PRINT SYMM INCLUDING TRANSLATION
      ELSE IF (ISW .EQ. 20) THEN
        ISW  = 2
        ITRL = 12
        GOTO 10
C * ISW = 21 : PARSE HALL-SYMBOL
      ELSE IF (ISW .EQ. 21) THEN
        CALL SG03 (X, TRDET, 1)
        CALL GEN038 (ZSPG, 1, 13)
        IF (IER .EQ. 0) THEN
          DO 190 I = 5, 80
            IF (LINE(I:I) .NE. ' ') GOTO 200
  190     CONTINUE
  200     SGSMC(33:) = LINE(I : I + 16)
          CALL GEN020 (-1, SGSMC, 35, 49)
          CALL SG01 (1)
          IF (IER .EQ. 0) THEN
            LRET = 2
            GOTO 270
          ELSE
            GOTO 510
          ENDIF
        ENDIF
      ELSE IF (ISW .EQ. 22) THEN
        ISW   = 0
        NSGET = 1
        GOTO 10
      ENDIF
      GOTO 510
C * ISW = 2 & 4 (& 17 & 20) : PRINT SYMM (X,Y,Z OR H,K,L) LINES
C * ISW = 18 : INFO OPTION: SPACE GROUP NUMBER, CRYSTAL SYSTEM,
C *             LAUE GROUP NUMBER, NSYMP, ICNTR, IBV
C *             SPACEGROUP NAME (1:11)
  210 IF (SGSMC(1:1) .NE. ' ') GOTO 490
      ISWD  = 1
      JSWD  = 1
      NTRNS = 0
      DO 220 I = 1, NST
        NSL = I
        CALL SG05 (NSL, NSL)
        IF (IER .NE. 0) GOTO 510
  220 CONTINUE
      JS    = JSMX + 1
  230 JS    = JS   - 1
      IF (JS .LT. JSMI) GOTO 490
      NSLP  = 0
      NICM  = 3
      NIC   = NICM
      N = INDEX (SGT(JS)(16:32), '-1')
      IF (N .GT. 0) THEN
        IF (SGT(JS)(15+N:N+17) .EQ. '-1)') N = 0
      ENDIF
      IF (SGT(JS)(16:16) .EQ. '-' .OR. N .NE. 0) THEN
        ISGC = 2
      ELSE
        ISGC = 1
      ENDIF
      IF (ISGC .NE. ICNTRX) GOTO 230
      IBRAV = SGSMC(13:13)
  240 NSLP  = NSLP + 1
      IF (NSLP .EQ. 1) THEN
        NSLPM = 1
        N     = 0
        READ (SGT(JS)(13:15), 99996) NUMS
        IF (NUMS .GT. 15 .AND. NUMS .LT. 75) THEN
          N = INDEX (SGT(JS)(1:12), ':1')
          IF (N .EQ. 0) THEN
            IF (NSLOC(NUMS - 15) .GT. 0) NSLPM = 6
          ENDIF
        ENDIF
        BLT = SGT(JS)(1:1)
        IF (BLT .EQ. 'R') THEN
          IF (INDEX (SGT(JS)(2:12), 'R') .NE. 0) BLT = 'P'
        ENDIF
      ELSE
        IF (NSLP .GT. NSLPM) GOTO 230
        BLT = NONST((NSLOC(NUMS - 15) - 1) * 6 + NSLP)(1:1)
      ENDIF
      SGSMC(13:13) = IBRAV
      IF (BLT .NE. IBRAV) GOTO 240
      IMD  = 1
      ISGN = 1
      DO 260 KK = 1, 4
        XCHAR = NOSTP(NSLP)(KK:KK)
        IF (XCHAR .EQ. '-') THEN
          ISGN = -1
        ELSE
          DO 250 L0 = 1, 3
            IF (XCHAR .EQ. CHAR(ICHAR('A') - 1 + L0)) THEN
              IABC(L0 + 3) = ISGN
              JABC(L0 + 3) = IMD
              IMD          = IMD + 1
              ISGN         = 1
            ENDIF
  250     CONTINUE
        ENDIF
  260 CONTINUE
      LINE = '    '//SGT(JS)(16:32)
      CALL SG01 (0)
      IF (IER .NE. 0) GOTO 510
      LRET = 1
  270 JB  = -19
  280 JB  = JB + 20
      JE  = JB + 19
      NIC = NICM
      IF (JB .GT. 80 .OR. LINE(JB:JB) .EQ. ' ') THEN
        IF (LRET .EQ. 1) THEN
          ISGNR = NUMS
          SGSMC(15:54) = SGT(JS)(1:12)//SHFL(NUMS)//SGT(JS)(16:32)
          IF (NSLP .GT. 1) SGSMC(8:11) = NOSTP(NSLP)
          JLAUE = 8
          L0    = 0
          DO 290 L = 1, 12
            IF (SGT(JS)(L + 15:L + 15) .EQ. '"') JLAUE = 7
            IF (SGT(JS)(L:L) .NE. ' ') THEN
              L0           = L0 + 1
              SGSMC(L0:L0) = SGT(JS)(L:L)
            ENDIF
  290     CONTINUE
          CALL SG15 (LIN, X, NSM)
        ELSE IF (LRET .EQ. 2) THEN
          CALL SG04
        ENDIF
        GOTO 510
      ENDIF
  300 NTRNS = ITRNS
  310 IC    = 0
      I     = JB - 1
      NCOM  = 0
  320 IF (IC .GT. 0) THEN
        KABC = JABC(IC + NIC)
        IF (IN .EQ. 2) THEN
          IR(2, KABC, 195) = 0
        ELSE IF (IN .GT. 2) THEN
          IF (IABS(IR(1, KABC, 195)) .GT. IABS(IR(2, KABC, 195)))
     1      CALL GEN014 (IR(1, KABC, 195), IR(2, KABC, 195))
        ENDIF
        FFLT0 = ISNN * FLT * 12.0
        FFLT  = MOD (FFLT0, 12.0)
        IF (FFLT .LT. 0.0) FFLT = FFLT + 12.0
        IF (NSGET .EQ. 1) XSAV(IC) = FFLT0 - FFLT
        NFLT = NINT(FFLT)
        IF (NFLT .EQ. 1  .OR. NFLT .EQ. 5 .OR. NFLT .EQ. 7 .OR.
     1      NFLT .EQ. 11 .OR. ABS(FFLT - NFLT) .GT. 0.01) GOTO 500
        IR(3, JABC(IC + NIC), 195) = MOD(IABC(IC + NIC)
     1      * NFLT + 12, 12)
      ENDIF
      IC   =  IC + 1
      IN   =  1
      ITRV = -1
      IFLT =  0
      FLT  =  0.0
      IFRC =  0
      ISNN =  1
      ISN  =  1
  330 I = I + 1
      IF (I - JE .LT. 1) THEN
        DO 340 K = 1, 21
          IF (LINE(I:I) .EQ. ICH(K)) GOTO 350
  340   CONTINUE
        GOTO 500
  350   LINE(I:I) = ' '
        IF (K .EQ. 20 .OR. K .EQ. 21) THEN
          ITRNS = 0
          NTRNS = 0
        ELSE IF (K .LT. 10) THEN
          IF (IFLT .EQ. 0) THEN
            IF (ITRV .NE. 0) THEN
              IF (ITRV .LT. 0) THEN
                ITRV = K
                KTRV = K
                INM  = 1
              ELSE
                INM  = K
              ENDIF
              ISNN = ISN
              IF (KTRV .GT. K .AND. NSGET .EQ. 0) ITRV = MOD(KTRV, K)
              FLT  = FLOAT(ITRV) / FLOAT(INM)
              IFRC = IFRC + 1
              IF (IFRC .GT. 2) GOTO 500
            ENDIF
          ELSE
            FLT  = FLT  + K * 10.0**IFLT
            IFLT = IFLT - 1
            ISNN = ISN
          ENDIF
        ELSE IF (K .EQ. 11) THEN
          IFLT = IFLT - 1
          ISNN = ISN
        ELSE IF (K .GT. 11 .AND. K .LT. 15) THEN
          KM11 = K - 11
          IR(IN, JABC(IC + NIC), 195) =
     1      IABC(IC + NIC) * ISN * JABC(KM11 + NIC) * IABC(KM11 + NIC)
          IN   = IN + 1
          ISN  = 1
        ELSE IF (K .EQ. 16) THEN
          NCOM = NCOM + 1
          GOTO 320
        ELSE IF (K .EQ. 17) THEN
          ISN = 1
        ELSE IF (K .EQ. 18) THEN
          ISN = - 1
        ENDIF
        GOTO 330
      ELSE IF (I - JE .EQ. 1) THEN
        GOTO 320
      ELSE
        IF (IC .LT. 3 .OR. (IC .EQ. 3 .AND. IN .LT. 2) .OR.
     1      NCOM .NE. 2) GOTO 500
        IF (NSGET .EQ. 1) THEN
          X(1) = IR(1, 1, 195)
          X(2) = IR(1, 2, 195)
          X(3) = IR(1, 3, 195)
          X(4) = IR(2, 1, 195)
          X(5) = IR(2, 2, 195)
          X(6) = IR(2, 3, 195)
          X(7) = IR(3, 1, 195) + XSAV(1)
          X(8) = IR(3, 2, 195) + XSAV(2)
          X(9) = IR(3, 3, 195) + XSAV(3)
          ISW  = 7
          CALL SG10 (X)
          GOTO 510
        ENDIF
        IF (ISW .EQ. 11 .OR. ISW .EQ. 15) THEN
          N1 = IR(3, 1, 195)
          N2 = IR(3, 2, 195)
          N3 = IR(3, 3, 195)
          N  = N1 * 100 + N2 * 10 + N3
          IF (SGSMC(13:13) .EQ. 'P') THEN
            GOTO 360
          ELSE IF (SGSMC(13:13) .EQ. 'A') THEN
            IF (N .NE. 66) GOTO 360
          ELSE IF (SGSMC(13:13) .EQ. 'B') THEN
            IF (N .NE. 606) GOTO 360
          ELSE IF (SGSMC(13:13) .EQ. 'C') THEN
            IF (N .NE. 660) GOTO 360
          ELSE IF (SGSMC(13:13) .EQ. 'I') THEN
            IF (N .NE. 666) GOTO 360
          ELSE IF (SGSMC(13:13) .EQ. 'F') THEN
            IF (N .NE. 660 .AND. N .NE. 606 .AND. N .NE. 66) GOTO 360
          ELSE IF (SGSMC(13:13) .EQ. 'R') THEN
            IF (N .NE. 844 .AND. N .NE. 488) GOTO 360
          ENDIF
          IR(3, 1, 195) = 0
          IR(3, 2, 195) = 0
          IR(3, 3, 195) = 0
        ENDIF
  360   CALL GEN021 (R3, 0)
        DO 380 III = 1, 3
          DO 370 KKK = 1, 2
            N = IR(KKK, III, 195)
            IF (N .NE. 0) R3(III, IABS(N)) = SIGN(1.0, FLOAT(N))
  370     CONTINUE
          T3(III) = FLOAT(IR(3, III, 195)) / 12.0
  380   CONTINUE
        IF (ISW .EQ. 11 .OR. ISW .EQ. 12 .OR. ISW .EQ. 15 .OR.
     1      ISW .EQ. 21) THEN
          IMPROP = MIN (IMPROP, NINT(GEN119 (R3)))
        ENDIF
        IF (NTRNS .GT. 0) THEN
          NTRNS = 0
          CALL GEN004 (R3, R1, R0)
          CALL GEN004 (R2, R0, R0)
          CALL GEN002 (1, R2, T3, T0, XLNG)
          DO 400 III = 1, 3
            T0(III) = T0(III) + OSFT(III)
            DO 390 JJJ = 1, 3
              T0(III) = T0(III) - R0(III, JJJ) * OSFT(JJJ)
  390       CONTINUE
  400     CONTINUE
          NIC        = 0
          SGSMC(1:1) = ' '
          CALL GEN038 (YSPG, 1, 9)
          CALL SG02 (JB)
          IF (IER .NE. 0) GOTO 510
          JSWD    = 0
          GOTO 310
        ENDIF
        IF (ISW .NE. 2 .AND. ISW .NE. 4 .AND. ISW .NE. 18) THEN
          NSYMO = NSYMP
          OLAT  = SGSMC(13:14)
          CALL SG07
          IF (IER .NE. 0) GOTO 510
          IF (SGSMC(13:14) .NE. OLAT) THEN
            NSYMP = NSYMO
            GOTO 470
          ENDIF
          IF (NSYMP .GE. 48) GOTO 480
          IF (NSYMP .GT. 1) THEN
            II  = 2
  410       I   = II
            JM  = 2 * II - 2
            JJ  = 2
            CALL SG05 (194, I)
            IF (IER .NE. 0) GOTO 510
  420       J   = JJ
            IF (JJ .LE. II) GOTO 430
            J   = II
            I   = 2 * II - JJ
            CALL SG05 (194, I)
            IF (IER .NE. 0) GOTO 510
  430       CALL SG05 (193, J)
            IF (IER .NE. 0) GOTO 510
            CALL SG06
            CALL SG07
            IF (IER .NE. 0) GOTO 510
            IF (SGSMC(13:14) .NE. OLAT) THEN
              NSYMP = NSYMO
              GOTO 470
            ENDIF
            IF (NSYMP .GE. 48) GOTO 480
            JJ = JJ + 1
            IF (JJ .LE. JM) GOTO 420
            II = II + 1
            IF (II .LE. NSYMP) GOTO 410
          ENDIF
        ELSE
          DO 460 I = 1, NST
            DO 450 JJ = 1, 3
              DO 440 KK = 1, 3
                IF (IR(JJ, KK, I) .NE. IR(JJ, KK, 195)) GOTO 460
  440         CONTINUE
  450       CONTINUE
            GOTO 470
  460     CONTINUE
          GOTO 240
        ENDIF
      ENDIF
  470 IF (ISW .NE. 11 .AND. ISW .NE. 15) GOTO 280
  480 CALL SG04
      GOTO 510
  490 CALL SG15 (LIN, X, NSM)
      GOTO 510
  500 IF (IUIT .NE. 0) WRITE (IUIT, 99997) LINE(1:40)
      IER    = 2
  510 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 (/, ':: Error in SYMM line syntax !!, ',
     1        /, ':: Line ignored: ', A, /)
99996 FORMAT (I3)
99995 FORMAT ('====>> Continue with <CR> <<====')
99994 FORMAT (6(1X, A))
99993 FORMAT (/, 'General Space Group Symmetry Handler - Version:',
     1 ' 15-Apr-2002', //, '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 (/, 4X, 'Space Group Names Known to the Program', //)
99989 FORMAT (A)
      END
      SUBROUTINE SG01 (MODE)
      PARAMETER (NRSPGR = 336, NTRL = 174, NOPR = 18, NSITE = 70,
     1  NNH = 168)
      COMMON /CSPGR/ IS(3, 3, 48), ISBRV(4, 3), ISGNR, NSYMP, ICNTR,
     1 IBV, IKLS, LAUE, IR(3, 3, 195), ISV(3), IABC(6), JABC(6),
     2 R0(3, 3), R1(3, 3), R2(3, 4), R3(3, 3), T0(3), T3(3), OSFT(3),
     3 IINV, ISW, IBV0(7), IBV1(7), IBV2(18), ILAUE, IAXM, KSITE(NSITE),
     4 IOPR(NOPR), IORG(3, 3), JSMI, JSMX, NST, ISWD, JSWD, NSG(28),
     5 ITRNS, ICNTRX, IMPROP, IUIT, OCNT(3), NHRM(198), IHALL(9, 4),
     6 LRET, NSLOC(59), NSGF(230), NSGET, NTRNS, JLAUE, ISHEL, ITRL, IER
      COMMON /CSGSM/ ICH(43), SGT, NONST, NOSTP, SGSMC, YSPG, ZSPG,
     1 NHLA, NHLB, TRLTA, TRLTB, LINE, SHFL
      CHARACTER SGT(NRSPGR)*32, LINE*80, LNI*1, LN0*1, ICH*1,
     1 NONST(294)*9, NOSTP(6)*4, YSPG*9, ZSPG*13, SGSMC*59,
     2 TRLTA(NTRL)*13, TRLTB(NTRL)*7, SHFL(230)*6,
     4 NHLA(NNH)*7, NHLB(NNH)*15
      CALL GEN020 (1, LINE, 1, 80)
      IF (MODE .EQ. 1) SGSMC(14:14) = 'A'
      JB    = -19
      JE    = 0
      NLEV  = -1
      ISGN  = 1
      LPAR  = -1
      JLAUE = 8
      ISTAT = 0
      DO 20 L = 1, 4
        DO 10 K = 1, 9
          IHALL(K, L) = 0
   10   CONTINUE
        IHALL(2, L) = 1
   20 CONTINUE
      DO 40 I = 5, 80
        LN0 = LINE(I - 1: I - 1)
        LNI = LINE(I : I)
        IF (NLEV .EQ. -1) THEN
          IF (LNI .EQ. '-') THEN
            IF (MODE .EQ. 1) SGSMC(14:14) = 'C'
          ELSE IF (LNI .NE. ' ') THEN
            DO 30 J = 1, 7
              IF (LNI .EQ. ICH(36 + J)) THEN
                IF (ZSPG(1:1) .EQ. ' ' .AND. MODE .EQ. 1)
     1              SGSMC(13:13) = LNI
                NLEV        = 0
                ISTAT       = 1
                IHALL(1, 1) = 10
                GOTO 40
              ENDIF
   30       CONTINUE
          ENDIF
        ELSE
          IF (LNI .EQ. '-') THEN
            IF (LPAR .LT. 0) THEN
              NLEV  = NLEV + ISTAT
              IF (NLEV .GT. 4) GOTO 120
              ISTAT          = 0
              IHALL(2, NLEV) = -1
            ELSE
              ISGN = -1
            ENDIF
          ELSE IF (LNI .EQ. '(') THEN
            IF (NLEV .LT. 2) GOTO 120
            LPAR = 0
          ELSE IF (LNI .EQ. ')') THEN
          ELSE IF (LNI .EQ. '0') THEN
            IF (LPAR .GE. 0) LPAR = LPAR + 1
          ELSE IF (LNI .EQ. '1') THEN
            IF (LPAR .GE. 0) THEN
              LPAR = LPAR + 1
              IF (NLEV .GT. 4) GOTO 120
              IHALL(6 + LPAR, NLEV) = ISGN
              ISGN = 1
            ELSE IF (LN0 .EQ. '3') THEN
              IF (NLEV .GT. 4) GOTO 120
              IHALL(6, NLEV) = IHALL(6, NLEV) + 4
            ELSE IF (LN0 .EQ. '4') THEN
              IF (NLEV .GT. 4) GOTO 120
              IHALL(6, NLEV) = IHALL(6, NLEV) + 3
            ELSE IF (LN0 .EQ. '6') THEN
              IF (NLEV .GT. 4) GOTO 120
              IHALL(6, NLEV) = IHALL(6, NLEV) + 2
            ELSE
              NLEV  = NLEV + ISTAT
              IF (NLEV .GT. 4) GOTO 120
              ISTAT = 1
              IHALL(3, NLEV) = 0
            ENDIF
          ELSE IF (LNI .EQ. '2') THEN
            IF (LN0 .EQ. '3') THEN
              IF (NLEV .GT. 4) GOTO 120
              IHALL(6, NLEV) = IHALL(6, NLEV) + 8
            ELSE IF (LN0 .EQ. '6') THEN
              IF (NLEV .GT. 4) GOTO 120
              IHALL(6, NLEV) = IHALL(6, NLEV) + 4
            ELSE
              NLEV  = NLEV + ISTAT
              IF (NLEV .GT. 4) GOTO 120
              ISTAT = 1
              IF (NLEV .GT. 1) THEN
                IHX = IHALL(1, NLEV - 1) + IHALL(3, NLEV - 1)
              ELSE
                IHX = 0
              ENDIF
              IF (IHX .EQ. 2 .OR. IHX .EQ. 4) THEN
                IHALL(1, NLEV) = 15
                IHALL(3, NLEV) = 0
              ELSE IF (IHX .EQ. 7 .OR. IHX .EQ. 9) THEN
                IHALL(1, NLEV) = 15
                IHALL(3, NLEV) = 2
              ELSE IF (IHX .EQ. 12 .OR. IHX .EQ. 14 .OR.
     1                 IHX .EQ. 21) THEN
                IHALL(1, NLEV) = 15
                IHALL(3, NLEV) = 4
              ELSE
                IHALL(3, NLEV) = 1
              ENDIF
            ENDIF
          ELSE IF (LNI .EQ. '3') THEN
            IF (LN0 .EQ. '4') THEN
              IF (NLEV .GT. 4) GOTO 120
              IHALL(6, NLEV) = IHALL(6, NLEV) + 9
            ELSE
              NLEV  = NLEV + ISTAT
              IF (NLEV .GT. 4) GOTO 120
              ISTAT = 1
              IHALL(3, NLEV) = 2
              IF (NLEV .EQ. 3) THEN
                IHALL(1, NLEV) = 21
                IHALL(3, NLEV) = 0
              ENDIF
            ENDIF
          ELSE IF (LNI .EQ. '4') THEN
            IF (LN0 .EQ. '6') THEN
              IF (NLEV .GT. 4) GOTO 120
              IHALL(6, NLEV) = IHALL(6, NLEV) + 8
            ELSE
              NLEV  = NLEV + ISTAT
              IF (NLEV .GT. 4) GOTO 120
              ISTAT = 1
              IHALL(3, NLEV) = 3
            ENDIF
          ELSE IF (LNI .EQ. '5') THEN
            IF (LN0 .EQ. '6') THEN
              IF (NLEV .GT. 4) GOTO 120
              IHALL(6, NLEV) = IHALL(6, NLEV) +  10
            ENDIF
          ELSE IF (LNI .EQ. '6') THEN
            NLEV  = NLEV + ISTAT
            IF (NLEV .GT. 4) GOTO 120
            ISTAT = 1
            IHALL(3, NLEV) = 4
          ELSE IF (LNI .EQ. 'X') THEN
            IHALL(1, NLEV) = 0
          ELSE IF (LNI .EQ. 'Y') THEN
            IHALL(1, NLEV) = 5
          ELSE IF (LNI .EQ. 'Z') THEN
            IHALL(1, NLEV) = 10
          ELSE IF (LNI .EQ. '*') THEN
            IHALL(1, NLEV) = 21
            IHALL(3, NLEV) = 0
          ELSE IF (LNI .EQ. '''') THEN
            IHALL(1, NLEV) = 15
            IHX = IHALL(1, NLEV - 1)
            IF (IHX .EQ. 0) THEN
              IHALL(3, NLEV) = 0
            ELSE IF (IHX .EQ. 5) THEN
              IHALL(3, NLEV) = 2
            ELSE
              IHALL(3, NLEV) = 4
            ENDIF
          ELSE IF (LNI .EQ. '"') THEN
            JLAUE = 7
            IHALL(1, NLEV) = 15
            IF (NLEV .EQ. 1) GOTO 120
            IHX = IHALL(1, NLEV - 1)
            IF (IHX .EQ. 0) THEN
              IHALL(3, NLEV) = 1
            ELSE IF (IHX .EQ. 5) THEN
              IHALL(3, NLEV) = 3
            ELSE
              IHALL(3, NLEV) = 5
            ENDIF
          ELSE IF (LNI .EQ. '*') THEN
          ELSE IF (LNI .EQ. 'A') THEN
            IF (NLEV .GT. 4) GOTO 120
            IHALL(4, NLEV) = IHALL(4, NLEV) + 6
          ELSE IF (LNI .EQ. 'B') THEN
            IF (NLEV .GT. 4) GOTO 120
            IHALL(5, NLEV) = IHALL(5, NLEV) + 6
          ELSE IF (LNI .EQ. 'C') THEN
            IF (NLEV .GT. 4) GOTO 120
            IHALL(6, NLEV) = IHALL(6, NLEV) + 6
          ELSE IF (LNI .EQ. 'N') THEN
            IF (NLEV .GT. 4) GOTO 120
            IHALL(4, NLEV) = IHALL(4, NLEV) + 6
            IHALL(5, NLEV) = IHALL(5, NLEV) + 6
            IHALL(6, NLEV) = IHALL(6, NLEV) + 6
          ELSE IF (LNI .EQ. 'U') THEN
            IHALL(4, NLEV) = IHALL(4, NLEV) + 3
          ELSE IF (LNI .EQ. 'V') THEN
            IHALL(5, NLEV) = IHALL(5, NLEV) + 3
          ELSE IF (LNI .EQ. 'W') THEN
            IHALL(6, NLEV) = IHALL(6, NLEV) + 3
          ELSE IF (LNI .EQ. 'D') THEN
            IHALL(4, NLEV) = IHALL(4, NLEV) + 3
            IHALL(5, NLEV) = IHALL(5, NLEV) + 3
            IHALL(6, NLEV) = IHALL(6, NLEV) + 3
          ENDIF
        ENDIF
   40 CONTINUE
      IF (NLEV .LE. 0) GOTO 120
      IF (MODE .EQ. 1) CALL SG04
      IF (IER .EQ. 0) THEN
        CALL GEN038 (LINE, 1, 80)
        LH = 0
   50   LH = LH + 1
        IF (LH .GT. NLEV) GOTO 110
        JB = JB + 20
        JE = JE + 20
        M  = (IHALL(1, LH) + IHALL(3, LH)) * 9
        DO 70 J = 1, 3
          DO 60 I = 1, 3
            K = (J - 1) * 3 + I
            R0(I, J) = NHRM(M + K) * IHALL(2, LH)
   60     CONTINUE
   70   CONTINUE
        DO 80 K = 1, 3
          T0(K) = (IHALL(3 + K, LH) + IHALL(6 + K, LH)) / 12.0
   80   CONTINUE
        DO 100 I = 1, 3
          DO 90 J = 1, 3
            T0(I) = T0(I) - R0(I, J) * IHALL(6 + J, LH) / 12.0
   90     CONTINUE
  100   CONTINUE
        NTRNS = ITRNS
        CALL SG02 (JB)
        IF (IER .EQ. 0) GOTO 50
      ENDIF
  110 IF (IER .EQ. 0) GOTO 130
  120 IER = 7
  130 RETURN
      END
      SUBROUTINE SG02 (JB)
      PARAMETER (NRSPGR = 336, NTRL = 174, NOPR = 18, NSITE = 70,
     1  NNH = 168)
      COMMON /CSPGR/ IS(3, 3, 48), ISBRV(4, 3), ISGNR, NSYMP, ICNTR,
     1 IBV, IKLS, LAUE, IR(3, 3, 195), ISV(3), IABC(6), JABC(6),
     2 R0(3, 3), R1(3, 3), R2(3, 4), R3(3, 3), T0(3), T3(3), OSFT(3),
     3 IINV, ISW, IBV0(7), IBV1(7), IBV2(18), ILAUE, IAXM, KSITE(NSITE),
     4 IOPR(NOPR), IORG(3, 3), JSMI, JSMX, NST, ISWD, JSWD, NSG(28),
     5 ITRNS, ICNTRX, IMPROP, IUIT, OCNT(3), NHRM(198), IHALL(9, 4),
     6 LRET, NSLOC(59), NSGF(230), NSGET, NTRNS, JLAUE, ISHEL, ITRL, IER
      COMMON /CSGSM/ ICH(43), SGT, NONST, NOSTP, SGSMC, YSPG, ZSPG,
     1 NHLA, NHLB, TRLTA, TRLTB, LINE, SHFL
      CHARACTER SGT(NRSPGR)*32, LINE*80, ICH*1,  NONST(294)*9,
     1 NOSTP(6)*4, YSPG*9, ZSPG*13, SGSMC*59, TRLTA(NTRL)*13,
     2 TRLTB(NTRL)*7, SHFL(230)*6, NHLA(NNH)*7, NHLB(NNH)*15
      CALL GEN038 (LINE, JB, JB + 19)
      K = JB
      DO 30 I = 1, 3
        TRV  = AMOD(T0(I) * 12.0, 12.0)
        NTRV = NINT(TRV)
        IF (ABS(TRV - NTRV) .GT. 0.1) THEN
          IF (IUIT .NE. 0) WRITE (IUIT, 99999) (T0(K), K = 1, 3)
          IER = 8
          GOTO 40
        ENDIF
        NTRVN = 12
        IF (NTRV .NE. 0) THEN
          IF (NTRV .LT. 0) NTRV = NTRV + 12
          IF (NTRV .GT. 0) THEN
   10       IF (MOD(NTRV, 2) .EQ. 0 .AND. MOD(NTRVN, 2) .EQ. 0) THEN
              NTRV  = NTRV / 2
              NTRVN = NTRVN / 2
              GOTO 10
            ENDIF
            IF (MOD(NTRV, 3) .EQ. 0 .AND. MOD(NTRVN, 3) .EQ. 0) THEN
              NTRV  = NTRV / 3
              NTRVN = NTRVN / 3
              GOTO 10
            ENDIF
            LINE(K:K+2) = ICH(NTRV)//'/'//ICH(NTRVN)
            K = K + 3
          ENDIF
        ENDIF
        DO 20 J = 1, 3
          IF (ABS(R0(I, J)) .GT. 0.9) THEN
            NR0 = NINT(R0(I, J))
            IF (NR0 .GT. 0) THEN
              LINE(K:K) = '+'
            ELSE
              LINE(K:K) = '-'
            ENDIF
            LINE(K + 1:K + 1) = ICH(11 + J)
            K = K + 2
          ENDIF
   20   CONTINUE
        IF (I .LT. 3) THEN
          LINE(K:K) = ','
          K = K + 1
        ENDIF
   30 CONTINUE
   40 RETURN
99999 FORMAT ('E: SYMM TRANSLATION N.A.:', 3F8.3)
      END
      SUBROUTINE SG03 (X, DET, ISG04)
      PARAMETER (NRSPGR = 336, NTRL = 174, NOPR = 18, NSITE = 70,
     1  NNH = 168)
      COMMON /CSPGR/ IS(3, 3, 48), ISBRV(4, 3), ISGNR, NSYMP, ICNTR,
     1 IBV, IKLS, LAUE, IR(3, 3, 195), ISV(3), IABC(6), JABC(6),
     2 R0(3, 3), R1(3, 3), R2(3, 4), R3(3, 3), T0(3), T3(3), OSFT(3),
     3 IINV, ISW, IBV0(7), IBV1(7), IBV2(18), ILAUE, IAXM, KSITE(NSITE),
     4 IOPR(NOPR), IORG(3, 3), JSMI, JSMX, NST, ISWD, JSWD, NSG(28),
     5 ITRNS, ICNTRX, IMPROP, IUIT, OCNT(3), NHRM(198), IHALL(9, 4),
     6 LRET, NSLOC(59), NSGF(230), NSGET, NTRNS, JLAUE, ISHEL, ITRL, IER
      COMMON /CSGSM/ ICH(43), SGT, NONST, NOSTP, SGSMC, YSPG, ZSPG,
     1 NHLA, NHLB, TRLTA, TRLTB, LINE, SHFL
      CHARACTER SGT(NRSPGR)*32, LINE*80, NONST(294)*9, NOSTP(6)*4,
     1 YSPG*9, ICH*1, SGSMC*59, ZSPG*13, TRLTA(NTRL)*13,
     2 TRLTB(NTRL)*7, SHFL(230)*6, NHLA(NNH)*7, NHLB(NNH)*15
      DIMENSION X(12)
      K = 0
      DO 20 I = 1, 3
        IF (ITRNS .EQ. 0) THEN
          OSFT(I) = 0.0
        ELSE
          OSFT(I) = - X(I + 9)
        ENDIF
        DO 10 J = 1, 3
          IF (ITRNS .EQ. 0) THEN
            IF (I .EQ. J) THEN
              XVAL = 1.0
            ELSE
              XVAL = 0.0
            ENDIF
          ELSE
            K    = K   + 1
            XVAL = X(K)
          ENDIF
          R1(J, I) = XVAL
   10   CONTINUE
   20 CONTINUE
      CALL GEN003 (R1, R2, DET, 0)
      IF (ABS(DET) .LT. 0.1) THEN
        IF (IUIT .NE. 0)
     1    WRITE (IUIT, 99999) DET, ((R1(I, J), I = 1, 3), J = 1, 3)
        IER = 11
        GOTO 50
      ENDIF
      IF (ISW .NE. 11) THEN
        DO 40 I = 1, 3
          IABC(I)     = 1
          IABC(I + 3) = 1
          JABC(I)     = I
          JABC(I + 3) = I
          DO 30 J = 1, 3
            IF (I .EQ. 1) THEN
              ISS = J
            ELSE
              ISS = 0
            ENDIF
            IS (I, J, 1) = ISS
            IF (I .EQ. J) THEN
              ISS = I
            ELSE
              ISS = 0
            ENDIF
            IORG(I, J) = ISS
   30     CONTINUE
   40   CONTINUE
        CALL GEN038 (YSPG,  1, 9)
        CALL GEN038 (ZSPG,  1, 13)
        CALL GEN038 (SGSMC, 1, 47)
        SGSMC(13:14) = 'PA'
        NSYMP        = 1
        JSWD         = 0
        IKLS         = 8
        ISGNR        = 0
        IAXM         = 0
        IMPROP       = 1
      ENDIF
   50 IF (ISG04 .NE. 0) CALL SG04
      RETURN
99999 FORMAT (':: Transformation Matrix with Determinant =', F6.3, //,
     1 3(3F10.3, /))
      END
      SUBROUTINE SG04
      PARAMETER (NRSPGR = 336, NTRL = 174, NOPR = 18, NSITE = 70,
     1  NNH = 168)
      COMMON /CSPGR/ IS(3, 3, 48), ISBRV(4, 3), ISGNR, NSYMP, ICNTR,
     1 IBV, IKLS, LAUE, IR(3, 3, 195), ISV(3), IABC(6), JABC(6),
     2 R0(3, 3), R1(3, 3), R2(3, 4), R3(3, 3), T0(3), T3(3), OSFT(3),
     3 IINV, ISW, IBV0(7), IBV1(7), IBV2(18), ILAUE, IAXM, KSITE(NSITE),
     4 IOPR(NOPR), IORG(3, 3), JSMI, JSMX, NST, ISWD, JSWD, NSG(28),
     5 ITRNS, ICNTRX, IMPROP, IUIT, OCNT(3), NHRM(198), IHALL(9, 4),
     6 LRET, NSLOC(59), NSGF(230), NSGET, NTRNS, JLAUE, ISHEL, ITRL, IER
      COMMON /CSGSM/ ICH(43), SGT, NONST, NOSTP, SGSMC, YSPG, ZSPG,
     1 NHLA, NHLB, TRLTA, TRLTB, LINE, SHFL
      COMMON /SLAUE/ NLAUE, XSYST, IBVL, SITE
      CHARACTER SGT(NRSPGR)*32, LINE*80,
     1 NONST(294)*9, NOSTP(6)*4, YSPG*9, NLAUE(14)*5, XSYST(8)*12,
     2 ICH*1, IBVL(8)*1, SGSMC*59, SITE(NSITE)*5, ZSPG*13,
     3 TRLTA(NTRL)*13, TRLTB(NTRL)*7, SHFL(230)*6,
     4 NHLA(NNH)*7, NHLB(NNH)*15
      IF (SGSMC(14:14) .EQ. 'C') THEN
        ICNTR = 2
      ELSE
        ICNTR = 1
      ENDIF
      ICNTRX = ICNTR
      NSYMX  = NSYMP
      IF (ICNTR .EQ. 1 .AND. NSYMP .GT. 1) THEN
        DO 20 I = 2, NSYMP
          DO 10 K = 1, 3
            IF (IS(2, K, I) .NE. 0) GOTO 20
            IF (IS(1, K, I) .NE. - K) GOTO 20
            OCNT(K) = FLOAT(IS(3, K, I)) / 24
   10     CONTINUE
          ICNTRX = 2
          NSYMX  = NSYMP / 2
          GOTO 30
   20   CONTINUE
      ENDIF
   30 DO 40 I = 1, 7
        IF (SGSMC(13:13) .EQ. ICH(I + 29)) GOTO 50
   40 CONTINUE
      IF (IUIT .NE. 0) WRITE (IUIT, 99999) SGSMC(13:13)
      IER = 10
      GOTO 80
   50 IBV  = IBV0(I)
      IBVP = IBV1(I)
      DO 70 J = 1, IBV
        DO 60 I = 1, 3
          IF (J .EQ. 1) THEN
            ISBRV(J, I) = 0
          ELSE
            ISBRV(J, I) = IBV2(IBVP)
            IBVP        = IBVP + 1
          ENDIF
   60   CONTINUE
   70 CONTINUE
      IF (ILAUE .LT. 0) THEN
        IINV = 2
      ELSE
        IINV = ICNTR
      ENDIF
      NST  = NSYMP * IBV * IINV
      IKLS  =  8
      LAUE  = 13
      IF (NSYMX .EQ. 1) THEN
        IKLS = 1
        LAUE = 1
      ELSE IF (NSYMX .EQ. 2) THEN
        IKLS = 2
        LAUE = 2
      ELSE IF (IAXM .EQ. 6) THEN
        IKLS = 6
        IF (NSYMX .EQ. 6) THEN
          LAUE = 9
        ELSE
          LAUE = 10
        ENDIF
      ELSE IF (NSYMX .GE. 12) THEN
        IKLS = 7
        IF (NSYMX .EQ. 12) THEN
          LAUE = 11
        ELSE
          LAUE = 12
        ENDIF
      ELSE IF (IAXM .EQ. 4) THEN
        IKLS = 4
        IF (NSYMX .EQ. 4) THEN
          LAUE = 4
        ELSE
          LAUE = 5
        ENDIF
      ELSE IF (IAXM .EQ. 3) THEN
        IKLS = 5
        IF (NSYMX .EQ. 3) THEN
          LAUE = 6
        ELSE
          LAUE = 14
        ENDIF
      ELSE IF (NSYMX .EQ. 4) THEN
        IKLS  = 3
        LAUE  = 3
      ENDIF
      JSMI = NSG(2 * LAUE - 1)
      JSMX = NSG(2 * LAUE)
      IF(IKLS .EQ. 5 .AND. IABS(IS(1, 3, 2)) .EQ. 3) THEN
        SGSMC(12:12) = IBVL(6)
      ELSE
        SGSMC(12:12) = IBVL(IKLS)
      ENDIF
   80 RETURN
99999 FORMAT (':: Unknown LATTICE Type:', A)
      END
      SUBROUTINE SG05 (N, NSL)
      PARAMETER (NOPR = 18, NSITE = 70)
      COMMON /CSPGR/ IS(3, 3, 48), ISBRV(4, 3), ISGNR, NSYMP, ICNTR,
     1 IBV, IKLS, LAUE, IR(3, 3, 195), ISV(3), IABC(6), JABC(6),
     2 R0(3, 3), R1(3, 3), R2(3, 4), R3(3, 3), T0(3), T3(3), OSFT(3),
     3 IINV, ISW, IBV0(7), IBV1(7), IBV2(18), ILAUE, IAXM, KSITE(NSITE),
     4 IOPR(NOPR), IORG(3, 3), JSMI, JSMX, NST, ISWD, JSWD, NSG(28),
     5 ITRNS, ICNTRX, IMPROP, IUIT, OCNT(3), NHRM(198), IHALL(9, 4),
     6 LRET, NSLOC(59), NSGF(230), NSGET, NTRNS, JLAUE, ISHEL, ITRL, IER
      IF (NSL .EQ. 0) THEN
        IF (IUIT .NE. 0) WRITE (IUIT, 99996)
        IER = 9
        GOTO 40
      ENDIF
      NS0 = (IABS(NSL) - 1) / NSYMP
      NS  =  IABS(NSL) - NS0 * NSYMP
      IF (NS .LT. 1) THEN
        IF (IUIT .NE. 0) WRITE (IUIT, 99998) NSL, NSYMP, NS0, NS,ISW
        IER = 5
        GOTO 40
      ENDIF
      IF (ILAUE .LT. 0) THEN
        IINV = 2
      ELSE
        IINV = ICNTR
      ENDIF
      NS2 = NS0 / IINV
      NS1 = NS0 + 1 - NS2 * IINV
      NS2 = NS2 + 1
      IF (NS2 .LT. 1 .OR. NS2 .GT. 4) THEN
        IF (IUIT .NE. 0) WRITE (IUIT, 99999) NS0, NS1, NS2, IINV
        IER = 4
        GOTO 40
      ENDIF
      IF (N .LT. 1 .OR. N .GT. 195) THEN
        IF (IUIT .NE. 0) WRITE (IUIT, 99997) NS, NS0, NS1, NS2, IINV, N
        IER = 3
        GOTO 40
      ENDIF
      DO 10 I = 1, 3
        IR(1, I, N) = 0
        IR(2, I, N) = 0
   10 CONTINUE
      DO 30 I = 1, 3
        DO 20 K = 1, 3
          INH = IS(K, I, NS)
          IF (NS1 .EQ. 2) INH = - INH
          IF (K .EQ. 3) THEN
            IF (ILAUE .GT. 0) THEN
              INH = MOD(INH + ISBRV(NS2, I), 12)
            ELSE
              INH = MOD(ISBRV(NS2, I), 12)
            ENDIF
            IF (INH .LT. 0) INH = INH + 12
            IR(K, I, N) = INH
          ELSE IF (ISWD .GT. 0) THEN
            IR(K, I, N) = INH
          ELSE IF (INH .NE. 0) THEN
            IF (INH .LT. 0) THEN
              INHD = - I
              INH  = - INH
            ELSE
              INHD =  I
            ENDIF
            IF (IR(1, INH, N) .EQ. 0) THEN
              IR(1, INH, N) = INHD
            ELSE
              IR(2, INH, N) = INHD
            ENDIF
          ENDIF
   20   CONTINUE
   30 CONTINUE
   40 RETURN
99999 FORMAT ('SGSM Problem:NS0,NS1,NS2,IINV = ', 4I10,
     1        'NS2 < 1 OR NS2 > 4')
99998 FORMAT ('NS .LT. 1 ERROR IN (SGSM)', /,
     1        'NSL, NSYMP, NS0, NS, ISW =', 5I10, /)
99997 FORMAT ('E: SPGR-Problem', 6I5, /)
99996 FORMAT ('nsl = 0 in SG05')
      END
      SUBROUTINE SG06
      PARAMETER (NOPR = 18, NSITE = 70)
      COMMON /CSPGR/ IS(3, 3, 48), ISBRV(4, 3), ISGNR, NSYMP, ICNTR,
     1 IBV, IKLS, LAUE, IR(3, 3, 195), ISV(3), IABC(6), JABC(6),
     2 R0(3, 3), R1(3, 3), R2(3, 4), R3(3, 3), T0(3), T3(3), OSFT(3),
     3 IINV, ISW, IBV0(7), IBV1(7), IBV2(18), ILAUE, IAXM, KSITE(NSITE),
     4 IOPR(NOPR), IORG(3, 3), JSMI, JSMX, NST, ISWD, JSWD, NSG(28),
     5 ITRNS, ICNTRX, IMPROP, IUIT, OCNT(3), NHRM(198), IHALL(9, 4),
     6 LRET, NSLOC(59), NSGF(230), NSGET, NTRNS, JLAUE, ISHEL, ITRL, IER
      DO 50 K = 1, 3
        DO 10 M = 1, 3
          ISV(M) = 0
   10   CONTINUE
        ITS = IR(3, K, 193)
        DO 30 L = 1, 2
          ISJ = IR(L, K, 193)
          IF (ISJ .NE. 0) THEN
            ISS = IR(3, IABS(ISJ), 194)
            IF (ISJ .LT. 0) ISS = - ISS
            ITS = ITS + ISS
            DO 20 M = 1, 2
              ISX = IR(M, IABS(ISJ), 194)
              IF (ISJ .LT. 0) ISX = - ISX
              IF (ISX .NE. 0) THEN
                ISY = IABS(ISX)
                ISV(ISY) = ISV(ISY) + ISX
              ENDIF
   20       CONTINUE
          ENDIF
   30   CONTINUE
        IR(2, K, 195) = 0
        MM = 0
        DO 40 M = 1, 3
          IF (ISV(M) .NE. 0) THEN
            MM             = MM + 1
            IR(MM, K, 195) = ISV(M)
          ENDIF
   40   CONTINUE
        IR(3, K, 195) = ITS
   50 CONTINUE
      RETURN
      END
      SUBROUTINE SG07
      PARAMETER (NRSPGR = 336, NTRL = 174, NOPR = 18, NSITE = 70,
     1  NNH = 168)
      COMMON /CSPGR/ IS(3, 3, 48), ISBRV(4, 3), ISGNR, NSYMP, ICNTR,
     1 IBV, IKLS, LAUE, IR(3, 3, 195), ISV(3), IABC(6), JABC(6),
     2 R0(3, 3), R1(3, 3), R2(3, 4), R3(3, 3), T0(3), T3(3), OSFT(3),
     3 IINV, ISW, IBV0(7), IBV1(7), IBV2(18), ILAUE, IAXM, KSITE(NSITE),
     4 IOPR(NOPR), IORG(3, 3), JSMI, JSMX, NST, ISWD, JSWD, NSG(28),
     5 ITRNS, ICNTRX, IMPROP, IUIT, OCNT(3), NHRM(198), IHALL(9, 4),
     6 LRET, NSLOC(59), NSGF(230), NSGET, NTRNS, JLAUE, ISHEL, ITRL, IER
      COMMON /CSGSM/ ICH(43), SGT, NONST, NOSTP, SGSMC, YSPG, ZSPG,
     1 NHLA, NHLB, TRLTA, TRLTB, LINE, SHFL
      CHARACTER SGT(NRSPGR)*32, LINE*80,
     1 NONST(294)*9, NOSTP(6)*4, YSPG*9, ICH*1, SGSMC*59, ZSPG*13,
     3 TRLTA(NTRL)*13, TRLTB(NTRL)*7, SHFL(230)*6,
     4 NHLA(NNH)*7, NHLB(NNH)*15
      CHARACTER JBRV*1, JCNT*1
      DO 10 K = 1, 3
        ITS = MOD(IR(3, K, 195), 12)
        IF (ITS .LT. 0) ITS = ITS + 12
        IR(3, K, 195) = ITS
   10 CONTINUE
      JBRV = SGSMC(13:13)
      JCNT = SGSMC(14:14)
      NSP  = 1
      CALL GEN038 (SGSMC, 1, 11)
      DO 40 NSM = 1, NSYMP
        L = NSM
        DO 30 LL = 1, 3, 2
          ISN  = 2 - LL
          IDIF = 0
          IDT  = 0
          IDT0 = 0
          DO 20 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 .LT. 0) IDV = IDV + 12
            IF (IDV .EQ. 4 .OR. IDV .EQ. 8) THEN
              IDT = IDT + IDV * 10**(3 - K)
            ELSE IF (IDV .EQ. 6) THEN
              IDT = IDT + 2**(3 - K)
            ENDIF
            IDT0 = IDT0 + IDV
   20     CONTINUE
          IF (IDIF .EQ. 0) THEN
            IF (IDT0 .EQ. 0) THEN
              IF (ISN .LT. 0) THEN
                IF (JCNT .EQ. 'A') THEN
                  JCNT = 'C'
                ENDIF
              ENDIF
              GOTO 90
            ELSE IF (IDT .EQ. 3) THEN
              IF (JBRV .EQ. 'A' .OR. JBRV .EQ. 'F') THEN
                IF (ISN .LT. 0) JCNT = 'C'
                GOTO 90
              ELSE IF (ISN .GT. 0) THEN
                IF (JBRV .EQ. 'P') THEN
                  JBRV = 'A'
                ELSE IF (JBRV .NE. 'F') THEN
                  JBRV = 'F'
                ENDIF
                NSP = 0
                GOTO 90
              ENDIF
            ELSE  IF (IDT .EQ. 5) THEN
              IF (JBRV .EQ. 'B' .OR. JBRV .EQ. 'F') THEN
                IF (ISN .LT. 0) JCNT = 'C'
                GOTO 90
              ELSE IF (ISN .GT. 0) THEN
                IF (JBRV .EQ. 'P') THEN
                  JBRV = 'B'
                ELSE IF (JBRV .NE. 'F') THEN
                  JBRV = 'F'
                ENDIF
                NSP = 0
              ENDIF
            ELSE IF (IDT .EQ. 6) THEN
              IF (JBRV .EQ. 'C' .OR. JBRV .EQ. 'F') THEN
                IF (ISN .LT. 0) JCNT = 'C'
                GOTO 90
              ELSE IF (ISN .GT. 0) THEN
                IF (JBRV .EQ. 'P') THEN
                  JBRV = 'C'
                ELSE IF (JBRV .NE. 'F') THEN
                  JBRV = 'F'
                ENDIF
                NSP = 0
              ENDIF
            ELSE IF (IDT .EQ. 7) THEN
              IF (JBRV .EQ. 'I') THEN
                IF (ISN .LT. 1) JCNT = 'C'
                GOTO 90
              ELSE IF (ISN .GT. 0) THEN
                IF (JBRV .NE. 'I') THEN
                  JBRV = 'I'
                ENDIF
                NSP = 0
              ENDIF
            ELSE IF (IDT .EQ. 488 .OR. IDT .EQ. 844) THEN
              IF (JBRV .EQ. 'R') THEN
                IF (ISN .LT. 0) JCNT = 'C'
                GOTO 90
              ELSE IF (ISN .GT. 0) THEN
                IF (JBRV .NE. 'R') THEN
                  JBRV = 'R'
                ENDIF
                NSP  = 0
              ENDIF
            ENDIF
          ENDIF
   30   CONTINUE
   40 CONTINUE
      IF (NSP .NE. 0) THEN
        IF (NSYMP .LT. 48) THEN
          NSYMP = NSYMP + 1
          DO 60 L = 1, 3
            DO 50 K = 1, 3
              ISLK            = IR(L, K, 195)
              IS(L, K, NSYMP) = ISLK
              ISLKA           = IABS (ISLK)
              IF (L .LT. 3 .AND. ISLK .NE. 0) THEN
                IF (ISLKA .LT. 4)  THEN
                  IORG(ISLKA, K) = IORG(ISLKA, K) + ISLK
                ELSE
                  IF (IUIT .NE. 0) WRITE (IUIT, 99998)
                  IER = 12
                  GOTO 90
                ENDIF
              ENDIF
   50       CONTINUE
   60     CONTINUE
          IF (IS(1, 3, NSYMP) .GT. 0) THEN
            ISN =  100000
          ELSE
            ISN = -100000
          ENDIF
          ISCOD = 555555
          DO 80 K = 1, 3
            DO 70 L = 1, 2
              ISCOD = ISCOD + ISN * IS(L, K, NSYMP)
              ISN = ISN / 10
   70       CONTINUE
   80     CONTINUE
          IF (ISCOD .EQ. 356385 .OR. ISCOD .EQ. 856575) THEN
            IAX = 3
          ELSE IF (ISCOD .EQ. 356585) THEN
            IAX = 4
          ELSE IF (ISCOD .EQ. 636585) THEN
            IAX = 6
          ELSE
            IAX = 0
          ENDIF
          IAXM = MAX(IAXM, IAX)
        ELSE
          IF (IUIT .NE. 0) WRITE (IUIT, 99999)
          IER = 6
          RETURN
        ENDIF
      ENDIF
   90 SGSMC(13:14) = JBRV//JCNT
      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 SG08 (DET)
      PARAMETER (NRSPGR = 336, NTRL = 174, NOPR = 18, NSITE = 70,
     1  NNH = 168)
      COMMON /CSPGR/ IS(3, 3, 48), ISBRV(4, 3), ISGNR, NSYMP, ICNTR,
     1 IBV, IKLS, LAUE, IR(3, 3, 195), ISV(3), IABC(6), JABC(6),
     2 R0(3, 3), R1(3, 3), R2(3, 4), R3(3, 3), T0(3), T3(3), OSFT(3),
     3 IINV, ISW, IBV0(7), IBV1(7), IBV2(18), ILAUE, IAXM, KSITE(NSITE),
     4 IOPR(NOPR), IORG(3, 3), JSMI, JSMX, NST, ISWD, JSWD, NSG(28),
     5 ITRNS, ICNTRX, IMPROP, IUIT, OCNT(3), NHRM(198), IHALL(9, 4),
     6 LRET, NSLOC(59), NSGF(230), NSGET, NTRNS, JLAUE, ISHEL, ITRL, IER
      COMMON /CSGSM/ ICH(43), SGT, NONST, NOSTP, SGSMC, YSPG, ZSPG,
     1 NHLA, NHLB, TRLTA, TRLTB, LINE, SHFL
      CHARACTER SGT(NRSPGR)*32, LINE*80,
     1 NONST(294)*9, NOSTP(6)*4, YSPG*9, ICH*1, SGSMC*59, ZSPG*13,
     3 TRLTA(NTRL)*13, TRLTB(NTRL)*7, SHFL(230)*6,
     4 NHLA(NNH)*7, NHLB(NNH)*15
      K = 0
      DO 10 I = 1, 7
        IF (SGSMC(13:13) .EQ. ICH(I + 29)) GOTO 20
   10 CONTINUE
      IF (IUIT .NE. 0) WRITE (IUIT, 99999) SGSMC(13:13)
      RETURN
   20 IDET = NINT(IBV0(I) * DET)
      IF (IDET .EQ. 4) THEN
        SGSMC(13:13) = 'F'
      ELSE IF (IDET .EQ. 3) THEN
        SGSMC(13:13) = 'R'
      ELSE IF (IDET .EQ. 2) THEN
        IBVX = 3
        IF (I .GT. 1) THEN
          IBVP = IBV1(I) - 1
          DO 40 J = 1, 3
            R2(J, 4) = 0.0
            DO 30 K = 1, 3
              R2(J, 4) = R2(J, 4) + R2(J, K) * IBV2(IBVP + K) / 12.0
   30       CONTINUE
   40     CONTINUE
          IBVX = 4
        ENDIF
        DO 60 J = 1, IBVX
          K = 0
          DO 50 I = 1, 3
            IF (ABS(0.5 - ABS(AMOD(R2(I, J), 1.0))) .LT. 0.1)
     1        K = K + 2**(I - 1)
   50     CONTINUE
          IF (K .GT. 2 .AND. K .NE. 4) GOTO 70
   60   CONTINUE
   70   IF (K .EQ. 6) THEN
          SGSMC(13:13) = 'A'
        ELSE IF (K .EQ. 5) THEN
          SGSMC(13:13) = 'B'
        ELSE IF (K .EQ. 3) THEN
          SGSMC(13:13) = 'C'
        ELSE IF (K .EQ. 7) THEN
          SGSMC(13:13) = 'I'
        ENDIF
      ELSE
        SGSMC(13:13) = 'P'
      ENDIF
      IF (SGSMC(14:14) .EQ. 'C') THEN
        DO 80 I = 1, 3
          L = NINT(AMOD(ABS(2.0 * OSFT(I)), 1.0) * 12.0)
          IF (L .NE. 0 .AND. L .NE. 6) THEN
            IF (IUIT .NE. 0) WRITE (IUIT, 99998)
            SGSMC(14:14) = 'A'
          ENDIF
   80   CONTINUE
      ENDIF
      RETURN
99999 FORMAT (':: Cannot Transform Lattice: ', A)
99998 FORMAT (':: Origin shift not compatible with inversion on 0,0,0')
      END
      SUBROUTINE SG09 (X, NSM)
      PARAMETER (NOPR = 18, NSITE = 70)
      COMMON /CSPGR/ IS(3, 3, 48), ISBRV(4, 3), ISGNR, NSYMP, ICNTR,
     1 IBV, IKLS, LAUE, IR(3, 3, 195), ISV(3), IABC(6), JABC(6),
     2 R0(3, 3), R1(3, 3), R2(3, 4), R3(3, 3), T0(3), T3(3), OSFT(3),
     3 IINV, ISW, IBV0(7), IBV1(7), IBV2(18), ILAUE, IAXM, KSITE(NSITE),
     4 IOPR(NOPR), IORG(3, 3), JSMI, JSMX, NST, ISWD, JSWD, NSG(28),
     5 ITRNS, ICNTRX, IMPROP, IUIT, OCNT(3), NHRM(198), IHALL(9, 4),
     6 LRET, NSLOC(59), NSGF(230), NSGET, NTRNS, JLAUE, ISHEL, ITRL, IER
      DIMENSION X(12)
      IF (ILAUE .LT. 0 .AND. ICNTR .EQ. 1) THEN
        NSTT = NST * 2
        JSWD = 0
        ISKP = 0
      ELSE
        NSTT = NST
        ISKP = 1
      ENDIF
      IF (ISWD .NE. JSWD) THEN
        DO 10 N = 1, NSTT
          NSL = N
          CALL SG05 (NSL, NSL)
          IF (IER .NE. 0) GOTO 40
   10   CONTINUE
        JSWD = ISWD * ISKP
      ENDIF
      N  = IABS(NSM)
      DO 30 J = 1, 3
        IF (NSM .GT. 0) THEN
          IF (ISWD .LT. 0) THEN
            X(J + 6) = 0.0
            IF (J .EQ. 1) X(10) = X(4) / 360.0
            X(10) = X(10) + IR(3, J, N) * X(J) / 12.0
          ELSE
            X(J + 6) = IR(3, J, N) / 12.0 + X(J + 3)
          ENDIF
        ELSE
          X(J + 6) = 0.0
        ENDIF
        DO 20 I = 1, 2
          IF (N .GT. 0 .AND. N .LT. 196) THEN
            ISJ = IR(I, J, N)
          ELSE
            ISJ = 0
          ENDIF
          IF (ISJ .NE. 0) THEN
            XISJ = X(IABS(ISJ))
            IF (ISJ .LT. 0 .AND. NSM .GE. 0) XISJ = - XISJ
            X(J + 6) = X(J + 6) + XISJ
          ENDIF
   20   CONTINUE
   30 CONTINUE
      IF (ISWD .LT. 0) THEN
        X10 = MOD(X(10), 1.0)
        IF (X10 .GT. 0.5) THEN
          X10 = X10 - 1.0
        ELSE IF (X10 .LE. -0.5) THEN
          X10 = X10 + 1.0
        ENDIF
        X(10) = X10 * 360.0
      ENDIF
   40 RETURN
      END
      SUBROUTINE SG10 (X)
      PARAMETER (NOPR = 18, NSITE = 70)
      COMMON /CSPGR/ IS(3, 3, 48), ISBRV(4, 3), ISGNR, NSYMP, ICNTR,
     1 IBV, IKLS, LAUE, IR(3, 3, 195), ISV(3), IABC(6), JABC(6),
     2 R0(3, 3), R1(3, 3), R2(3, 4), R3(3, 3), T0(3), T3(3), OSFT(3),
     3 IINV, ISW, IBV0(7), IBV1(7), IBV2(18), ILAUE, IAXM, KSITE(NSITE),
     4 IOPR(NOPR), IORG(3, 3), JSMI, JSMX, NST, ISWD, JSWD, NSG(28),
     5 ITRNS, ICNTRX, IMPROP, IUIT, OCNT(3), NHRM(198), IHALL(9, 4),
     6 LRET, NSLOC(59), NSGF(230), NSGET, NTRNS, JLAUE, ISHEL, ITRL, IER
      DIMENSION X(12)
      NSL = NST
      N   = 195
   10 CALL SG05 (N, NSL)
      IF (IER .EQ. 0) THEN
        IJ = 0
        DO 30 I = 1, 3
          DO 20 J = 1, 3
            IJ = IJ + 1
            IDIF = IFIX(X(IJ)) - IR(I, J, N)
            IF (I .EQ. 3) THEN
              X(9 + J) = FLOAT(IDIF / 12)
              IDIF     = MOD(IDIF, 12)
            ENDIF
            IF (IDIF .NE. 0) THEN
              NSL = NSL - 1
              IF (NSL .GT. 0) THEN
                GOTO 10
              ELSE
                GOTO 40
              ENDIF
            ENDIF
   20     CONTINUE
   30   CONTINUE
   40   X(9) = NSL
      ENDIF
      RETURN
      END
      SUBROUTINE SG11 (X)
      PARAMETER (NOPR = 18, NSITE = 70)
      COMMON /CSPGR/ IS(3, 3, 48), ISBRV(4, 3), ISGNR, NSYMP, ICNTR,
     1 IBV, IKLS, LAUE, IR(3, 3, 195), ISV(3), IABC(6), JABC(6),
     2 R0(3, 3), R1(3, 3), R2(3, 4), R3(3, 3), T0(3), T3(3), OSFT(3),
     3 IINV, ISW, IBV0(7), IBV1(7), IBV2(18), ILAUE, IAXM, KSITE(NSITE),
     4 IOPR(NOPR), IORG(3, 3), JSMI, JSMX, NST, ISWD, JSWD, NSG(28),
     5 ITRNS, ICNTRX, IMPROP, IUIT, OCNT(3), NHRM(198), IHALL(9, 4),
     6 LRET, NSLOC(59), NSGF(230), NSGET, NTRNS, JLAUE, ISHEL, ITRL, IER
      DIMENSION X(12)
      IF (ISW .EQ. 9) X(5) = NST
      N   = 193
      NSL = NINT(X(1))
      CALL SG05 (N, NSL)
      IF (IER .EQ. 0) THEN
        DO 10 K = 1, 3
          IR(3, K, 193) = IR(3, K, 193) + NINT(X(K + 1)) * 12
   10   CONTINUE
        N   = 194
   20   NSL = NINT(X(5))
        CALL SG05 (N, NSL)
        IF (IER .EQ. 0) THEN
          IF (ISW .NE. 9) THEN
            DO 30 K = 1, 3
              IR(3, K, 194) = IR(3, K, 194) + NINT(X(5 + K)) * 12
   30       CONTINUE
          ENDIF
          CALL SG06
          IF (ISW .EQ. 9) THEN
            DO 50 K = 1, 3
              IF (IR(1, K, 195) .NE. K) GOTO 60
              IF (IR(2, K, 195) .NE. 0) GOTO 60
              IF (MOD(IABS(IR(3, K, 195)), 12) .NE. 0) GOTO 60
              ITS = - IR(3, K, 194)
              DO 40 I = 1, 2
                ISJ = IR(I, K, 194)
                IF (ISJ .NE. 0) THEN
                  ISS = IR(3, IABS(ISJ), 193)
                  IF (ISJ .LT. 0) ISS = - ISS
                  ITS = ITS - ISS
                ENDIF
   40         CONTINUE
              X(9 + K) = FLOAT(ITS / 12)
   50       CONTINUE
            X(9) = X(5)
            GOTO 90
   60       X(5) = X(5) - 1
            IF (X(5) .GT. 0) THEN
              GOTO 20
            ELSE
              IF (IUIT .NE. 0)
     1          WRITE (IUIT, '(A)') 'ERROR AT LABEL 60  (SGSM)'
              IER = 1
              GOTO 90
            ENDIF
          ENDIF
          IJ = 0
          DO 80 I = 1, 3
            DO 70 J = 1, 3
              IJ = IJ + 1
              X(IJ) = IR(I, J, 195)
   70       CONTINUE
   80     CONTINUE
          CALL SG10 (X)
        ENDIF
      ENDIF
   90 CONTINUE
      RETURN
      END
      SUBROUTINE SG12 (X, NSM)
      PARAMETER (NRSPGR = 336, NTRL = 174, NOPR = 18, NSITE = 70,
     1  NNH = 168)
      COMMON /CSPGR/ IS(3, 3, 48), ISBRV(4, 3), ISGNR, NSYMP, ICNTR,
     1 IBV, IKLS, LAUE, IR(3, 3, 195), ISV(3), IABC(6), JABC(6),
     2 R0(3, 3), R1(3, 3), R2(3, 4), R3(3, 3), T0(3), T3(3), OSFT(3),
     3 IINV, ISW, IBV0(7), IBV1(7), IBV2(18), ILAUE, IAXM, KSITE(NSITE),
     4 IOPR(NOPR), IORG(3, 3), JSMI, JSMX, NST, ISWD, JSWD, NSG(28),
     5 ITRNS, ICNTRX, IMPROP, IUIT, OCNT(3), NHRM(198), IHALL(9, 4),
     6 LRET, NSLOC(59), NSGF(230), NSGET, NTRNS, JLAUE, ISHEL, ITRL, IER
      COMMON /CSGSM/ ICH(43), SGT, NONST, NOSTP, SGSMC, YSPG, ZSPG,
     1 NHLA, NHLB, TRLTA, TRLTB, LINE, SHFL
      COMMON /SLAUE/ NLAUE, XSYST, IBVL, SITE
      CHARACTER SGT(NRSPGR)*32, LINE*80, NONST(294)*9,
     1 NOSTP(6)*4, YSPG*9, ZSPG*13, NLAUE(14)*5, XSYST(8)*12,
     2 ACENT*2, ICH*1, IBVL(8)*1, SGSMC*59, SITE(NSITE)*5,
     3 TRLTA(NTRL)*13, TRLTB(NTRL)*7, SHFL(230)*6, TXT*13,
     4 NHLA(NNH)*7, NHLB(NNH)*15, LZSPG*7
      DIMENSION X(12)
      M0   = 0
      NRSM = NSM
      ISWD = 3 - ISW
      IF (ICNTR .EQ. 1 .AND. ILAUE .LT. 0) THEN
        NSTT = NST * 2
      ELSE
        NSTT = NST
      ENDIF
      IF (ISWD .LT. 0) NSTT = NSTT / IBV
      IF (NRSM .GT. NSTT) NRSM = MOD(NRSM, NSTT)
      NSL = 1
      IF (NRSM .NE. 0) THEN
        NSL  = NRSM
        NSTT = NRSM
        GOTO 20
      ENDIF
      IF (ICNTRX .EQ. 2 .OR. ILAUE .LT. 0) THEN
        ACENT = ' C'
      ELSE
        ACENT = 'Ac'
      ENDIF
      IF (LAUE .EQ. 14) LAUE = JLAUE
      IF (IUIT .NE. 0) THEN
        N = INDEX (SGSMC(1:11), ':')
        IF (N .NE. 0) THEN
          TXT = SGSMC(1:11)
        ELSE IF (SGSMC(8:8) .NE. ' ') THEN
          TXT = SGSMC(1:7)//':'//SGSMC(8:11)
          LZSPG = ZSPG(1:7)
          CALL GEN020 (-1, LZSPG, 2, 7)
          DO 10 J = 1, NNH
            IF (LZSPG .EQ. NHLA(J)) SGSMC(33:49) = NHLB(J)
   10     CONTINUE
        ELSE
          TXT = SGSMC(1:7)
        ENDIF
        WRITE (IUIT, 99999) TXT, YSPG, ISGNR, NLAUE(LAUE), SGSMC(33:49),
     1      SGSMC(12:13), ACENT, XSYST(IKLS), NSTT, NSYMP, SGSMC(27:32)
      ENDIF
      IF (IUIT .EQ. 7) CALL PLA269 (6)
      IF (ICNTR .NE. ICNTRX) THEN
        IF (IUIT .NE. 0) WRITE (IUIT, 99994) OCNT(1), OCNT(2), OCNT(3)
        IF (IUIT .EQ. 7) CALL PLA269 (2)
      ENDIF
      IF (ILAUE .GT. 0) THEN
        IF (ICNTR .EQ. 1) THEN
          IF (IMPROP .GT. 0) THEN
            IF (IUIT .NE. 0) WRITE (IUIT, 99995) 'CHIRAL '
          ELSE
            IF (IUIT .NE. 0) WRITE (IUIT, 99995) 'ACHIRAL'
          ENDIF
          IF (IUIT .EQ. 7) CALL PLA269 (2)
        ENDIF
        IF (IUIT .NE. 0) WRITE (IUIT, 99998)
      ELSE
        IF (IUIT .NE. 0) WRITE (IUIT, 99997)
      ENDIF
   20 IF (ISW .EQ. 4) THEN
        ICHS = 26
      ELSE
        ICHS = 11
      ENDIF
      NSLB = NSL
      DO 40 NSLX = NSLB, NSTT
        NSL = NSLX
        N   = 195
        CALL SG05 (N, NSL)
        IF (IER .NE. 0) GOTO 50
        CALL GEN038 (LINE, 1, 80)
        DO 30 I = 1, 3
          IND = 17 * I - 6 + ISHEL * 4
          IF (I .LT. 3) LINE(IND + 2:IND + 2) = ','
          M = IR(2, I, N)
          IF (M .NE. 0) THEN
            LINE(IND:IND) = ICH(IABS(M) + ICHS)
            IF (M .LT. 0) THEN
              LINE(IND - 2:IND - 2) = '-'
            ELSE
              LINE(IND - 2:IND - 2) = '+'
            ENDIF
            IND = IND - 4
          ENDIF
          LINE(IND:IND) = ICH(IABS(IR(1, I, N)) + ICHS)
          IF (IR(1, I, N) .LT. 0) LINE(IND - 2:IND - 2) = '-'
          M = IR(3, I, N)
          IF (ITRL .NE. 0) M = M + ITRL * NINT(X(I + 3))
          IF (M .NE. 0) THEN
            IF (IR(1, I, N) .GT. 0) LINE(IND - 2:IND - 2) = '+'
            IF (ISHEL .EQ. 0) THEN
              IF (M .LT. 0) THEN
                M = - M
                IF (IND .GT. 8) LINE(IND - 8 : IND - 6) = '- -'
              ENDIF
              IF (MOD(M, 12) .EQ. 0) THEN
                M0 = 12
              ELSE IF (MOD(M, 6) .EQ. 0) THEN
                M0 = 6
              ELSE IF (MOD(M, 4) .EQ. 0) THEN
                M0 = 4
              ELSE IF (MOD(M, 3) .EQ. 0) THEN
                M0 = 3
              ELSE IF (MOD(M, 2) .EQ. 0) THEN
                M0 = 2
              ENDIF
              IF (M0 .NE. 12) THEN
                LINE(IND - 6:IND - 4) = ICH(M / M0)//'/'//ICH(12 / M0)
              ELSE
                LINE(IND - 4:IND - 4) = ICH(M / M0)
                IF (IND .GT. 8) LINE(IND - 8:IND - 8) = ' '
              ENDIF
            ELSE
              TRV = FLOAT(IR(3, I, N)) / 12.0
              WRITE (LINE(IND - 10:IND - 4), 99993) TRV
            ENDIF
          ENDIF
   30   CONTINUE
        IF (ITRL .NE. 0) CALL GEN047 (LINE, 1, 50)
        IF (IUIT .GT. 0) THEN
          IF (IUIT .EQ. 7) CALL PLA269 (1)
          IF (IUIT .NE. 0) WRITE (IUIT, 99996) NSL, LINE(1:60)
        ENDIF
   40 CONTINUE
   50 RETURN
99999 FORMAT ('Space Group ', 2A, 1X, 'No:', I4, ', Laue:', A,
     1 ' [Hall: ', A, ']', //, 'Lattice Type ', A, ', ', A,
     2 'entric, ', A, ', Order ' , I3, '(', I2, ')', ' [Schoenflies: ',
     3 A, 4X, ']', /)
99998 FORMAT (2X, 'Nr', 12X, '***** Symmetry Operation(s) *****', /)
99997 FORMAT (2X, 'Nr', 7X, 'Patterson/Laue Symmetry Operation', /)
99996 FORMAT (I4, 5X, A)
99995 FORMAT (A, ' - See P.G. Jones, Acta Cryst. ',
     1        '(1986), A42, 57.', /)
99994 FORMAT ('Shifted Inversion Centre at (', F6.3, ',', F6.3, ',',
     1        F6.3, ')', /)
99993 FORMAT (F7.5)
      END
      SUBROUTINE SG14 (X, TRDET)
      PARAMETER (NRSPGR = 336, NTRL = 174, NOPR = 18, NSITE = 70,
     1  NNH = 168)
      COMMON /CSPGR/ IS(3, 3, 48), ISBRV(4, 3), ISGNR, NSYMP, ICNTR,
     1 IBV, IKLS, LAUE, IR(3, 3, 195), ISV(3), IABC(6), JABC(6),
     2 R0(3, 3), R1(3, 3), R2(3, 4), R3(3, 3), T0(3), T3(3), OSFT(3),
     3 IINV, ISW, IBV0(7), IBV1(7), IBV2(18), ILAUE, IAXM, KSITE(NSITE),
     4 IOPR(NOPR), IORG(3, 3), JSMI, JSMX, NST, ISWD, JSWD, NSG(28),
     5 ITRNS, ICNTRX, IMPROP, IUIT, OCNT(3), NHRM(198), IHALL(9, 4),
     6 LRET, NSLOC(59), NSGF(230), NSGET, NTRNS, JLAUE, ISHEL, ITRL, IER
      COMMON /CSGSM/ ICH(43), SGT, NONST, NOSTP, SGSMC, YSPG, ZSPG,
     1 NHLA, NHLB, TRLTA, TRLTB, LINE, SHFL
      CHARACTER SGT(NRSPGR)*32, LINE*80, NONST(294)*9, NOSTP(6)*4,
     1 YSPG*9, ZSPG*13, XSPG*12, ICH*1, SGSMC*59, NONSTJ*9,
     2 TRLTA(NTRL)*13, TRLTB(NTRL)*7, SHFL(230)*6,
     3 NHLA(NNH)*7, NHLB(NNH)*15
      DIMENSION X(12)
      CHARACTER CH*1
      ISGN = 0
   10 DO 20 I = 5,80
        CH = LINE(I:I)
        IF (CH .EQ. '(' .OR. CH .EQ. ')' .OR.
     1      CH .EQ. '_' .OR. CH .EQ. '~') THEN
          LINE(I:I) = ' '
        ELSE IF (CH .EQ. ICH(20) .OR. CH .EQ. ICH(21)) THEN
          LINE(I:I) = ' '
          ITRNS = 0
          NTRNS = 0
        ENDIF
   20 CONTINUE
      CALL GEN047 (LINE, 5, 80)
      DO 40 I = 1, NTRL
        J = INDEX (LINE, TRLTA(I))
        IF (J .NE. 0) THEN
          LINE(J:) = TRLTB(I)
          GOTO 50
        ENDIF
   40 CONTINUE
   50 CALL SG03 (X, TRDET, 1)
      IF (IER .NE. 0) GOTO 110
      JJ  = 0
      KK  = 0
      IMD = 0
      CALL GEN038 (SGSMC, 1, 11)
      I = INDEX (LINE, ':')
      IF (I .NE. 0) THEN
        IF (LINE(I:I+1) .NE. ':1' .AND. LINE(I:I+1) .NE. ':2') THEN
          LINE(I:I) = '.'
        ENDIF
      ENDIF
      DO 70 I = 5, 80
        IF (LINE(I:I) .EQ. '.') THEN
          IMD  = 1
          ISGN = 1
        ELSE
          IF (IMD .EQ. 0) THEN
            JJ = JJ + 1
            IF (JJ .GT. 9) GOTO 80
            SGSMC(JJ:JJ) = LINE(I:I)
            IF (JJ .EQ. 1) THEN
              SGSMC(13:13) = SGSMC(1:1)
            ELSE
              IF (SGSMC(JJ:JJ) .EQ. 'R') SGSMC(13:13) = 'P'
            ENDIF
          ELSE
            KK = KK + 1
            IF (KK .GT. 4) GOTO 80
            SGSMC(KK + 7:KK + 7) = LINE(I:I)
            IF (LINE(I:I) .EQ. '-') ISGN = -1
            DO 60 L0 = 1, 3
              IF (LINE(I:I) .EQ. CHAR(ICHAR('A') - 1 + L0)) THEN
                IABC(L0 + 3) = ISGN
                JABC(L0 + 3) = IMD
                IMD          = IMD + 1
                ISGN         = 1
              ENDIF
   60       CONTINUE
            IF (IMD .EQ. 4) GOTO 80
          ENDIF
        ENDIF
   70 CONTINUE
   80 IF (IMD .EQ. 0) THEN
        ZSPG = SGSMC(1:9)
      ELSE
        ZSPG = SGSMC(1:7)
      ENDIF
      IF (ITRNS .EQ. 1) THEN
        CALL GEN038 (SGSMC,  1, 11)
        CALL GEN038 (SGSMC, 15, 32)
        CALL SG08 (TRDET)
      ELSE
        IF (SGSMC(1:1) .EQ. 'A') THEN
          SGSMC(13:13) = CHAR(ICHAR('A') + JABC(4) - 1)
        ELSE IF (SGSMC(1:1) .EQ. 'B') THEN
          SGSMC(13:13) = CHAR(ICHAR('A') + JABC(5) - 1)
        ELSE IF (SGSMC(1:1) .EQ. 'C') THEN
          SGSMC(13:13) = CHAR(ICHAR('A') + JABC(6) - 1)
        ENDIF
      ENDIF
      DO 90 JJ = 1, NRSPGR
        XSPG = SGT(JJ)(1:12)
        CALL GEN047 (XSPG, 1, 12)
        IF (ZSPG(1:9) .EQ. XSPG(1:9)) THEN
          READ (SGT(JJ)(13:15), 99988) ISGNR
          IF (SGSMC(15:15) .EQ. ' ') THEN
            SGSMC(15:54) = SGT(JJ)(1:12)//SHFL(ISGNR)//SGT(JJ)(16:32)
          ELSE
            SGSMC(38:54) = SGT(JJ)(16:32)
          ENDIF
          WRITE (SGSMC(55:59), 99987) NSGF(ISGNR)
          LINE = '    '//SGT(JJ)(16:32)
          IF (ITRNS .EQ. 1) THEN
            IKLS  = 8
            ISGNR = 0
          ENDIF
          CALL SG01 (1)
          IF (IER .NE. 0) GOTO 110
          GOTO 120
        ENDIF
   90 CONTINUE
      YSPG(1:9) = '['//ZSPG(1:7)//']'
      DO 100 J = 1, 294
        NONSTJ = NONST(J)
        CALL GEN047 (NONSTJ, 1, 9)
        IF (ZSPG(1:9) .EQ. NONSTJ) THEN
          SGSMC(15:24) = NONST(J)
          JA = ((J - 1) / 6) * 6
          WRITE (LINE, 99989) NONST(JA + 1), NOSTP(J - JA)
          GOTO 10
        ENDIF
  100 CONTINUE
      IF (IUIT .NE. 0) WRITE (IUIT, 99999) SGSMC(1:11)
      CALL SG03 (X, TRDET, 1)
      IER  = 5
      NST  = 0
  110 LRET = 3
      RETURN
  120 LRET = 2
      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.', /)
99989 FORMAT ('SPGR ',A, '.', A, 61X)
99988 FORMAT (I3)
99987 FORMAT (I5)
      END
      SUBROUTINE SG15 (LIN, X, NSM)
      PARAMETER (NRSPGR = 336, NTRL = 174, NOPR = 18, NSITE = 70,
     1  NNH = 168)
      COMMON /SLAUE/ NLAUE, XSYST, IBVL, SITE
      COMMON /CSPGR/ IS(3, 3, 48), ISBRV(4, 3), ISGNR, NSYMP, ICNTR,
     1 IBV, IKLS, LAUE, IR(3, 3, 195), ISV(3), IABC(6), JABC(6),
     2 R0(3, 3), R1(3, 3), R2(3, 4), R3(3, 3), T0(3), T3(3), OSFT(3),
     3 IINV, ISW, IBV0(7), IBV1(7), IBV2(18), ILAUE, IAXM, KSITE(NSITE),
     4 IOPR(NOPR), IORG(3, 3), JSMI, JSMX, NST, ISWD, JSWD, NSG(28),
     5 ITRNS, ICNTRX, IMPROP, IUIT, OCNT(3), NHRM(198), IHALL(9, 4),
     6 LRET, NSLOC(59), NSGF(230), NSGET, NTRNS, JLAUE, ISHEL, ITRL, IER
      COMMON /CSGSM/ ICH(43), SGT, NONST, NOSTP, SGSMC, YSPG, ZSPG,
     1 NHLA, NHLB, TRLTA, TRLTB, LINE, SHFL
      CHARACTER SGT(NRSPGR)*32, LINE*80, NONST(294)*9, NOSTP(6)*4,
     1 YSPG*9, ZSPG*13, ICH*1, SGSMC*59,
     2 TRLTA(NTRL)*13, TRLTB(NTRL)*7, SHFL(230)*6,
     3 NHLA(NNH)*7, NHLB(NNH)*15
      CHARACTER LZSPG*7, XIMP*2, LIN*(*), NLAUE(14)*5, XSYST(8)*12,
     1 IBVL(8)*1, SITE(NSITE)*5
      DIMENSION X(12)
      IF (SGSMC(8:8) .NE. ' ') THEN
        DO 10 I = 2, 6
          IF (SGSMC(8:11) .EQ. 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)
            GOTO 20
          ENDIF
   10   CONTINUE
      ENDIF
   20 CALL GEN020 (-1, SGSMC, 2, 11)
      CALL GEN020 (-1, YSPG,  3, 8)
      IF (ISW .NE. 18) THEN
        CALL SG12 (X, NSM)
        LIN = LINE
      ELSE
        IF (LAUE .EQ. 14) LAUE = JLAUE
        X(1) = ISGNR
        X(2) = IKLS
        X(3) = LAUE
        X(4) = NSYMP
        X(5) = ICNTR
        X(6) = IBV
        X(9) = NST
        DO 30 I = 1, 7
          IF (SGSMC(13:13) .EQ. ICH(29 + I)) X(7) = I
          IF (SGSMC(13:13) .EQ. ICH(36 + I)) X(8) = I
   30   CONTINUE
        IF (SGSMC(14:14) .EQ. 'A') X(8) = - X(8)
        IF (IMPROP .GT. 0 .AND. ICNTR .EQ. 1) THEN
          XIMP = ' C'
        ELSE
          XIMP = '  '
        ENDIF
        LZSPG = ZSPG(1:7)
        CALL GEN020 (-1, LZSPG, 2, 7)
        IF (SGSMC(9:9) .EQ. ' ') THEN
          ZSPG = SGSMC(1:7)
        ELSE
          DO 40 J = 1, NNH
            IF (LZSPG .EQ. NHLA(J)) SGSMC(33:54) = NHLB(J)
   40     CONTINUE
        ENDIF
        LIN =
     1 SGSMC(1:26)//XSYST(IKLS)//NLAUE(LAUE)//SGSMC(33:59)//XIMP//LZSPG
        DO 60 J = 1, 3
          X(J + 9) = 0.0
          IF (ICNTR .EQ. 1) THEN
            DO 50 I = 1, 3
              IF (IORG(I, J) .NE. 0) X(J + 9) = X(J + 9) + 2 ** (I - 1)
   50       CONTINUE
          ENDIF
   60   CONTINUE
      ENDIF
      RETURN
      END
      BLOCK DATA SGSMD
      PARAMETER (NRSPGR = 336, NTRL = 174, NOPR = 18, NSITE = 70,
     1  NNH = 168)
      COMMON /CSPGR/ IS(3, 3, 48), ISBRV(4, 3), ISGNR, NSYMP, ICNTR,
     1 IBV, IKLS, LAUE, IR(3, 3, 195), ISV(3), IABC(6), JABC(6),
     2 R0(3, 3), R1(3, 3), R2(3, 4), R3(3, 3), T0(3), T3(3), OSFT(3),
     3 IINV, ISW, IBV0(7), IBV1(7), IBV2(18), ILAUE, IAXM, KSITE(NSITE),
     4 IOPR(NOPR), IORG(3, 3), JSMI, JSMX, NST, ISWD, JSWD, NSG(28),
     5 ITRNS, ICNTRX, IMPROP, IUIT, OCNT(3), NHRM(198), IHALL(9, 4),
     6 LRET, NSLOC(59), NSGF(230), NSGET, NTRNS, JLAUE, ISHEL, ITRL, IER
      COMMON /CSGSM/ ICH(43), SGT, NONST, NOSTP, SGSMC, YSPG, ZSPG,
     1 NHLA, NHLB, TRLTA, TRLTB, LINE, SHFL
      COMMON /SLAUE/ NLAUE, XSYST, IBVL, SITE
      CHARACTER SGT(NRSPGR)*32, LINE*80, NONST(294)*9, NOSTP(6)*4,
     1 NLAUE(14)*5, XSYST(8)*12, ICH*1, IBVL(8)*1, SGSMC*59, YSPG*9,
     2 SITE(NSITE)*5, ZSPG*13, TRLTA(NTRL)*13, TRLTB(NTRL)*7,
     3 SHFL(230)*6, NHLA(NNH)*7, NHLB(NNH)*15
      DATA NLAUE /
     1  '   -1', '  2/m', '  mmm', '  4/m', '4/mmm', '   -3', ' -3m1',
     2  ' -31m', '  6/m', '6/mmm', '  m-3', ' m-3m', '     ', '  -3m'/
      DATA XSYST /'   Triclinic', '  Monoclinic', 'Orthorhombic',
     1            '  Tetragonal', '    Trigonal', '   Hexagonal',
     2            '       Cubic', '            '/
      DATA 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.'/
      DATA 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/
      DATA IOPR /-162,  132, -132,  134, -134,   160, -160, 156, -156,
     1            138, -138,  152, -142,   72, -4650,  -68, -30,   26/
      DATA NOSTP /'ABC ', 'BA-C', 'CAB ', '-CBA', 'BCA ', 'A-CB'/
      DATA IBV0 /1, 2, 2, 2, 4, 2, 3/
      DATA IBV1 /0, 1, 4, 7, 1, 10, 13/
      DATA IBV2 /0, 6, 6, 6, 0, 6, 6, 6, 0, 6, 6, 6, 4, 8, 8, 8, 4, 4/
      DATA IBVL /'a', 'm', 'o', 't', 'r', 'h', 'c', ' '/
      DATA ICH /'1','2','3','4','5','6','7','8','9','0','.','X','Y','Z',
     1  ' ',',','+','-','/','[',']','A',' ','B','C','I','H','K','L','P',
     2  'A','B','C','F','I','R','P','I','R','F','A','B','C'/
      DATA (NHRM(I), I = 1, 198)/
     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/
      DATA (NSGF(I), I = 1, 171) /
     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/
      DATA (NSGF(I), I = 172, 230) /
     1    -6,    59,     3,     1,   164,     0,    16,     5,     7,
     2    -7,     4,     2,     0,     4,    24,     0,     0,     4,
     3    13,     3,     7,     1,    20,     0,     2,     6,    58,
     4     1,     3,     3,     4,     3,     9,    88,     8,     2,
     5     0,     2,     1,     0,     5,    -5,     0,     8,     7,
     6    25,    15,     8,    15,    10,     9,     5,     4,    24,
     7     2,    16,     7,    20,     1/
      DATA (SHFL(I), I = 1, 114) /
     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 '/
      DATA (SHFL(I), I = 115, 228) /
     1 'D2d^5 ', 'D2d^6 ', 'D2d^7 ', 'D2d^8 ', 'D2d^9 ', 'D2d^10',
     2 'D2d^11', 'D2d^12', 'D4h^1 ', 'D4h^2 ', 'D4h^3 ', 'D4h^4 ',
     3 'D4h^5 ', 'D4h^6 ', 'D4h^7 ', 'D4h^8 ', 'D4h^9 ', 'D4h^10',
     4 'D4h^11', 'D4h^12', 'D4h^13', 'D4h^14', 'D4h^15', 'D4h^16',
     5 'D4h^17', 'D4h^18', 'D4h^19', 'D4h^20', 'C3^1  ', 'C3^2  ',
     6 'C3^3  ', 'C3^4  ', 'C3i^1 ', 'C3i^2 ', 'D3^1  ', 'D3^2  ',
     7 'D3^3  ', 'D3^4  ', 'D3^5  ', 'D3^6  ', 'D3^7  ', 'C3v^1 ',
     8 'C3v^2 ', 'C3v^3 ', 'C3v^4 ', 'C3v^5 ', 'C3v^6 ', 'D3d^1 ',
     9 'D3d^2 ', 'D3d^3 ', 'D3d^4 ', 'D3d^5 ', 'D3d^6 ', 'C6^1  ',
     * 'C6^2  ', 'C6^3  ', 'C6^4  ', 'C6^5  ', 'C6^6  ', 'C3h^1 ',
     1 'C6h^1 ', 'C6h^2 ', 'D6^1  ', 'D6^2  ', 'D6^3  ', 'D6^4  ',
     2 'D6^5  ', 'D6^6  ', 'C6v^1 ', 'C6v^2 ', 'C6v^3 ', 'C6v^4 ',
     3 'D3h^1 ', 'D3h^2 ', 'D3h^3 ', 'D3h^4 ', 'D6h^1 ', 'D6h^2 ',
     4 'D6h^3 ', 'D6h^4 ', 'T^1   ', 'T^2   ', 'T^3   ', 'T^4   ',
     5 'T^5   ', 'Th^1  ', 'Th^2  ', 'Th^3  ', 'Th^4  ', 'Th^5  ',
     6 'Th^6  ', 'Th^7  ', 'O^1   ', 'O^2   ', 'O^3   ', 'O^4   ',
     7 'O^5   ', 'O^6   ', 'O^7   ', 'O^8   ', 'Td^1  ', 'Td^2  ',
     8 'Td^3  ', 'Td^4  ', 'Td^5  ', 'Td^6  ', 'Oh^1  ', 'Oh^2  ',
     9 'Oh^3  ', 'Oh^4  ', 'Oh^5  ', 'Oh^6  ', 'Oh^7  ', 'Oh^8  '/
      DATA (SHFL(I), I = 229, 230) /
     1 'Oh^9  ', 'Oh^10 '/
      DATA (NSG(I), I = 1, 28) /1, 14, 15, 80, 81, 153, 154, 170, 171,
     1 234, 235, 242, 243, 266, 243, 266, 267, 275, 276, 293, 294, 308,
     2 309, NRSPGR, 1, NRSPGR, 243, 266/
      DATA (SGT(I), I = 1, 14)/
     1 'P 1           1 P 1             ',
     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          2-P 1             ',
     9 'A -1          2-A 1             ',
     * 'B -1          2-B 1             ',
     1 'C -1          2-C 1             ',
     2 'I -1          2-I 1             ',
     3 'F -1          2-F 1             ',
     4 'R -1          2-R 1             '/
      DATA (SGT(I), I = 15, 32)/
     1 'P 2           3 P 2y            ',
     2 'P 2 1 1       3 P 2x            ',
     3 'P 1 1 2       3 P 2             ',
     4 'P 21          4 P 2yb           ',
     5 'P 21 1 1      4 P 2xa           ',
     6 'P 1 1 21      4 P 2c            ',
     7 'C 2           5 C 2y            ',
     8 'C 21          5 C 2yb           ',
     9 'A 2           5 A 2y            ',
     * 'I 2           5 I 2y            ',
     1 'I 21          5 I 2yb           ',
     2 'F 2           5 F 2y            ',
     3 'A 1 1 2       5 A 2             ',
     4 'B 1 1 2       5 B 2             ',
     5 'I 1 1 2       5 I 2             ',
     6 'P M           6 P -2y           ',
     7 'P 1 1 M       6 P -2            ',
     8 'P C           7 P -2yc          '/
      DATA (SGT(I), I = 33, 48)/
     1 'P C S         7 P -2ybc         ',
     2 'P A           7 P -2ya          ',
     3 'P N           7 P -2yac         ',
     4 'P N S         7 P -2yabc        ',
     5 'P 1 1 A       7 P -2a           ',
     6 'P 1 1 B       7 P -2b           ',
     7 'P 1 1 N       7 P -2ab          ',
     8 'C M           8 C -2y           ',
     9 'A M           8 A -2y           ',
     * 'B 1 1 M       8 B -2            ',
     1 'C C           9 C -2yc          ',
     2 'I C           9 I -2yc          ',
     3 'I A           9 I -2ya          ',
     4 'A A           9 A -2ya          ',
     5 'A N           9 A -2yac         ',
     6 'B 1 1 B       9 B -2b           '/
      DATA (SGT(I), I = 49, 65)/
     1 'P 2/M        10-P 2y            ',
     2 'P 1 1 2/M    10-P 2             ',
     3 'P 2/M 1 1    10-P 2x            ',
     4 'P 21/M       11-P 2yb           ',
     5 'P 1 1 21/M   11-P 2c            ',
     6 'P 21/M 1 1   11-P 2xa           ',
     7 'C 2/M        12-C 2y            ',
     8 'A 2/M        12-A 2y            ',
     9 'A 1 1 2/M    12-A 2             ',
     * 'B 1 1 2/M    12-B 2             ',
     1 'I 1 1 2/M    12-I 2             ',
     2 'I 2/M        12-I 2y            ',
     3 'I 1 1 2/B    12-I 2b            ',
     4 'I 1 1 2/A    12-I 2a            ',
     5 'P 2/C        13-P 2yc           ',
     6 'P 2/A        13-P 2ya           ',
     7 'P 2/N        13-P 2yac          '/
      DATA (SGT(I), I = 66, 80)/
     1 'P 1 1 2/B    13-P 2b            ',
     2 'P 21/C       14-P 2ybc          ',
     3 'P 21/A       14-P 2yab          ',
     4 'P 1 1 21/A   14-P 2ac           ',
     5 'P 1 1 21/B   14-P 2bc           ',
     6 'P 21/N       14-P 2yn           ',
     7 'P 1 1 21/N   14-P 2n            ',
     8 'P 21/N 1 1   14-P 2xn           ',
     9 'B 21/C       14-B 2ybc          ',
     9 'C 2/C        15-C 2yc           ',
     * 'A 2/A        15-A 2ya           ',
     1 'C 2/N        15-C 2ybc          ',
     2 'I 2/C        15-I 2yc           ',
     3 'I 2/A        15-I 2ya           ',
     4 'B 1 1 2/B    15-B 2b            '/
      DATA (SGT(I), I = 81, 89)/
     1 'P 2 2 2      16 P 2 2           ',
     2 'P 2 2 21     17 P 2c 2          ',
     3 'P 21 21 2    18 P 2 2ab         ',
     4 'P 21 21 21   19 P 2ac 2ab       ',
     5 'C 2 2 21     20 C 2c 2          ',
     6 'C 2 2 2      21 C 2 2           ',
     7 'F 2 2 2      22 F 2 2           ',
     8 'I 2 2 2      23 I 2 2           ',
     9 'I 21 21 21   24 I 2b 2c         '/
      DATA (SGT(I), I = 90, 99)/
     * 'P M M 2      25 P 2 -2          ',
     1 'P M C 21     26 P 2c -2         ',
     2 'P C C 2      27 P 2 -2c         ',
     3 'P M A 2      28 P 2 -2a         ',
     4 'P C A 21     29 P 2c -2ac       ',
     5 'P N C 2      30 P 2 -2bc        ',
     6 'P M N 21     31 P 2ac -2        ',
     7 'P B A 2      32 P 2 -2ab        ',
     8 'P N A 21     33 P 2c -2n        ',
     9 'P N N 2      34 P 2 -2n         '/
      DATA (SGT(I), I = 100, 118)/
     1 'C M M 2      35 C 2 -2          ',
     2 'C M C 21     36 C 2c -2         ',
     3 'C C C 2      37 C 2 -2c         ',
     4 'A M M 2      38 A 2 -2          ',
     5 'A B M 2      39 A 2 -2c         ',
     6 'A M A 2      40 A 2 -2a         ',
     7 'A B A 2      41 A 2 -2ac        ',
     8 'F M M 2      42 F 2 -2          ',
     9 'F D D 2      43 F 2 -2d         ',
     * 'I M M 2      44 I 2 -2          ',
     1 'I B A 2      45 I 2 -2c         ',
     2 'I M A 2      46 I 2 -2a         ',
     3 'P M M M      47-P 2 2           ',
     4 'P N N N:1    48 P 2 2 -1n       ',
     5 'P N N N      48-P 2ab 2bc       ',
     6 'P C C M      49-P 2 2c          ',
     7 'P B A N:1    50 P 2 2 -1ab      ',
     8 'P N C B:1    50 P 2 2 -1bc      ',
     9 'P C N A:1    50 P 2 2 -1ac      '/
      DATA (SGT(I), I = 119, 137)/
     1 'P B A N      50-P 2ab 2b        ',
     2 'P M M A      51-P 2a 2a         ',
     3 'P N N A      52-P 2a 2bc        ',
     4 'P M N A      53-P 2ac 2         ',
     5 'P C C A      54-P 2a 2ac        ',
     6 'P B A M      55-P 2 2ab         ',
     7 'P C C N      56-P 2ab 2ac       ',
     8 'P B C M      57-P 2c 2b         ',
     9 'P N N M      58-P 2 2n          ',
     * 'P M M N:1    59 P 2 2ab -1ab    ',
     1 'P N M M:1    59 P 2bc 2 -1bc    ',
     2 'P M N M:1    59 P 2ac 2ac -1ac  ',
     3 'P M M N      59-P 2ab 2a        ',
     4 'P B C N      60-P 2n 2ab        ',
     5 'P B C A      61-P 2ac 2ab       ',
     6 'P N M A      62-P 2ac 2n        ',
     7 'C M C M      63-C 2c 2          ',
     8 'C M C A      64-C 2bc 2         ',
     9 'C M M M      65-C 2 2           '/
      DATA (SGT(I), I = 138, 153)/
     1 'C C C M      66-C 2 2c          ',
     2 'C M M A      67-C 2b 2          ',
     3 'C C C A:1    68 C 2 2 -1bc      ',
     4 'C C C B:1    68 C 2 2 -1bc      ',
     5 'A B A A:1    68 A 2 2 -1ac      ',
     6 'A C A A:1    68 A 2 2 -1ac      ',
     7 'B B C B:1    68 B 2 2 -1bc      ',
     8 'B B A B:1    68 B 2 2 -1bc      ',
     9 'C C C A      68-C 2b 2bc        ',
     * 'F M M M      69-F 2 2           ',
     1 'F D D D:1    70 F 2 2 -1d       ',
     2 'F D D D      70-F 2uv 2vw       ',
     3 'I M M M      71-I 2 2           ',
     4 'I B A M      72-I 2 2c          ',
     5 'I B C A      73-I 2b 2c         ',
     6 'I M M A      74-I 2b 2          '/
      DATA (SGT(I), I = 154, 170)/
     1 'P 4          75 P 4             ',
     2 'P 41         76 P 4w            ',
     3 'P 42         77 P 4c            ',
     4 'P 43         78 P 4cw           ',
     5 'I 4          79 I 4             ',
     6 'I 41         80 I 4bw           ',
     7 'P -4         81 P -4            ',
     8 'I -4         82 I -4            ',
     9 'P 4/M        83-P 4             ',
     * 'P 42/M       84-P 4c            ',
     1 'P 4/N:1      85 P 4ab -1ab      ',
     2 'P 4/N        85-P 4a            ',
     3 'P 42/N:1     86 P 4n -1n        ',
     4 'P 42/N       86-P 4bc           ',
     5 'I 4/M        87-I 4             ',
     6 'I 41/A:1     88 I 4bw -1bw      ',
     7 'I 41/A       88-I 4ad           '/
      DATA (SGT(I), I = 171, 185)/
     1 'P 4 2 2      89 P 4 2           ',
     2 'P 4 21 2     90 P 4ab 2ab       ',
     3 'P 41 2 2     91 P 4w 2c         ',
     4 'P 41 21 2    92 P 4abw 2nw      ',
     5 'P 42 2 2     93 P 4c 2          ',
     6 'P 42 21 2    94 P 4n 2n         ',
     7 'P 43 2 2     95 P 4cw 2c        ',
     8 'P 43 21 2    96 P 4nw 2abw      ',
     9 'I 4 2 2      97 I 4 2           ',
     * 'I 41 2 2     98 I 4bw 2bw       ',
     1 'P 4 M M      99 P 4 -2          ',
     2 'P 4 B M     100 P 4 -2ab        ',
     3 'P 42 C M    101 P 4c -2c        ',
     4 'P 42 N M    102 P 4n -2n        ',
     5 'P 4 C C     103 P 4 -2c         '/
      DATA (SGT(I), I = 186, 204)/
     1 'P 4 N C     104 P 4 -2n         ',
     2 'P 42 M C    105 P 4c -2         ',
     3 'P 42 B C    106 P 4c -2ab       ',
     4 'I 4 M M     107 I 4 -2          ',
     5 'I 4 C M     108 I 4 -2c         ',
     6 'I 41 M D    109 I 4bw -2        ',
     7 'I 41 C D    110 I 4bw -2c       ',
     8 'P -4 2 M    111 P -4 2          ',
     9 'P -4 2 C    112 P -4 2c         ',
     * 'P -4 21 M   113 P -4 2ab        ',
     1 'P -4 21 C   114 P -4 2n         ',
     2 'P -4 M 2    115 P -4 -2         ',
     3 'P -4 C 2    116 P -4 -2c        ',
     4 'P -4 B 2    117 P -4 -2ab       ',
     5 'P -4 N 2    118 P -4 -2n        ',
     6 'I -4 M 2    119 I -4 -2         ',
     7 'I -4 C 2    120 I -4 -2c        ',
     8 'I -4 2 M    121 I -4 2          ',
     9 'I -4 2 D    122 I -4 2bw        '/
      DATA (SGT(I), I = 205, 220)/
     1 'P 4/M M M   123-P 4 2           ',
     2 'P 4/M C C   124-P 4 2c          ',
     3 'P 4/N B M:1 125 P 4 2 -1ab      ',
     4 'P 4/N B M   125-P 4a 2b         ',
     5 'P 4/N N C:1 126 P 4 2 -1n       ',
     6 'P 4/N N C   126-P 4a 2bc        ',
     7 'P 4/M B M   127-P 4 2ab         ',
     8 'P 4/M N C   128-P 4 2n          ',
     9 'P 4/N M M:1 129 P 4ab 2ab -1ab  ',
     * 'P 4/N M M   129-P 4a 2a         ',
     1 'P 4/N C C:1 130 P 4ab 2n -1ab   ',
     2 'P 4/N C C   130-P 4a 2ac        ',
     3 'P 42/M M C  131-P 4c 2          ',
     4 'P 42/M C M  132-P 4c 2c         ',
     5 'P 42/N B C:1133 P 4n 2c -1n     ',
     6 'P 42/N B C  133-P 4ac 2b        '/
      DATA (SGT(I), I = 221, 234)/
     1 'P 42/N N M:1134 P 4n 2 -1n      ',
     2 'P 42/N N M  134-P 4ac 2bc       ',
     3 'P 42/M B C  135-P 4c 2ab        ',
     4 'P 42/M N M  136-P 4n 2n         ',
     5 'P 42/N M C:1137 P 4n 2n -1n     ',
     6 'P 42/N M C  137-P 4ac 2a        ',
     7 'P 42/N C M:1138 P 4n 2ab -1n    ',
     8 'P 42/N C M  138-P 4ac 2ac       ',
     9 'I 4/M M M   139-I 4 2           ',
     * 'I 4/M C M   140-I 4 2c          ',
     1 'I 41/A M D:1141 I 4bw 2bw -1bw  ',
     2 'I 41/A M D  141-I 4bd 2         ',
     3 'I 41/A C D:1142 I 4bw 2aw -1bw  ',
     4 'I 41/A C D  142-I 4bd 2c        '/
      DATA (SGT(I), I = 235, 252)/
     2 'P 3         143 P 3             ',
     3 'P 31        144 P 31            ',
     4 'P 32        145 P 32            ',
     5 'R 3         146 R 3             ',
     6 'R 3 R       146 P 3*            ',
     7 'P -3        147-P 3             ',
     8 'R -3        148-R 3             ',
     9 'R -3 R      148-P 3*            ',
     * 'P 3 1 2     149 P 3 2           ',
     1 'P 3 2 1     150 P 3 2"          ',
     2 'P 31 1 2    151 P 31 2c (0 0 1) ',
     3 'P 31 2 1    152 P 31 2"         ',
     4 'P 32 1 2    153 P 32 2c (0 0 -1)',
     5 'P 32 2 1    154 P 32 2"         ',
     6 'R 3 2       155 R 3 2"          ',
     7 'R 3 2 R     155 P 3* 2          ',
     8 'P 3 M 1     156 P 3 -2"         ',
     9 'P 3 1 M     157 P 3 -2          '/
      DATA (SGT(I), I = 253, 271)/
     1 'P 3 C 1     158 P 3 -2"c        ',
     2 'P 3 1 C     159 P 3 -2c         ',
     3 'R 3 M       160 R 3 -2"         ',
     4 'R 3 M R     160 P 3* -2         ',
     5 'R 3 C       161 R 3 -2"c        ',
     6 'R 3 C R     161 P 3* -2n        ',
     7 'P -3 1 M    162-P 3 2           ',
     8 'P -3 1 C    163-P 3 2c          ',
     9 'P -3 M 1    164-P 3 2"          ',
     * 'P -3 C 1    165-P 3 2"c         ',
     1 'R -3 M      166-R 3 2"          ',
     2 'R -3 M R    166-P 3* 2          ',
     3 'R -3 C      167-R 3 2"c         ',
     4 'R -3 C R    167-P 3* 2n         ',
     5 'P 6         168 P 6             ',
     6 'P 61        169 P 61            ',
     7 'P 65        170 P 65            ',
     8 'P 62        171 P 62            ',
     9 'P 64        172 P 64            '/
      DATA (SGT(I), I = 272, 290)/
     1 'P 63        173 P 6c            ',
     2 'P -6        174 P -6            ',
     3 'P 6/M       175-P 6             ',
     4 'P 63/M      176-P 6c            ',
     5 'P 6 2 2     177 P 6 2           ',
     6 'P 61 2 2    178 P 61 2 (0 0 -1) ',
     7 'P 65 2 2    179 P 65 2 ( 0 0 1) ',
     8 'P 62 2 2    180 P 62 2c (0 0 1) ',
     9 'P 64 2 2    181 P 64 2c (0 0 -1)',
     * 'P 63 2 2    182 P 6c 2c         ',
     1 'P 6 M M     183 P 6 -2          ',
     2 'P 6 C C     184 P 6 -2c         ',
     3 'P 63 C M    185 P 6c -2         ',
     4 'P 63 M C    186 P 6c -2c        ',
     5 'P -6 M 2    187 P -6 2          ',
     6 'P -6 C 2    188 P -6c 2         ',
     7 'P -6 2 M    189 P -6 -2         ',
     8 'P -6 2 C    190 P -6c -2c       ',
     9 'P 6/M M M   191-P 6 2           '/
      DATA (SGT(I), I = 291, 308)/
     1 'P 6/M C C   192-P 6 2c          ',
     2 'P 63/M C M  193-P 6c 2          ',
     3 'P 63/M M C  194-P 6c 2c         ',
     4 'P 2 3       195 P 2 2 3         ',
     5 'F 2 3       196 F 2 2 3         ',
     6 'I 2 3       197 I 2 2 3         ',
     7 'P 21 3      198 P 2ac 2ab 3     ',
     8 'I 21 3      199 I 2b 2c 3       ',
     9 'P M -3      200-P 2 2 3         ',
     * 'P N -3:1    201 P 2 2 3 -1n     ',
     1 'P N -3      201-P 2ab 2bc 3     ',
     2 'F M -3      202-F 2 2 3         ',
     3 'F D -3:1    203 F 2 2 3 -1d     ',
     4 'F D -3      203-F 2uv 2vw 3     ',
     5 'I M -3      204-I 2 2 3         ',
     6 'P A -3      205-P 2ac 2ab 3     ',
     7 'P B -3      205-P 2bc 2ac 3     ',
     8 'I A -3      206-I 2b 2c 3       '/
      DATA (SGT(I), I = 309, 322)/
     1 'P 4 3 2     207 P 4 2 3         ',
     2 'P 42 3 2    208 P 4n 2 3        ',
     3 'F 4 3 2     209 F 4 2 3         ',
     4 'F 41 3 2    210 F 4d 2 3        ',
     5 'I 4 3 2     211 I 4 2 3         ',
     6 'P 43 3 2    212 P 4acd 2ab 3    ',
     7 'P 41 3 2    213 P 4bd 2ab 3     ',
     8 'I 41 3 2    214 I 4bd 2c 3      ',
     9 'P -4 3 M    215 P -4 2 3        ',
     * 'F -4 3 M    216 F -4 2 3        ',
     1 'I -4 3 M    217 I -4 2 3        ',
     2 'P -4 3 N    218 P -4n 2 3       ',
     3 'F -4 3 C    219 F -4c 2 3       ',
     4 'I -4 3 D    220 I -4bd 2c 3     '/
      DATA (SGT(I), I = 323, NRSPGR)/
     1 'P M -3 M    221-P 4 2 3         ',
     2 'P N -3 N:1  222 P 4 2 3 -1n     ',
     2 'P N -3 N    222-P 4a 2bc 3      ',
     3 'P M -3 N    223-P 4n 2 3        ',
     4 'P N -3 M:1  224 P 4n 2 3 -1n    ',
     4 'P N -3 M    224-P 4bc 2bc 3     ',
     5 'F M -3 M    225-F 4 2 3         ',
     6 'F M -3 C    226-F 4c 2 3        ',
     7 'F D -3 M:1  227 F 4d 2 3 -1d    ',
     7 'F D -3 M    227-F 4vw 2vw 3     ',
     8 'F D -3 C:1  228 F 4d 2 3 -1cd   ',
     8 'F D -3 C    228-F 4cvw 2vw 3    ',
     9 'I M -3 M    229-I 4 2 3         ',
     * 'I A -3 D    230-I 4bd 2c 3      '/
      DATA (NSLOC(I), I = 1, 59)/
     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,  0,  0, 47, 48, 49/
C * NON-Standard Orthorhomic Settings
      DATA (NONST(I), I = 1, 76)/
     1 'P 2 2 21 ', 'P 2 2 21 ', 'P 21 2 2 ', 'P 21 2 2 ',
     2 'P 2 21 2 ', 'P 2 21 2 ', 'P 21 21 2', 'P 21 21 2',
     3 'P 2 21 21', 'P 2 21 21', 'P 21 2 21', 'P 21 2 21',
     4 'C 2 2 21 ', 'C 2 2 21 ', 'A 21 2 2 ', 'A 21 2 2 ',
     5 'B 2 21 2 ', 'B 2 21 2 ', 'C 2 2 2  ', 'C 2 2 2  ',
     6 'A 2 2 2  ', 'A 2 2 2  ', 'B 2 2 2  ', 'B 2 2 2  ',
     7 'P M M 2  ', 'P M M 2  ', 'P 2 M M  ', 'P 2 M M  ',
     8 'P M 2 M  ', 'P M 2 M  ', 'P M C 21 ', 'P C M 21 ',
     9 'P 21 M A ', 'P 21 A M ', 'P B 21 M ', 'P M 21 B ',
     * 'P C C 2  ', 'P C C 2  ', 'P 2 A A  ', 'P 2 A A  ',
     1 'P B 2 B  ', 'P B 2 B  ', 'P M A 2  ', 'P B M 2  ',
     2 'P 2 M B  ', 'P 2 C M  ', 'P C 2 M  ', 'P M 2 A  ',
     3 'P C A 21 ', 'P B C 21 ', 'P 21 A B ', 'P 21 C A ',
     4 'P C 21 B ', 'P B 21 A ', 'P N C 2  ', 'P C N 2  ',
     5 'P 2 N A  ', 'P 2 A N  ', 'P B 2 N  ', 'P N 2 B  ',
     6 'P M N 21 ', 'P N M 21 ', 'P 21 M N ', 'P 21 N M ',
     7 'P N 21 M ', 'P M 21 N ', 'P B A 2  ', 'P B A 2  ',
     8 'P 2 C B  ', 'P 2 C B  ', 'P C 2 A  ', 'P C 2 A  ',
     9 'P N A 21 ', 'P B N 21 ', 'P 21 N B ', 'P 21 C N '/
      DATA (NONST(I), I = 77, 152)/
     1 'P C 21 N ', 'P N 21 A ', 'P N N 2  ', 'P N N 2  ',
     2 'P 2 N N  ', 'P 2 N N  ', 'P N 2 N  ', 'P N 2 N  ',
     3 'C M M 2  ', 'C M M 2  ', 'A 2 M M  ', 'A 2 M M  ',
     4 'B M 2 M  ', 'B M 2 M  ', 'C M C 21 ', 'C C M 21 ',
     5 'A 21 M A ', 'A 21 A M ', 'B B 21 M ', 'B M 21 B ',
     6 'C C C 2  ', 'C C C 2  ', 'A 2 A A  ', 'A 2 A A  ',
     7 'B B 2 B  ', 'B B 2 B  ', 'A M M 2  ', 'B M M 2  ',
     8 'B 2 M M  ', 'C 2 M M  ', 'C M 2 M  ', 'A M 2 M  ',
     9 'A B M 2  ', 'B M A 2  ', 'B 2 C M  ', 'C 2 M B  ',
     * 'C M 2 A  ', 'A C 2 M  ', 'A M A 2  ', 'B B M 2  ',
     1 'B 2 M B  ', 'C 2 C M  ', 'C C 2 M  ', 'A M 2 A  ',
     2 'A B A 2  ', 'B B A 2  ', 'B 2 C B  ', 'C 2 C B  ',
     3 'C C 2 A  ', 'A C 2 A  ', 'F M M 2  ', 'F M M 2  ',
     4 'F 2 M M  ', 'F 2 M M  ', '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  ', 'I M M 2  ', 'I M M 2  ',
     7 'I 2 M M  ', 'I 2 M M  ', 'I M 2 M  ', 'I M 2 M  ',
     8 'I B A 2  ', 'I B A 2  ', 'I 2 C B  ', 'I 2 C B  ',
     9 'I C 2 A  ', 'I C 2 A  ', 'I M A 2  ', 'I B M 2  '/
      DATA (NONST(I), I = 153, 228)/
     1 'I 2 M B  ', 'I 2 C M  ', 'I C 2 M  ', 'I M 2 A  ',
     2 'P C C M  ', 'P C C M  ', 'P M A A  ', 'P M A A  ',
     3 'P B M B  ', 'P B M B  ', 'P B A N  ', 'P B A N  ',
     4 'P N C B  ', 'P N C B  ', 'P C N A  ', 'P C N A  ',
     5 'P M M A  ', 'P M M B  ', 'P B M M  ', 'P C M M  ',
     6 'P M C M  ', 'P M A M  ', 'P N N A  ', 'P N N B  ',
     7 'P B N N  ', 'P C N N  ', 'P N C N  ', 'P N A N  ',
     8 'P M N A  ', 'P N M B  ', 'P B M N  ', 'P C N M  ',
     9 'P N C M  ', 'P M A N  ', 'P C C A  ', 'P C C B  ',
     * 'P B A A  ', 'P C A A  ', 'P B C B  ', 'P B A B  ',
     1 'P B A M  ', 'P B A M  ', 'P M C B  ', 'P M C B  ',
     2 'P C M A  ', 'P C M A  ', 'P C C N  ', 'P C C N  ',
     3 'P N A A  ', 'P N A A  ', 'P B N B  ', 'P B N B  ',
     4 'P B C M  ', 'P C A M  ', 'P M C A  ', 'P M A B  ',
     5 'P B M A  ', 'P C M B  ', 'P N N M  ', 'P N N M  ',
     6 'P M N N  ', 'P M N N  ', 'P N M N  ', 'P N M N  ',
     7 'P M M N  ', 'P M M N  ', 'P N M M  ', 'P N M M  ',
     8 'P M N M  ', 'P M N M  ', 'P B C N  ', 'P C A N  ',
     9 'P N C A  ', 'P N A B  ', 'P B N A  ', 'P C N B  '/
      DATA (NONST(I), I = 229, 294)/
     1 'P B C A  ', 'P C A B  ', 'P B C A  ', 'P C A B  ',
     2 'P B C A  ', 'P C A B  ', 'P N M A  ', 'P M N B  ',
     3 'P B N M  ', 'P C M N  ', 'P M C N  ', 'P N A M  ',
     4 'C M C M  ', 'C C M M  ', 'A M M A  ', 'A M A M  ',
     5 'B B M M  ', 'B M M B  ', 'C M C A  ', 'C C M B  ',
     6 'A B M A  ', 'A C A M  ', 'B B C M  ', 'B M A B  ',
     7 'C M M M  ', 'C M M M  ', 'A M M M  ', 'A M M M  ',
     8 'B M M M  ', 'B M M M  ', 'C C C M  ', 'C C C M  ',
     9 'A M A A  ', 'A M A A  ', 'B B M B  ', 'B B M B  ',
     * 'C M M A  ', 'C M M B  ', 'A B M M  ', 'A C M M  ',
     1 'B M C M  ', 'B M A M  ', 'C C C A  ', 'C C C B  ',
     2 'A B A A  ', 'A C A A  ', 'B B C B  ', 'B B A B  ',
     3 'I B A M  ', 'I B A M  ', 'I M C B  ', 'I M C B  ',
     4 'I C M A  ', 'I C M A  ', 'I B C A  ', 'I C A B  ',
     5 'I B C A  ', 'I C A B  ', 'I B C A  ', 'I C A B  ',
     6 'I M M A  ', 'I M M B  ', 'I B M M  ', 'I C M M  ',
     7 'I M C M  ', 'I M A M  '/
C * EQUIVALENT SPACE-GROUP NAME SUBSTITUTIONS
      DATA (TRLTA(I), TRLTB(I), I = 1, 38)/
     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  '/
      DATA (TRLTA(I), TRLTB(I), I = 39, 76)/
     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  '/
      DATA (TRLTA(I), TRLTB(I), I = 77, 112)/
     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    '/
      DATA (TRLTA(I), TRLTB(I), I = 113, 150)/
     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 'P21/M21/M2/N ', '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   '/
      DATA (TRLTA(I), TRLTB(I), I = 151, NTRL)/
     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   '/
C * Hall symbols for non-standard orthorhombic settings
      DATA (NHLA(I), NHLB(I), I = 1, 36)/
     1 'P2122  ', ' P 2a 2a       ', 'P2212  ', ' P 2 2b        ',
     2 'P22121 ', ' P 2bc 2       ', 'P21221 ', ' P 2ac 2ac     ',
     3 'A2122  ', ' A 2a 2a       ', 'B2212  ', ' B 2 2b        ',
     4 'A222   ', ' A 2 2         ', 'B222   ', ' B 2 2         ',
     5 'P2mm   ', ' P -2 2        ', 'Pm2m   ', ' P -2 -2       ',
     6 'Pcm21  ', ' P 2c -2c      ', 'P21ma  ', ' P -2a 2a      ',
     7 'P21am  ', ' P -2 2a       ', 'Pb21m  ', ' P -2 -2b      ',
     8 'Pm21b  ', ' P -2b -2      ', 'P2aa   ', ' P -2a 2       ',
     9 'Pb2b   ', ' P -2b -2b     ', 'Pbm2   ', ' P 2 -2b       ',
     * 'P2mb   ', ' P -2b 2       ', 'P2cm   ', ' P -2c 2       ',
     1 'Pc2m   ', ' P -2c -2c     ', 'Pm2a   ', ' P -2a -2a     ',
     2 'Pbc21  ', ' P 2c -2b      ', 'P21ab  ', ' P -2b 2a      ',
     3 'P21ca  ', ' P -2ac 2a     ', 'Pc21b  ', ' P -2bc -2c    ',
     4 'Pb21a  ', ' P -2a -2ab    ', 'Pcn2   ', ' P 2 -2ac      ',
     5 'P2na   ', ' P -2ac 2      ', 'P2an   ', ' P -2ab 2      ',
     6 'Pb2n   ', ' P -2ab -2ab   ', 'Pn2b   ', ' P -2bc -2bc   ',
     7 'Pnm21  ', ' P 2bc -2bc    ', 'P21mn  ', ' P -2ab 2ab    ',
     8 'P21nm  ', ' P -2 2ac      ', 'Pn21m  ', ' P -2 -2bc     '/
      DATA (NHLA(I), NHLB(I), I = 37, 72)/
     1 'Pm21n  ', ' P -2ab -2     ', 'P2cb   ', ' P -2bc 2      ',
     2 'Pc2a   ', ' P -2ac -2ac   ', 'Pbn21  ', ' P 2c -2ab     ',
     3 'P21nb  ', ' P -2bc 2a     ', 'P21cn  ', ' P -2n 2a      ',
     4 'Pc21n  ', ' P -2n -2ac    ', 'Pn21a  ', ' P -2ac -2n    ',
     5 'P2nn   ', ' P -2n 2       ', 'Pn2n   ', ' P -2n -2n     ',
     6 'A2mm   ', ' A -2 2        ', 'Bm2m   ', ' B -2 -2       ',
     7 'Ccm21  ', ' C 2c -2c      ', 'A21ma  ', ' A -2a 2a      ',
     8 'A21am  ', ' A -2 2a       ', 'Bb21m  ', ' B -2 -2b      ',
     9 'Bm21b  ', ' B -2b -2      ', 'A2aa   ', ' A -2a 2       ',
     * 'Bb2b   ', ' B -2b -2b     ', 'Bmm2   ', ' B 2 -2        ',
     1 'B2mm   ', ' B -2 2        ', 'C2mm   ', ' C -2 2        ',
     2 'Cm2m   ', ' C -2 -2       ', 'Am2m   ', ' A -2 -2       ',
     3 'Bma2   ', ' B 2 -2c       ', 'B2cm   ', ' B -2c 2       ',
     4 'C2mb   ', ' C -2b 2       ', 'Cm2a   ', ' C -2b -2b     ',
     5 'Ac2m   ', ' A -2c -2c     ', 'Bbm2   ', ' B 2 -2b       ',
     6 'B2mb   ', ' B -2b 2       ', 'C2cm   ', ' C -2c 2       ',
     7 'Cc2m   ', ' C -2c -2c     ', 'Am2a   ', ' A -2a -2a     ',
     8 'Bba2   ', ' B 2 -2bc      ', 'B2cb   ', ' B -2bc 2      '/
      DATA (NHLA(I), NHLB(I), I = 73, 106)/
     1 'C2cb   ', ' C -2bc 2      ', 'Cc2a   ', ' C -2bc -2bc   ',
     2 'Ac2a   ', ' A -2ac -2ac   ', 'F2mm   ', ' F -2 2        ',
     3 'Fm2m   ', ' F -2 -2       ', 'F2dd   ', ' F -2d 2       ',
     4 'Fd2d   ', ' F -2d -2d     ', 'I2mm   ', ' I -2 2        ',
     5 'Im2m   ', ' I -2 -2       ', 'I2cb   ', ' I -2a 2       ',
     6 'Ic2a   ', ' I -2b -2b     ', 'Ibm2   ', ' I 2 -2b       ',
     7 'I2mb   ', ' I -2b 2       ', 'I2cm   ', ' I -2c 2       ',
     8 'Ic2m   ', ' I -2c -2c     ', 'Im2a   ', ' I -2a -2a     ',
     9 'Pmaa   ', '-P 2a 2        ', 'Pbmb   ', '-P 2b 2b       ',
     * 'Pncb   ', '-P 2b 2bc      ', 'Pcna   ', '-P 2a 2c       ',
     2 'Pmmb   ', '-P 2b 2        ', 'Pbmm   ', '-P 2 2b        ',
     3 'Pcmm   ', '-P 2c 2c       ', 'Pmcm   ', '-P 2c 2        ',
     4 'Pmam   ', '-P 2 2a        ', 'Pnnb   ', '-P 2b 2n       ',
     5 'Pbnn   ', '-P 2n 2b       ', 'Pcnn   ', '-P 2ab 2c      ',
     6 'Pncn   ', '-P 2ab 2n      ', 'Pnan   ', '-P 2n 2bc      ',
     7 'Pnmb   ', '-P 2bc 2bc     ', 'Pbmn   ', '-P 2ab 2ab     ',
     8 'Pcnm   ', '-P 2 2ac       ', 'Pncm   ', '-P 2 2bc       '/
      DATA (NHLA(I), NHLB(I), I = 107, 140)/
     1 'Pman   ', '-P 2ab 2       ', 'Pccb   ', '-P 2b 2c       ',
     2 'Pbaa   ', '-P 2a 2b       ', 'Pcaa   ', '-P 2ac 2c      ',
     3 'Pbcb   ', '-P 2bc 2b      ', 'Pbab   ', '-P 2b 2ab      ',
     4 'Pmcb   ', '-P 2bc 2       ', 'Pcma   ', '-P 2ac 2ac     ',
     5 'Pnaa   ', '-P 2ac 2bc     ', 'Pbnb   ', '-P 2bc 2ab     ',
     6 'Pcam   ', '-P 2c 2ac      ', 'Pmca   ', '-P 2ac 2a      ',
     7 'Pmab   ', '-P 2b 2a       ', 'Pbma   ', '-P 2a 2ab      ',
     8 'Pcmb   ', '-P 2bc 2c      ', 'Pmnn   ', '-P 2n 2        ',
     9 'Pnmn   ', '-P 2n 2n       ', 'Pnmm   ', '-P 2c 2bc      ',
     1 'Pmnm   ', '-P 2c 2a       ', 'Pcan   ', '-P 2n 2c       ',
     2 'Pnca   ', '-P 2a 2n       ', 'Pnab   ', '-P 2bc 2n      ',
     3 'Pbna   ', '-P 2ac 2b      ', 'Pcnb   ', '-P 2b 2ac      ',
     4 'Pcab   ', '-P 2bc 2ac     ', 'Pmnb   ', '-P 2bc 2a      ',
     5 'Pbnm   ', '-P 2c 2ab      ', 'Pcmn   ', '-P 2n 2ac      ',
     6 'Pmcn   ', '-P 2n 2a       ', 'Pnam   ', '-P 2c 2n       ',
     7 'Ccmm   ', '-C 2c 2c       ', 'Amma   ', '-A 2a 2a       ',
     8 'Amam   ', '-A 2 2a        ', 'Bbmm   ', '-B 2 2b        '/
      DATA (NHLA(I), NHLB(I), I = 141, NNH)/
     1 'Bmmb   ', '-B 2b 2        ', 'Ccmb   ', '-C 2bc 2bc     ',
     2 'Abma   ', '-A 2ac 2ac     ', 'Acam   ', '-A 2 2ac       ',
     3 'Bbcm   ', '-B 2 2bc       ', 'Bmab   ', '-B 2bc 2       ',
     4 'Ammm   ', '-A 2 2         ', 'Bmmm   ', '-B 2 2         ',
     5 'Amaa   ', '-A 2a 2        ', 'Bbmb   ', '-B 2b 2b       ',
     6 'Cmmb   ', '-C 2b 2b       ', 'Abmm   ', '-A 2c 2c       ',
     7 'Acmm   ', '-A 2 2c        ', 'Bmcm   ', '-B 2 2c        ',
     8 'Bmam   ', '-B 2c 2        ', 'Cccb   ', '-C 2b 2c       ',
     9 'Abaa   ', '-A 2a 2c       ', 'Acaa   ', '-A 2ac 2c      ',
     * 'Bbcb   ', '-B 2bc 2b      ', 'Bbab   ', '-B 2b 2bc      ',
     1 'Imcb   ', '-I 2a 2        ', 'Icma   ', '-I 2b 2b       ',
     2 'Icab   ', '-I 2a 2b       ', 'Immb   ', '-I 2a 2a       ',
     3 'Ibmm   ', '-I 2c 2c       ', 'Icmm   ', '-I 2 2b        ',
     4 'Imcm   ', '-I 2 2a        ', 'Imam   ', '-I 2c 2        '/
      END
C * GENERAL ROUTINES (9-12-2004)
      SUBROUTINE GEN001 (MODE, Z, T, W)
      DIMENSION Z(3, 3), T(3, 3), V(3, 3), W(3, 3), ZTR(3, 3)
      CALL GEN005 (Z, ZTR)
      IF (MODE .EQ. 1) THEN
        CALL GEN004 (Z, T, V)
        CALL GEN004 (V, ZTR, W)
      ELSE
        CALL GEN004 (ZTR, T, V)
        CALL GEN004 (V, Z, W)
      ENDIF
      RETURN
      END
      SUBROUTINE GEN002 (MODE, A, B, C, XLNG)
      DIMENSION A(3, 3), B(3), C(3), V(3)
      XLNG = 0.0
      DO 30 I = 1, 3
        V(I) = 0.0
        IF (MODE .GT. 0) THEN
          DO 10 J = 1, 3
            V(I) = V(I) + A(I, J) * B(J)
   10     CONTINUE
        ELSE
          DO 20 J = 1, 3
            V(I) = V(I) + B(J) * A(J, I)
   20     CONTINUE
        ENDIF
   30 CONTINUE
      DO 40 I = 1, 3
        C(I) = V(I)
   40 CONTINUE
      IF (IABS(MODE) .EQ. 2) THEN
        XLNG = SQRT(GEN009 (C, C))
        IF (XLNG .GT. 1.E-5) THEN
          DO 50 I = 1, 3
            C(I) = C(I) / XLNG
   50     CONTINUE
        ELSE
          XLNG = 0.0
        ENDIF
      ENDIF
      RETURN
      END
      SUBROUTINE GEN003 (A, B, DET, MODE)
      DIMENSION A(3, 3), B(3, 3)
      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 .EQ. 0) THEN
        CALL GEN005 (B, B)
        DEEL = DET
      ELSE IF (MODE .EQ. 1) THEN
        DEEL = B(3, 3)
      ELSE
        DEEL = 0
      ENDIF
      IF (DEEL .NE. 0.0) THEN
        DO 20 I = 1, 3
          DO 10 J = 1, 3
            B(I, J) = B(I, J) / DEEL
   10     CONTINUE
   20   CONTINUE
      ENDIF
      RETURN
      END
      SUBROUTINE GEN004 (A, B, C)
      DIMENSION A(3, 3), B(3, 3), C(3, 3), V(3, 3)
      DO 30 I = 1, 3
        DO 20 J = 1, 3
          V(I, J) = 0.0
          DO 10 K = 1, 3
            V(I, J) = V(I, J) + A(I, K) * B(K, J)
   10     CONTINUE
   20   CONTINUE
   30 CONTINUE
      DO 50 I = 1, 3
        DO 40 J = 1, 3
          C(I, J) = V(I, J)
   40   CONTINUE
   50 CONTINUE
      RETURN
      END
      SUBROUTINE GEN005 (T, TR)
      DIMENSION T(3, 3), TR(3, 3), X(3, 3)
      DO 20 I = 1, 3
        DO 10 J = 1, 3
          X(J, I) = T(I, J)
   10   CONTINUE
   20 CONTINUE
      DO 40 I = 1, 3
        DO 30 J = 1, 3
          TR(I, J) = X(I, J)
   30   CONTINUE
   40 CONTINUE
      RETURN
      END
      FUNCTION GEN006 (X1, QM, X2)
      DIMENSION X1(3), QM(3, 3), X2(3)
      T1 = 0.0
      DO 10 J = 1, 3
        T1 = T1 + X1(J) * (X2(1) * QM(J, 1) + X2(2) * QM(J, 2)
     1     + X2(3) * QM(J, 3))
   10 CONTINUE
      GEN006 = T1
      RETURN
      END
      SUBROUTINE GEN007 (AA, X, Z, ITYPE)
      DIMENSION X(3), Z(3), AA(3,3)
      IF (ITYPE .GT. 0) THEN
        TN = SQRT(GEN009(X, X))
      ELSE
        TN = SQRT(GEN006(X, AA, X))
      ENDIF
      IF (TN .EQ. 0.0) TN = 1.0
      Z(1) = X(1) / TN
      Z(2) = X(2) / TN
      Z(3) = X(3) / TN
      RETURN
      END
      SUBROUTINE GEN008 (A, B, C, MODE)
      DIMENSION A(3), B(3), C(3)
      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 .NE. 0) THEN
        DSQ = C(1) * C(1) + C(2) * C(2) + C(3) * C(3)
        IF (MODE .GT. 0) THEN
          IF (DSQ .GT. 0.00001) THEN
            D = SQRT(DSQ)
            C(1) = C(1) / D
            C(2) = C(2) / D
            C(3) = C(3) / D
          ENDIF
        ELSE
          C(1) = DSQ
        ENDIF
      ENDIF
      RETURN
      END
      FUNCTION GEN009 (X, Y)
      DIMENSION X(3), Y(3)
      GEN009 = X(1) * Y(1) + X(2) * Y(2) + X(3) * Y(3)
      RETURN
      END
      SUBROUTINE GEN010 (R, IDET, MODE)
      DIMENSION R(3, 3), V(3)
      IF (MODE .GE. 0) THEN
        CALL GEN008 (R(1, 1), R(1, 2), V, 0)
        DET = GEN009 (R(1, 3), V)
        IF (DET .GT. 0.999) THEN
          IDET = 1
        ELSE IF (DET .LT. -0.999) THEN
          IDET = -1
        ELSE
          IDET = 0
        ENDIF
      ENDIF
      IF (MODE .NE. 0) THEN
        DO 20 I = 1, 3
          DO 10 J = 1, 3
            R(I, J) = IDET * R(I, J)
   10     CONTINUE
   20   CONTINUE
      ENDIF
      RETURN
      END
      SUBROUTINE GEN011 (BB, X, Y, Z, ITYPE)
      DIMENSION X(3), Y(3), Z(3), Z1(3), BB(3,3)
      DO 10 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) .LT. 1.E-5) T1 = 0.0
        IF (ITYPE .GT. 0) THEN
          Z(I) = T1
        ELSE
          Z1(I) = T1
        ENDIF
   10 CONTINUE
      IF (ITYPE .LE. 0) CALL GEN002 (1, BB, Z1, Z, XLNG)
      RETURN
      END
      SUBROUTINE GEN012 (B, A, NN, DAMP, DA, R)
      DIMENSION B(*), A(*)
      K = 0
      L = 0
      J = NN + 1
      DO 40 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 .LT. NN) THEN
   10     B(K) = - B(J) * B(M)
          M = M + 1
          K = K + 1
          IF (K .LT. J) GOTO 10
          GOTO 30
   20     B(M) = B(J) * B(L) + B(M)
          M = M + 1
          L = L + 1
          IF (I .GE. L) GOTO 20
   30     L = J + NI - NN
          J = J + 1
          IF (I .GE. L) GOTO 20
        ENDIF
   40 CONTINUE
      NI   = NN - 1
   50 NI   = NI - 1
      J    = K
      M    = K + NI - NN
      L    = M - 1
      I    = M + 1
      K    = I + NI - NN
   60 B(I) = 0
      I    = I + 1
      IF (I .LT. J) GOTO 60
   70 M    = M + 1
      B(M) = B(K) * B(J) + B(M)
      I    = M
      NK   = K + 1
   80 IF (L .GE. 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
        GOTO 80
      ENDIF
      B(NK) = B(K) * B(M) + B(NK)
      J     = J + 1
      K     = K + 1
      IF (L  .GE. K) GOTO 70
      IF (NI .GT. 0) GOTO 50
      DO 120 I = 1, NN
        B(I) = 0.0
  120 CONTINUE
      L = NN + 1
      DO 140 I = 1, NN
        B(I) = B(I) - B(L) * A(I)
        T = B(L) * R
        DO 130 K = I, NN
          B(I) = B(L) * A(K) + B(I)
          B(K) = B(L) * A(I) + B(K)
          L    = L + 1
  130   CONTINUE
        A(I) = SQRT(ABS(T))
  140 CONTINUE
      RETURN
      END
      SUBROUTINE GEN013 (DATC, IATC, N1, N)
      DIMENSION IATC(*), DATC(*)
      NEL = N - N1 + 1
      IF (NEL .GT. 1) THEN
        ND = 2**(INT((ALOG(FLOAT(NEL)) / ALOG(2.0)) + 1.0e-5)) - 1
   10   IF (ND .LE. 0) GOTO 50
        I            = N1
   20   J            = I
        Y            = DATC(I + ND)
        NZ           = IATC(I + ND)
   30   IF (Y .GE. DATC(J)) GOTO 40
        DATC(J + ND) = DATC(J)
        IATC(J + ND) = IATC(J)
        J            = J - ND
        IF (J .GE. N1) GOTO 30
   40   DATC(J + ND) = Y
        IATC(J + ND) = NZ
        I            = I + 1
        IF (I + ND .LE. N) GOTO 20
        ND           = (ND - 1) / 2
        GOTO 10
      ENDIF
   50 RETURN
      END
      SUBROUTINE GEN014 (I, J)
      K = I
      I = J
      J = K
      RETURN
      END
      SUBROUTINE GEN015 (A, B, C)
      DIMENSION A(3), B(3), C(3)
      DO 10 I = 1, 3
        C(I) = A(I) + B(I)
   10 CONTINUE
      RETURN
      END
      SUBROUTINE GEN016 (A, B, C)
      DIMENSION A(3), B(3), C(3)
      DO 10 I = 1, 3
        C(I) = A(I) - B(I)
   10 CONTINUE
      RETURN
      END
      FUNCTION GEN017 (V)
      DIMENSION V(3)
      D = SQRT (V(1) ** 2 + V(2) ** 2 + V(3) ** 2)
      IF (D .LT. 0.00001) THEN
        GEN017 = 0.0
      ELSE
        GEN017 = D
        DO 10 I = 1, 3
          V(I) = V(I) / D
   10   CONTINUE
      ENDIF
      RETURN
      END
      SUBROUTINE GEN018 (A, B)
      C = A
      A = B
      B = C
      RETURN
      END
      SUBROUTINE GEN019 (AA, BB, U, V, X, ITYPE)
      DIMENSION U(3), V(3), W(3,3), X(3,3), AA(3,3), BB(3,3)
      IT = ITYPE
      DO 30 J = 1, 3
         W(J, 1) = U(J)
   30 CONTINUE
      CALL GEN011 (BB, U, V, W(1, 2), IT)
      CALL GEN011 (BB, U, W(1, 2), W(1, 3), IT)
      DO 100 I = 1, 3
        CALL GEN007 (AA, W(1, I), X(1, I), IT)
  100 CONTINUE
      RETURN
      END
      SUBROUTINE GEN020 (MODE, ICL, IMIN, IMAX)
      CHARACTER ICL*(*)
      IF (IMAX .GE. IMIN) THEN
        IF (MODE .GT. 0) THEN
          DO 20 I = IMIN, IMAX
            IF (ICL(I:I) .EQ. CHAR(9)) ICL(I:I) = ' '
            CALL GEN105 (2, ICL(I:I), N)
            IF (N .GT. 0) ICL(I:I) = CHAR(N + ICHAR('A') - ICHAR('a'))
   20     CONTINUE
        ELSE
          DO 40 I = IMIN, IMAX
            CALL GEN105 (1, ICL(I:I), N)
            IF (N .GT. 0) ICL(I:I) = CHAR(N - ICHAR('A') + ICHAR('a'))
   40     CONTINUE
        ENDIF
      ENDIF
      RETURN
      END
      SUBROUTINE GEN021 (X, MODE)
      DIMENSION X(3, 3)
      DO 20 I = 1, 3
        DO 10 J = 1, 3
          IF (I .EQ. J) THEN
            X(I, I) = MODE
          ELSE
            X(I, J) = 0.0
          ENDIF
   10   CONTINUE
   20 CONTINUE
      RETURN
      END
      SUBROUTINE GEN022 (NA, N0, N)
      DIMENSION NA(*)
      NEL = N - N0 + 1
      IF (NEL .LE. 1) GOTO 50
      ND = 2**(INT((ALOG(FLOAT(NEL)) / ALOG(2.0)) + 1.0E-5)) - 1
   10 IF (ND .LE. 0) GOTO 50
      I = N0
   20 J = I
      NY = NA(I + ND)
   30 IF (NY .GE. NA(J)) GOTO 40
      NA(J + ND) = NA(J)
      J = J - ND
      IF (J .GE. N0) GOTO 30
   40 NA(J + ND) = NY
      I = I + 1
      IF (I + ND .LE. N) GOTO 20
      ND = (ND - 1) / 2
      GOTO 10
   50 RETURN
      END
      SUBROUTINE GEN023 (A, R, N)
      DIMENSION A(*), R(*)
      RANGE = 1.0E-6
      IQ = - N
      DO 30 J = 1, N
        IQ = IQ + N
        DO 20 I = 1, N
          IJ = IQ + I
          IF (I .EQ. J) THEN
            R(IJ) = 1.0
          ELSE
            R(IJ) = 0.0
          ENDIF
   20   CONTINUE
   30 CONTINUE
      ANORM = 0.0
      DO 60 I = 1, N
        DO 50 J = I, N
          IF (I .NE. J) THEN
            IA    = I + (J * J - J) / 2
            ANORM = ANORM + A(IA)**2
          ENDIF
   50   CONTINUE
   60 CONTINUE
      IF (ANORM .LE. 0.0) GOTO 310
      ANORM = 1.414 * SQRT(ANORM)
      ANRMX = ANORM * RANGE / FLOAT(N)
      IND = 0
      THR = ANORM
   80 THR = THR / FLOAT(N)
   90 L   = 1
  100 M   = L + 1
  110 MQ = (M * M - M) / 2
      LQ = (L * L - L) / 2
      LM = L + MQ
      IF (ABS(A(LM)) .GE. 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 .LT. 0.0) Y  = - Y
        Y2 = Y**2
        IF (Y2 .LT. 1.0) THEN
          SINX = Y / SQRT(2.0 * (1.0 + (SQRT(1.0 - Y2))))
        ELSE
          SINX = Y / SQRT(2.0)
        ENDIF
        SINX2 = SINX * SINX
        COSX  = SQRT(1.0 - SINX2)
        COSX2 = COSX**2
        SINCS = SINX * COSX
        ILQ = N * (L - 1)
        IMQ = N * (M - 1)
        DO 230 I = 1, N
          IQ = (I * I - I) / 2
          IF (I .NE. L) THEN
            IF (I .GT. M) THEN
              IM = M + IQ
              GOTO 180
            ELSE IF (I .EQ. M) THEN
              GOTO 220
            ENDIF
            IM = I + MQ
  180       IF (I .LT. L) THEN
              IL = I + LQ
              GOTO 210
            ENDIF
            IL = L + IQ
  210       X     = A(IL) * COSX - A(IM) * SINX
            A(IM) = A(IL) * SINX + A(IM) * COSX
            A(IL) = X
          ENDIF
  220     ILR = ILQ + I
          IMR = IMQ + I
          X      = R(ILR) * COSX - R(IMR) * SINX
          R(IMR) = R(ILR) * SINX + R(IMR) * COSX
          R(ILR) = X
  230   CONTINUE
        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
      ENDIF
      IF (M .NE. N) THEN
        M = M + 1
        GOTO 110
      ENDIF
      IF (L .NE. (N - 1)) THEN
        L = L + 1
        GOTO 100
      ENDIF
      IF (IND .NE. 1) GOTO 300
      IND = 0
      GOTO 90
  300 IF (THR .GT. ANRMX) GOTO 80
  310 IQ = - N
      DO 350 I = 1, N
        IQ = IQ + N
        LL = I + (I * I - I) / 2
        JQ = N * (I - 2)
        DO 340 J = I, N
          JQ = JQ + N
          MM = J + (J * J - J) / 2
          IF (A(LL) .GE. A(MM)) GOTO 340
          X     = A(LL)
          A(LL) = A(MM)
          A(MM) = X
          DO 330 K = 1, N
            ILR    = IQ + K
            IMR    = JQ + K
            X      = R(ILR)
            R(ILR) = R(IMR)
            R(IMR) = X
  330     CONTINUE
  340   CONTINUE
  350 CONTINUE
      RETURN
      END
      SUBROUTINE GEN024 (W, EV, EW, DUMV)
      DIMENSION W(3, 3), EV(3, 3), EW(3), DUMA(6), DUMV(3, 3)
      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)
      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 GEN025 (A, V, MODE)
      DIMENSION A(3, 3), V(6)
      IF (MODE .GT. 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)
      ENDIF
      RETURN
      END
      SUBROUTINE GEN026 (MODE, A, V, PAR5)
      DIMENSION A(3, 3), V(6)
      IF (MODE .EQ. 1) THEN
        A(1, 1) = V(1) * V(1)
        A(2, 2) = V(2) * V(2)
        A(3, 3) = V(3) * V(3)
        A(1, 2) = V(1) * V(2) * COS(V(6) / PAR5)
        A(2, 1) = A(1, 2)
        A(1, 3) = V(1) * V(3) * COS(V(5) / PAR5)
        A(3, 1) = A(1, 3)
        A(2, 3) = V(2) * V(3) * COS(V(4) / PAR5)
        A(3, 2) = A(2, 3)
      ELSE IF (MODE .EQ. -1) THEN
        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))) * PAR5
        V(5)   = ACOS(A(1, 3) / (V(1) * V(3))) * PAR5
        V(6)   = ACOS(A(1, 2) / (V(1) * V(2))) * PAR5
      ENDIF
      RETURN
      END
      FUNCTION GEN027 (V1, V2, P5)
      DIMENSION V1(*), V2(*)
      ANG = GEN009 (V1, V2)
      IF (ANG .GT.  1.0) ANG =  1.0
      IF (ANG .LT. -1.0) ANG = -1.0
      GEN027 = ACOS(ANG) * P5
      RETURN
      END
      SUBROUTINE GEN028 (XAR, NN, NDM, ISIGN)
      DOUBLE PRECISION WR, WI, WPR, WPI, WYK, TH
      DIMENSION NN(NDM), XAR(*)
      NPRV = 1
      NTOT = 1
      DO 10 IDM = 1, NDM
        NTOT = NTOT * NN(IDM)
   10 CONTINUE
      DO 100 IDM = 1, NDM
        N    = NN(IDM)
        NREM = NTOT / (N * NPRV)
        IPA  = 2 * NPRV
        IPB  = IPA * N
        IPC  = IPB * NREM
        IBRV = 1
        DO 50 IB = 1, IPB, IPA
          IF (IB .LT. IBRV) THEN
            DO 30 IA = IB, IB + IPA - 2, 2
              DO 20 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
   20         CONTINUE
   30       CONTINUE
          ENDIF
          IBIT = IPB / 2
   40     IF ((IBIT .GE. IPA) .AND. (IBRV .GT. IBIT)) THEN
            IBRV = IBRV - IBIT
            IBIT = IBIT / 2
            GOTO 40
          ENDIF
          IBRV = IBRV + IBIT
   50   CONTINUE
        IFPA = IPA
   60   IF (IFPA .LT. IPB) THEN
          IFPB = 2 * IFPA
          TH   = ISIGN * 6.28318530717959D0 / (IFPB / IPA)
          WPR  = -2.D0 * DSIN(0.5D0 * TH)**2
          WPI  = DSIN(TH)
          WR   = 1.D0
          WI   = 0.D0
          DO 90 IC = 1, IFPA, IPA
            DO 80 IA = IC, IC + IPA - 2, 2
              DO 70 IB = IA, IPC, IFPB
                KA  = IB
                KB  = KA + IFPA
                YKR = SNGL(WR) * XAR(KB) - SNGL(WI) * XAR(KB + 1)
                YKI = SNGL(WR) * XAR(KB + 1) + SNGL(WI) * XAR(KB)
                XAR(KB)     = XAR(KA)     - YKR
                XAR(KB + 1) = XAR(KA + 1) - YKI
                XAR(KA)     = XAR(KA)     + YKR
                XAR(KA + 1) = XAR(KA + 1) + YKI
   70         CONTINUE
   80       CONTINUE
            WYK = WR
            WR  = WR * WPR - WI  * WPI + WR
            WI  = WI * WPR + WYK * WPI + WI
   90     CONTINUE
          IFPA = IFPB
          GOTO 60
        ENDIF
        NPRV = N * NPRV
  100 CONTINUE
      RETURN
      END
      SUBROUTINE GEN029 (A, VALUE, VECTOR, M, IA, IV, W)
      DIMENSION A(IA, M), VALUE(M), VECTOR(IV, M), W(*)
      M1 = M + 1
      W(1) = A(1, 1)
      IF (M .LT. 2) THEN
        GOTO 30
      ELSE IF (M .GT. 2) THEN
        GOTO 20
      ENDIF
      W(2) = A(2, 2)
      W(4) = A(2, 1)
      GOTO 30
   20 CALL GEN030 (A, W, W(M1), M, IA, W(M + M1))
   30 CALL GEN031 (W, W(M1), VALUE, VECTOR, M, IV, W(M + M1))
      IF (M .GT. 2) THEN
        DO 80 L = 1, M
          DO 70 II = 3, M
            I = M - II + 1
            IF (W(M1 + I) .NE. 0.0) THEN
              PP = 0.0
              I1 = I + 1
              DO 50 K = I1, M
                PP = PP + A(I, K) * VECTOR(K, L)
   50         CONTINUE
              PP = PP / (A(I, I + 1) * W(M1 + I))
              DO 60 K = I1, M
                VECTOR(K, L) = VECTOR(K, L) + PP * A(I, K)
   60         CONTINUE
            ENDIF
   70     CONTINUE
   80   CONTINUE
      ENDIF
      RETURN
      END
      SUBROUTINE GEN030 (A, ALPHA, BETA, M, IA, Q)
      DIMENSION A(IA, *), ALPHA(*), BETA(*), Q(*)
      ALPHA(1) = A(1, 1)
      DO 20 J = 2, M
        J1 = J - 1
        DO 10 I = 1, J1
          A(I, J) = A(J, I)
   10   CONTINUE
        ALPHA(J) = A(J, J)
   20 CONTINUE
      M2 = M - 2
      DO 170 I = 1, M2
        PP = 0.0
        I1 = I + 1
        DO 30 J = I1, M
          PP = PP + A(I, J)**2
   30   CONTINUE
        PP1 = SQRT(PP)
        IF (A(I, I + 1) .GE. 0.0) THEN
          BETA(I + 1) = -PP1
        ELSE
          BETA(I + 1) = PP1
        ENDIF
        IF (PP .GT. 0.0) THEN
          H = PP - BETA(I + 1) * A(I, I + 1)
          A(I, I + 1) = A(I, I + 1) - BETA(I + 1)
          DO 120 KI = I1, M
            QJ = 0.0
            DO 80 KJ = I1, KI
              QJ = QJ + A(KJ, KI) * A(I, KJ)
   80       CONTINUE
            IF(KI .LT. M) THEN
              I2 = KI + 1
              DO 100 KJ = I2, M
                QJ = QJ + A(KI, KJ) * A(I, KJ)
  100         CONTINUE
            ENDIF
            Q(KI) = QJ / H
  120     CONTINUE
          BIGK = 0.0
          DO 130 KJ = I1, M
            BIGK = BIGK + A(I, KJ) * Q(KJ)
  130     CONTINUE
          BIGK = BIGK / (2.0 * H)
          DO 140 KJ = I1, M
            Q(KJ) = Q(KJ) - BIGK * A(I, KJ)
  140     CONTINUE
          DO 160 KI = I1, M
            DO 150 KJ = KI, M
              A(KI, KJ) = A(KI, KJ) - Q(KI) * A(I, KJ)
     1                  - Q(KJ) * A(I, KI)
  150       CONTINUE
  160     CONTINUE
        ENDIF
  170 CONTINUE
      DO 180 I = 2, M
        H = ALPHA(I)
        ALPHA(I) = A(I, I)
        A(I, I) = H
  180 CONTINUE
      BETA(M) = A(M - 1, M)
      RETURN
      END
      SUBROUTINE GEN031 (A, B, VALUE, VEC, M, IV, W)
      REAL A(M), B(M), VALUE(M), VEC(1), W(1)
      DATA EPS/1E-5/, A34/0.0/
      CALL GEN032 (A, B, W(M + 1), M, W)
      DO 20 I = 1, M
        VALUE(I) = A(I)
        W(I) = B(I)
        K = (I - 1) * IV + 1
        L = K + M - 1
        DO 10 J = K, L
          VEC(J) = 0.0
   10   CONTINUE
        VEC(K + I - 1) = 1.0
   20 CONTINUE
      ITER = 0
      IF (M .NE. 1) THEN
        N2 = M
   30   DO 40 II = 2, N2
          N1 = 2 + N2 - II
          IF (ABS(W(N1)) .LE. (ABS(VALUE(N1 - 1))
     1              + ABS(VALUE(N1))) * EPS) GOTO 50
   40   CONTINUE
        N1 = 1
   50   IF (N2 .EQ. N1) THEN
          N2 = N2 - 1
          IF (N2 .LE. 1) THEN
            GOTO 90
          ELSE
            GOTO 30
          ENDIF
        ENDIF
        ROOT = W(M + N2)
        ITER = ITER + 1
        N2M1 = N2 - 1
        A22 = VALUE(N1)
        A12 = A22 - ROOT
        A23 = W(N1 + 1)
        A13 = A23
        DO 80 I = N1, N2M1
          A33 = VALUE(I + 1)
          IF (I .NE. 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 70 JI = J1, J2
            V1 = VEC(JI)
            V2 = VEC(JK)
            VEC(JI) = V1 * CO + V2 * SI
            VEC(JK) = V2 * CO - V1 * SI
            JK = JK + 1
   70     CONTINUE
          IF (I .NE. 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
          VALUE(I) = A11 * CO + A12 * SI
          A12 = - A11 * SI + A12 * CO
          W(I + 1) = A12
          A22 = A22 * CO - A21 * SI
   80   CONTINUE
        VALUE(N2) = A22
        GOTO 30
   90   DO 110 J = 1, M
          K = (J - 1) * IV
          XX = VEC(K + 1)**2
          XAX = XX * A(1)
          DO 100 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))
  100     CONTINUE
          VALUE(J) = XAX / XX
  110   CONTINUE
      ENDIF
      RETURN
      END
      SUBROUTINE GEN032 (A, B, VALUE, M, OFF)
      REAL A(M), B(M), VALUE(M), OFF(M)
      DATA A34 /0.0/, EPS /0.6E-7/
      VALUE(1) = A(1)
      IF (M .EQ. 1) RETURN
      DO 10 I = 2, M
        VALUE(I) = A(I)
        OFF(I)   = B(I)
   10 CONTINUE
      N2 = M
   20 IF (N2 .LE. 1) RETURN
      DO 30 II = 2, N2
        N1 = 2 + N2 - II
        IF (ABS(OFF(N1)) .LE. (ABS(VALUE(N1 - 1))
     1     + ABS(VALUE(N1))) * EPS) GOTO 40
   30 CONTINUE
      N1 = 1
   40 IF (N2 .NE. N1) GOTO 50
      N2 = N2 - 1
      GOTO 20
   50 BB = (VALUE(N2) - VALUE(N2 - 1)) * 0.5
      CC = OFF(N2) * OFF(N2)
      SBB = 1.0
      IF (BB .LT. 0.0) SBB = -1.0
      ROOT = VALUE(N2) + CC / (BB + SBB * SQRT(BB * BB + CC))
      N2M1 = N2 - 1
      A22 = VALUE(N1)
      A12 = A22 - ROOT
      A23 = OFF(N1 + 1)
      A13 = A23
      DO 60 I = N1, N2M1
        A33 = VALUE(I + 1)
        IF (I .NE. N2M1) A34 = OFF(I + 2)
        S = SQRT(A12 * A12 + A13 * A13)
        SI = A13 / S
        CO = A12 / S
        IF (I .NE. 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
        VALUE(I) = A11 * CO + A12 * SI
        A12 = - A11 * SI + A12 * CO
        OFF(I + 1) = A12
        A22 = A22 * CO - A21 * SI
   60 CONTINUE
      VALUE(N2) = A22
      GOTO 20
      END
      SUBROUTINE GEN033 (P, Y, MP0, NP, NDIM, FTOL, FUNK, ITER)
      PARAMETER (NMAX = 20, ALPHA = 1.0, BETA = 0.5, GAMMA = 2.0,
     1           ITMAX = 500)
      DIMENSION P(MP0, NP), Y(MP0), PR(NMAX), PRR(NMAX), PBAR(NMAX)
      EXTERNAL FUNK
      MPTS = NDIM + 1
      ITER = 0
   10 ILO = 1
      IF (Y(1) .GT. Y(2)) THEN
        IHI  = 1
        INHI = 2
      ELSE
        IHI  = 2
        INHI = 1
      ENDIF
      DO 20 I = 1, MPTS
        IF (Y(I) .LT. Y(ILO)) ILO = I
        IF (Y(I) .GT. Y(IHI)) THEN
          INHI = IHI
          IHI  = I
        ELSE IF (Y(I) .GT. Y(INHI)) THEN
          IF (I .NE. IHI) INHI = I
        ENDIF
   20 CONTINUE
      RTOL = 2.0 * ABS(Y(IHI) - Y(ILO)) / (ABS(Y(IHI)) + ABS(Y(ILO)))
      IF (RTOL .LT. FTOL) RETURN
      IF (ITER .EQ. ITMAX)
     1  WRITE(6, *) 'GEN033 exceeding maximum iterations.'
      ITER = ITER + 1
      DO 30 J = 1, NDIM
        PBAR(J) = 0.0
   30 CONTINUE
      DO 50 I = 1, MPTS
        IF (I .NE. IHI) THEN
          DO 40 J = 1, NDIM
            PBAR(J) = PBAR(J) + P(I, J)
   40     CONTINUE
        ENDIF
   50 CONTINUE
      DO 60 J = 1, NDIM
        PBAR(J) = PBAR(J) / NDIM
        PR(J)   = (1.0 + ALPHA) * PBAR(J) - ALPHA * P(IHI, J)
   60 CONTINUE
      YPR = FUNK(PR)
      IF (YPR .LE. Y(ILO)) THEN
        DO 70 J = 1, NDIM
          PRR(J) = GAMMA * PR(J) + (1.0 - GAMMA) * PBAR(J)
   70   CONTINUE
        YPRR = FUNK(PRR)
        IF (YPRR .LT. Y(ILO)) THEN
          DO 80 J = 1, NDIM
            P(IHI, J) = PRR(J)
   80     CONTINUE
          Y(IHI) = YPRR
        ELSE
          DO 90 J = 1, NDIM
            P(IHI, J) = PR(J)
   90     CONTINUE
          Y(IHI) = YPR
        ENDIF
      ELSE IF (YPR .GE. Y(INHI)) THEN
        IF (YPR .LT. Y(IHI)) THEN
          DO 100 J = 1, NDIM
            P(IHI, J) = PR(J)
  100     CONTINUE
          Y(IHI) = YPR
        ENDIF
        DO 110 J = 1, NDIM
          PRR(J) = BETA * P(IHI, J) + (1.0 - BETA) * PBAR(J)
  110   CONTINUE
        YPRR = FUNK(PRR)
        IF (YPRR .LT. Y(IHI)) THEN
          DO 120 J = 1, NDIM
            P(IHI, J) = PRR(J)
  120     CONTINUE
          Y(IHI) = YPRR
        ELSE
          DO 140 I = 1, MPTS
            IF(I .NE. ILO) THEN
              DO 130 J = 1, NDIM
                PR(J) = 0.5 * (P(I, J) + P(ILO, J))
                P(I, J) = PR(J)
  130         CONTINUE
              Y(I) = FUNK(PR)
            ENDIF
  140     CONTINUE
        ENDIF
      ELSE
        DO 150 J = 1, NDIM
          P(IHI, J) = PR(J)
  150   CONTINUE
        Y(IHI) = YPR
      ENDIF
      GOTO 10
      END
      SUBROUTINE GEN034 (RA, N0, N)
      DIMENSION RA(*)
      NEL = N - N0 + 1
      IF (NEL .GT. 1) THEN
        NN = INT((ALOG(FLOAT(NEL)) / ALOG(2.0)) + 1.0E-5)
        ND = 2**NN - 1
   10   IF (ND .GT. 0) THEN
          I = N0
   20     J = I
          Y = RA(I + ND)
   30     IF (Y .GT. RA(J)) THEN
            RA(J + ND) = RA(J)
            J = J - ND
            IF (J .GE. N0) GOTO 30
          ENDIF
          RA(J + ND) = Y
          I = I + 1
          IF (I + ND .LE. N) GOTO 20
          ND = (ND - 1) / 2
          GOTO 10
        ENDIF
      ENDIF
      CONTINUE
      RETURN
      END
      SUBROUTINE GEN035 (RA, N0, N)
      DIMENSION RA(*)
      NEL = N - N0 + 1
      IF (NEL .GT. 1) THEN
        NN = INT((ALOG(FLOAT(NEL)) / ALOG(2.0)) + 1.0E-5)
        ND = 2**NN - 1
   10   IF (ND .GT. 0) THEN
          I = N0
   20     J = I
          Y = RA(I + ND)
   30     IF (Y .LT. RA(J)) THEN
            RA(J + ND) = RA(J)
            J = J - ND
            IF (J .GE. N0) GOTO 30
          ENDIF
          RA(J + ND) = Y
          I = I + 1
          IF (I + ND .LE. N) GOTO 20
          ND = (ND - 1) / 2
          GOTO 10
        ENDIF
      ENDIF
      CONTINUE
      RETURN
      END
      FUNCTION GEN036 (IDUM)
      PARAMETER (M = 714025, IA = 1366, IC = 150889)
      COMMON /DGEN36/ IR(97), RM, IY
      IF (IDUM .LT. 0) THEN
        RM = 1.0 / M
        IDUM = MOD(IC - IDUM, M)
        DO 10 J = 1, 97
          IDUM  = MOD(IA * IDUM + IC, M)
          IR(J) = IDUM
   10   CONTINUE
        IDUM = MOD(IA * IDUM + IC, M)
        IY   = IDUM
      ENDIF
      J = 1 + (97 * IY) / M
      IF (J .GT. 97 .OR. J .LT. 1) STOP 'IN RANDOM'
      IY       = IR(J)
      GEN036   = IY * RM
      IDUM     = MOD(IA * IDUM + IC, M)
      IR(J)    = IDUM
      RETURN
      END
      SUBROUTINE GEN037 (IA, JL, JU)
      DIMENSION IA(2, *)
      JV = JU - JL + 1
      IF (JV .GT. 1) THEN
        ND = 2**(INT((ALOG(FLOAT(JV)) / ALOG(2.0)) + 1.0E-5)) - 1
   10   IF (ND .LE. 0) GOTO 50
        I  = JL
   20   J  = I
        NY = IA(1, I + ND)
        NZ = IA(2, I + ND)
   30   IF (NY .GE. IA(1, J)) GOTO 40
        IA(1, J + ND) = IA(1, J)
        IA(2, J + ND) = IA(2, J)
        J  = J - ND
        IF (J .GE. JL) GOTO 30
   40   IA(1, J + ND) = NY
        IA(2, J + ND) = NZ
        I  = I + 1
        IF (I + ND .LE. JU) GOTO 20
        ND = (ND - 1) / 2
        GOTO 10
      ENDIF
   50 RETURN
      END
      SUBROUTINE GEN038 (LINE, LO, LU)
      CHARACTER LINE*(*)
      IF (LO .GT. 0 .AND. LU .GE. LO) THEN
        DO 10 I = LO, LU
          LINE(I:I) = ' '
   10   CONTINUE
      ENDIF
      RETURN
      END
      SUBROUTINE GEN039 (MODE, LINE, LB, LE, NB, NE)
      CHARACTER LINE*(*)
      NB = LB
      NE = LE
      IF (MODE .GE. 0) THEN
        N = LE - LB + 1
        K = LE + 1
        DO 10 I = 1, N
          K = K - 1
          IF (LINE(K:K) .NE. ' ') GOTO 20
   10   CONTINUE
   20   NE = K
      ENDIF
      IF (MODE .LE. 0) THEN
        N = NE - LB + 1
        K = LB - 1
        DO 30 I = 1, N
          K = K + 1
          IF (LINE(K:K) .NE. ' ') GOTO 40
   30   CONTINUE
        K  = K + 1
   40   NB = K
      ENDIF
      RETURN
      END
      SUBROUTINE GEN040 (NR, NQ, IP)
      CHARACTER NQ*(*)
      NQ  = '-       '
      NR1 = IABS(NR)
      ISN = 6
      IF (NR .LT. 0) ISN = 5
      N = 1
      DO 10 I = 1, ISN
        N = N * 10
        IF (N .GT. NR1) GOTO 20
   10 CONTINUE
      I = ISN
   20 IP = I - ISN + 6
      DO 30 J = 1, I
        ISCR = MOD(NR1, 10)
        NQ(IP + 1 - J:IP + 1 - J) = CHAR(ICHAR('0') + ISCR)
        NR1 = NR1 / 10
   30 CONTINUE
      RETURN
      END
      SUBROUTINE GEN041 (X, SX, ISX, NDCD, NDEC, IRND)
      NDEC = IABS(NDCD)
      N    = 0
      IF (SX .GT. 0.0) THEN
        IF (IRND .NE. 0) THEN
          SXX = SX
          XM  = 1.0
   10     IF (N .GE. IABS(NDCD)) GOTO 20
          ISX = INT(SXX * XM + 0.051)
          IF (ISX .GE. IRND) GOTO 20
          XM = XM * 10
          N  = N + 1
          GOTO 10
   20     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)
        ENDIF
      ELSE
        ISX = 0
        IF (NDCD .LT. 0) THEN
   30     IF (ABS(FLOAT(INT(X * 10**N + 0.01)) - X * 10**N)
     1        .GT. 0.0000001 .AND. N .LT. IABS(NDCD)) THEN
            N = N + 1
            GOTO 30
          ENDIF
          NDEC = N
        ENDIF
      ENDIF
      RETURN
      END
      SUBROUTINE GEN042 (NWRD, A, NUM)
      DIMENSION A(2)
      CHARACTER NWRD*80, ICH*1
      A(1) = 0.0
      A(2) = 0.0
      S    = 1.0
      IP   = 0
      NP   = 0
      NUM  = 0
      K    = 1
      FIN  = 0
      IFRC = 0
      DO 20 I = 2, 80
        ICH = NWRD(I:I)
        CALL GEN105 (1, ICH, L)
        IF (L .LT. 0) CALL GEN105 (2, ICH, L)
        IF (L .GT. 0) THEN
          NUM = 0
          GOTO 30
        ENDIF
        IF (ICH .EQ. '''') THEN
          FIN = 1
          GOTO 10
        ENDIF
        IF (ICH .EQ. '+') THEN
          S   = 1.0
          NUM = 1
        ELSE IF (ICH .EQ. '-') THEN
          S   = -1.0
          NUM = 1
        ELSE IF (ICH .EQ. '_') THEN
          IF (NUM .EQ. 1) IP = 1
        ELSE IF (ICH .EQ. '.') THEN
          IP  = 1
          IF (NUM .EQ. 0) NUM = -1
        ELSE IF (I .EQ. 2 .AND. ICH .EQ. '?') THEN
          NUM = -1
          GOTO 40
        ELSE IF (ICH .EQ. '(') THEN
          GOTO 10
        ELSE IF (ICH .EQ. '/') THEN
          IFRC = 1
          GOTO 10
        ELSE IF (ICH .EQ. ')') THEN
          FIN = 1
          GOTO 10
        ELSE
          CALL GEN105 (3, ICH, N)
          IF (N .GE. 0) THEN
            NUM  = 1
            NP   = NP + IP
            A(K) = 10.0 * A(K) + N - 1
          ENDIF
        ENDIF
        GOTO 20
   10   A(K) = S * A(K) / 10.0**NP
        IF (FIN .EQ. 1) GOTO 30
        IP = 0
        S  = 1.0
        K  = 2
   20 CONTINUE
   30 IF (NUM * IFRC .NE. 0) THEN
        IF (A(1) .NE. 0.0 .AND. A(2) .NE. 0) THEN
          A(1) = A(1) / A(2)
          A(2) = 0.0
        ELSE
          NUM = 0
        ENDIF
      ENDIF
   40 RETURN
      END
      SUBROUTINE GEN043 (MODE, A, ANG)
      DIMENSION A(3, 3)
      CA = COS(ANG)
      SA = SIN(ANG)
      CALL GEN074 (A, 0.0, 1, 9)
      IF (MODE .EQ. 3) THEN
        A(1, 1) =  CA
        A(1, 2) =  SA
        A(2, 1) = -SA
        A(2, 2) =  CA
        A(3, 3) = 1.0
      ELSE IF (MODE .EQ. 2) THEN
        A(1, 1) = CA
        A(1, 3) = -SA
        A(2, 2) = 1.0
        A(3, 1) = SA
        A(3, 3) = CA
      ELSE IF (MODE .EQ. 1) THEN
        A(1, 1) = 1.0
        A(2, 2) = CA
        A(2, 3) = SA
        A(3, 2) = -SA
        A(3, 3) = CA
      ENDIF
      RETURN
      END
      SUBROUTINE GEN044 (P, R)
      DIMENSION P(6), R(3, 3)
      RAD     = ATAN2(1.0, 1.0) / 45.0
      R(1, 1) = P(1)
      R(1, 2) = P(2) * COS(P(6) * RAD)
      R(1, 3) = P(3) * COS(P(5) * RAD)
      R(2, 1) = 0.0
      R(2, 2) = P(2) * SIN(P(6) * RAD)
      R(2, 3) = P(3) * (COS(P(4) * RAD)  - COS(P(5) * RAD)
     1               *  COS(P(6) * RAD)) / SIN(P(6) * RAD)
      R(3, 1) = 0.0
      R(3, 2) = 0.0
      R(3, 3) = P(3) * SQRT(1.0 - COS(P(4) * RAD)**2
     1        - COS(P(5) * RAD)**2 - COS(P(6) * RAD)**2
     2        + 2.0 * COS(P(4) * RAD) * COS(P(5) * RAD)
     3            * COS(P(6) * RAD)) / SIN(P(6) * RAD)
      RETURN
      END
      FUNCTION GEN045 (C)
      REAL C(6)
      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 .LT. 0.0) STOP 'CELL VOLUME COMPLEX!!'
      GEN045 = C(1) * C(2) * C(3) * SQRT(VOL)
      RETURN
      END
      SUBROUTINE GEN046 (HKLP, X, Y, Z)
      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 GEN047 (LINE, N, M)
      CHARACTER LINE*(*)
C * ELIMINATE BLANKS
      IND = N
      DO 10 I = N, M
        IF (LINE(I:I) .NE. ' ') THEN
          LINE(IND:IND) = LINE(I:I)
          IND = IND + 1
        ENDIF
   10 CONTINUE
      CALL GEN038 (LINE, IND, M)
      RETURN
      END
      SUBROUTINE GEN048 (IKEY, IFLI, IBIT, IVL)
      COMMON /NBIT/ IBT(32)
      JKEY = IABS(IKEY)
      IF (JKEY .EQ. 1) THEN
        KEY = 2
      ELSE IF (JKEY .EQ. 10) THEN
        KEY = 1024
      ELSE IF (JKEY .NE. 0) THEN
        KEY = 2**JKEY
      ELSE
        DO 10 I = 1, 31
          IBT(I) = 2**(I - 1)
   10   CONTINUE
        GOTO 20
      ENDIF
      JBIT = IBT(IBIT)
      INH  = MOD(IFLI / JBIT, KEY)
      IF (IKEY .LT. 0) THEN
        IVL  = INH
      ELSE
        IFLI = IFLI + (IVL - INH) * JBIT
      ENDIF
   20 RETURN
      END
      FUNCTION GEN049 (LATC, JH, JK, JL)
      CHARACTER LATC*1
      S = 1.0
      IF (LATC .NE. 'P') THEN
        IF (LATC .EQ. 'A') THEN
          IF (MOD(JK + JL, 2) .NE. 0) S = - 1.0
        ELSE IF (LATC .EQ. 'B') THEN
          IF (MOD(JH + JL, 2) .NE. 0) S = - 1.0
        ELSE IF (LATC .EQ. 'C') THEN
          IF (MOD(JH + JK, 2) .NE. 0) S = - 1.0
        ELSE IF (LATC .EQ. 'F') THEN
          IF (MOD(JH + JK, 2) .NE. 0 .OR. MOD(JH + JL, 2) .NE. 0)
     1        S = - 1.0
        ELSE IF (LATC .EQ. 'I') THEN
          IF (MOD(JH + JK + JL, 2) .NE. 0) S = - 1.0
        ELSE IF (LATC .EQ. 'R') THEN
          IF (MOD(-JH + JK + JL, 3) .NE. 0) S = -1.0
        ENDIF
      ENDIF
      GEN049 = S
      RETURN
      END
      FUNCTION GEN050 (TM, IH, IK, IL, JH, JK, JL)
      DIMENSION TM(3, 3)
      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) .LT. 0.01) THEN
        IF (ABS(XK - JK) .LT. 0.01) THEN
          IF (ABS(XL - JL) .LT. 0.01) THEN
            GEN050 = 1.0
          ENDIF
        ENDIF
      ENDIF
      RETURN
      END
      SUBROUTINE GEN051 (MODE, RV, X, L)
      DIMENSION RM(3, 3), TM(3, 3), RV(3, 3)
      T1         = COS(X)
      T2         = SIN(X)
      I3         = MOD(L + 2, 3) + 1
      I1         = MOD(I3, 3) + 1
      I2         = MOD(I1, 3) + 1
      RM(I1, I1) = T1
      RM(I1, I2) = T2
      RM(I1, I3) = 0.0
      RM(I2, I1) = -T2
      RM(I2, I2) = T1
      RM(I2, I3) = 0.0
      RM(I3, I1) = 0.0
      RM(I3, I2) = 0.0
      RM(I3, I3) = 1.0
      IF (MODE .EQ. 0) THEN
        CALL GEN004 (RV, RM, TM)
      ELSE IF (MODE .EQ. 1) THEN
        CALL GEN004 (RM, RV, TM)
      ENDIF
      DO 20 J = 1, 3
        DO 10 K = 1, 3
          RV(J, K) = TM(J, K)
   10   CONTINUE
   20 CONTINUE
      RETURN
      END
      SUBROUTINE GEN053 (N, DATA, INDEX)
      DIMENSION DATA(N), INDEX(N)
      DO 10 I = 1, N
        INDEX(I) = I
   10 CONTINUE
      IF (N .GT. 1) THEN
        I = N / 2 + 1
        J = N
   20   IF (I .GT. 1) THEN
          I     = I - 1
          INEXT = INDEX(I)
          T     = DATA(INEXT)
        ELSE
          INEXT    = INDEX(J)
          T        = DATA(INEXT)
          INDEX(J) = INDEX(1)
          J        = J - 1
          IF (J .EQ. 1) THEN
            INDEX(1) = INEXT
            GOTO 40
          ENDIF
        ENDIF
        K = I
        L = 2 * I
   30   IF (L .LE. J) THEN
          IF (L .LT. J) THEN
            IF (DATA(INDEX(L)) .LT. DATA(INDEX(L + 1))) L = L + 1
          ENDIF
          IF (T .LT. DATA(INDEX(L))) THEN
            INDEX(K) = INDEX(L)
            K = L
            L = 2 * L
          ELSE
            L = J + 1
          ENDIF
          GOTO 30
        ENDIF
        INDEX(K) = INEXT
        GOTO 20
      ENDIF
   40 RETURN
      END
      SUBROUTINE GEN054 (N, M, A, U, V)
      PARAMETER (NMAX = 999)
      DIMENSION A(M, M), U(M), V(M, M), B(NMAX), Z(NMAX)
      DOUBLE PRECISION A, U, V, B, Z, T, THRESH, E, AII, AJJ,
     1       THETA, C, S, TAU, P, Q
      DO 20 I = 1, N
        DO 10 J = 1, N
          V(I, J) = 0
   10   CONTINUE
        V(I, I) = 1
   20 CONTINUE
      DO 30 I = 1, N
        T    = A(I, I)
        U(I) = T
        B(I) = T
        Z(I) = 0
   30 CONTINUE
      DO 130 NCYCLE = 1, 50
        T = 0
        DO 50 I = 1, N - 1
          DO 40 J = I + 1, N
            T = T + ABS(A(I, J))
   40     CONTINUE
   50   CONTINUE
        IF (T .EQ. 0) RETURN
        IF (NCYCLE .LT. 4) THEN
          THRESH = T / (5 * N**2)
        ELSE
          THRESH = 0
        ENDIF
        DO 110 I = 1, N - 1
          DO 100 J = I + 1, N
            T   = ABS(A(I, J))
            E   = 100 * T
            AII = ABS(U(I))
            AJJ = ABS(U(J))
            IF (NCYCLE .GT. 4 .AND. AII + E .EQ. AII .AND.
     1                              AJJ + E .EQ. AJJ) THEN
              A(I, J) = 0
            ELSE IF (T .GT. THRESH) THEN
              T = ABS(AJJ - AII)
              IF (T + E .EQ. T) THEN
                T = A(I, J) / (AJJ - AII)
              ELSE
                THETA = (AJJ - AII) / (2 * A(I, J))
                T     = 1 / (ABS(THETA) + SQRT(1 + THETA**2))
                IF (THETA .LT. 0) T = -T
              ENDIF
              C   = 1 / SQRT(1 + T**2)
              S   = T * C
              TAU = S / (1 + C)
              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
              DO 60 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)
   60         CONTINUE
              DO 70 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)
   70         CONTINUE
              DO 80 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)
   80         CONTINUE
              DO 90 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)
   90         CONTINUE
            ENDIF
  100     CONTINUE
  110   CONTINUE
        DO 120 I = 1, N
          B(I) = B(I) + Z(I)
          U(I) = B(I)
          Z(I) = 0
  120   CONTINUE
  130 CONTINUE
      STOP '50 CYCLES OF JACOBI ROTATIONS SHOULD NEVER BE NECESSARY.'
      END
      SUBROUTINE GEN055 (YLM, XYZ, L0MAX, L1MAX)
      DIMENSION XYZ(3), YLM(80), FCLM(0:44), FNLM(0:44)
      DATA FCLM /
     1 1,
     2 1, 1,
     3 0.5, 3, 3,
     4 0.5, 1.5, 15, 15,
     5 0.125, 2.5, 7.5, 105, 105,
     6 0.125, 1.875, 52.5, 52.5, 945, 945,
     7 0.0625, 2.625, 13.125, 157.5, 472.5, 10395, 10395,
     8 0.0625, 0.4375, 7.875, 39.375, 1732.5, 5197.5, 135135, 135135,
     9 0.0078125, 0.5625, 19.6875, 433.125, 1299.375, 67567.5, 67567.5,
     * 2027025, 2027025/
      DATA FNLM /
     1 0.0795774,
     2 0.3183099, 0.3183099,
     3 0.2067483, 0.7500000, 0.3750000,
     4 0.2448538, 0.3203331, 1.0000000, 0.4244132,
     5 0.0694175, 0.4740025, 0.3305913, 1.2500000, 0.4687500,
     6 0.0767395, 0.3229812, 1.6875000, 0.3451455, 1.5000000, 0.5092958,
     7 0.0417084, 0.4172129, 0.3261107, 0.6513219, 0.3610405, 1.7500000,
     8 0.5468750,
     9 0.0447979, 0.0648780, 0.1573192, 0.1109240, 0.7404370, 0.3772319,
     * 2.0000000, 0.5820523,
     1 0.0059609, 0.0784858, 0.3253786, 0.8780415, 0.3411683, 2.4892756,
     2 0.3933012, 2.2500000, 0.6152344/
      CALL GEN074 (YLM, 0.0, 1, 80)
      IF (L0MAX .EQ. 0 .AND. L1MAX .EQ. 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
      IF (L1MAX .GE. 1) THEN
        YLM(1) = Z
        YLM(2) = X
        YLM(3) = Y
      ENDIF
      IF (L0MAX .GE. 2) THEN
        YLM(4) = 3 * ZK - 1
        YLM(5) = Z * X
        YLM(6) = Z * Y
        YLM(7) = XK - YK
        YLM(8) = 2 * X * Y
      ENDIF
      IF (L1MAX .GE. 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
      ENDIF
      IF (L0MAX .GE. 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
      ENDIF
      IF (L1MAX .GE. 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
      ENDIF
      IF (L0MAX .GE. 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
      ENDIF
      IF (L1MAX .GE. 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
      ENDIF
      IF (L0MAX .GE. 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
      ENDIF
      I = 0
      J = 0
      LMAX = MAX (L0MAX, L1MAX)
      DO 40 L = 1, LMAX
        DO 30 M = 0, L
          I = I + 1
          F = FCLM(I) * FNLM(I)
          DO 20 IP = 0, MIN(M, 1)
            J = J + 1
            YLM(J) = F * YLM(J)
   20     CONTINUE
   30   CONTINUE
   40 CONTINUE
      I = 0
      N = 0
      DO 60 L = 1, LMAX
        DO 50 M = -L, L
          I = I + 1
          IF ((MOD(L, 2) .EQ. 0 .AND. L .LE. L0MAX) .OR.
     1        (MOD(L, 2) .EQ. 1 .AND. L .LE. L1MAX)) THEN
            N = N + 1
            YLM(N) = YLM(I)
          ENDIF
   50   CONTINUE
   60 CONTINUE
      RETURN
      END
      FUNCTION GEN056 (IH, IK, IL, GINV)
      DIMENSION H(3), GINV(3, 3)
      H(1) = IH
      H(2) = IK
      H(3) = IL
      GEN056 = 0.5 * SQRT(GEN006 (H, GINV, H))
      RETURN
      END
      SUBROUTINE GEN057 (A, X, D, N)
      DIMENSION A(N, N), X(N), D(N)
      K  = 0
      I  = 1
   10 J  = I
      RL = 0
   20 IF (ABS(A(J, I)) .GT. RL) THEN
        RL = ABS(A(J, I))
        K  = J
      ENDIF
      J = J + 1
      IF (J .LE. N) GOTO 20
      J = I
      IF (K .NE. I) THEN
   30   Y = A(I, J)
        A(I, J) = A(K, J)
        A(K, J) = Y
        J = J + 1
        IF (J .LE. N) GOTO 30
        Y = D(I)
        D(I) = D(K)
        D(K) = Y
      ENDIF
      J = I + 1
      IF (I .NE. 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 .LE. N) GOTO 50
        D(J) = D(J) - RM * D(I)
        J = J + 1
        IF (J .LE. N) GOTO 40
        I = I + 1
        IF (I .LE. N) GOTO 10
      ENDIF
      I = N
   60 E = D(I)
      IF (I .NE. N) THEN
        J = I + 1
   70   E = - A(I, J) * X(J) + E
        J = J + 1
        IF (J .LE. N) GOTO 70
      ENDIF
      X(I) = E / A(I, I)
      I    = I - 1
      IF (I .NE. 0) GOTO 60
      RETURN
      END
      SUBROUTINE GEN058 (LABI, NR)
      CHARACTER LABI*4
      IF (LABI(2:2) .NE. ' ') THEN
        L0 = 1
        NO = 10 + NR
      ELSE
        L0 = 0
        NO = 500 + NR
      ENDIF
      IF (NO .LT. 100) THEN
        WRITE (LABI(2+L0:3+L0), '(I2)') NO
      ELSE
        WRITE (LABI(2:4), '(I3)') NO
      ENDIF
      RETURN
      END
      SUBROUTINE GEN059 (A, B, C)
      DIMENSION C(4, 4), A(4, 4), B(4, 4)
      DO 20 I = 1, 4
        DO 10 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)
   10   CONTINUE
   20 CONTINUE
      RETURN
      END
      SUBROUTINE GEN060 (A, B)
      DIMENSION B(4, 4), A(4, 4)
      DO 20 I = 1, 4
        DO 10 J = 1, 4
          B(I, J) = A(J, I)
   10   CONTINUE
   20 CONTINUE
      RETURN
      END
      FUNCTION GEN061 (A, AI)
      DIMENSION AI(4, 4), A(4, 4), TMP(4, 4), INDEX(4)
      DO 20 I = 1, 4
        DO 10 J = 1, 4
          TMP(I, J) = A(I, J)
          AI(I, J) = 0.0
   10   CONTINUE
        AI(I, I) = 1.0
   20 CONTINUE
      CALL GEN062 (TMP, 4, INDEX, D)
      GEN061 = D * TMP(1, 1) * TMP(2, 2) * TMP(3, 3) * TMP(4, 4)
      DO 30 J = 1, 4
        CALL GEN063 (TMP, 4, INDEX, AI(1, J))
   30 CONTINUE
      RETURN
      END
      SUBROUTINE GEN062 (A, N, INDEX, D)
      PARAMETER (NMAX = 10)
      DIMENSION INDEX(N), A(N, N), VV(NMAX)
C***********************************************************************
C***********************************************************************
      IMAX = 0
      D    = 1.0
      DO 20 I = 1, N
        AAMAX = 0.0
        DO 10 J = 1, N
          IF (ABS(A(I, J)) .GT. AAMAX) AAMAX = ABS(A(I, J))
   10   CONTINUE
        VV(I) = 1.0 / AAMAX
   20 CONTINUE
      DO 90 J = 1, N
        IF (J .GT. 1) THEN
          DO 40 I = 1, J - 1
            SUM = A(I, J)
            IF (I .GT. 1) THEN
              DO 30 K = 1, I - 1
                SUM = SUM - A(I, K) * A(K, J)
   30         CONTINUE
              A(I, J) = SUM
            ENDIF
   40     CONTINUE
        ENDIF
        AAMAX = 0.0
        DO 60 I = J, N
          SUM = A(I, J)
          IF (J .GT. 1) THEN
            DO 50 K = 1, J - 1
              SUM = SUM - A(I, K) * A(K, J)
   50       CONTINUE
            A(I, J) = SUM
          ENDIF
          DUM = VV(I) * ABS(SUM)
          IF (DUM .GE. AAMAX) THEN
	    IMAX = I
	    AAMAX = DUM
          ENDIF
   60   CONTINUE
        IF (J .NE. IMAX) THEN
          DO 70 K = 1, N
	    DUM = A(IMAX, K)
	    A(IMAX, K) = A(J, K)
	    A(J, K) = DUM
   70     CONTINUE
          D = - D
          VV(IMAX) = VV(J)
        ENDIF
        INDEX(J) = IMAX
        IF (J .NE. N) THEN
          DUM = 1.0 / A(J, J)
	  DO 80 I = J + 1, N
	    A(I, J) = A(I, J) * DUM
   80     CONTINUE
        ENDIF
   90 CONTINUE
      RETURN
      END
      SUBROUTINE GEN063 (A, N, INDEX, B)
      DIMENSION INDEX(N), A(N, N), B(N)
      II = 0
      DO 20 I = 1, N
        LL = INDEX(I)
        SUM = B(LL)
        B(LL) = B(I)
        IF (II .NE. 0) THEN
          DO 10 J = II, I - 1
            SUM = SUM - A(I, J) * B(J)
   10     CONTINUE
        ELSE IF (SUM .NE. 0.0) THEN
        II = I
        ENDIF
        B(I) = SUM
   20 CONTINUE
      DO 40 I = N, 1, -1
        SUM = B(I)
        IF (I .LT. N) THEN
          DO 30 J = I + 1, N
            SUM = SUM - A(I, J) * B(J)
   30     CONTINUE
        ENDIF
        B(I) = SUM / A(I, I)
   40 CONTINUE
      RETURN
      END
      SUBROUTINE GEN064 (A, N, NP, D, V)
      PARAMETER (NMAX=100)
      PARAMETER (TINY = 1.E-37)
      DIMENSION A(NP, NP), D(NP), V(NP, NP), B(NMAX), Z(NMAX)
C***********************************************************************
C***********************************************************************
      DO 20 IP = 1, N
        DO 10 IQ = 1, N
          V(IP, IQ) = 0.0
   10   CONTINUE
        V(IP, IP) = 1.0
        B(IP)     = A(IP, IP)
        D(IP)     = B(IP)
        Z(IP)     = 0.0
   20 CONTINUE
      DO 120 I = 1, 50
        SM = 0.0
        DO 40 IP = 1, N - 1
          DO 30 IQ = IP + 1, N
            SM = SM + ABS(A(IP, IQ))
   30     CONTINUE
   40   CONTINUE
        IF (SM .LT. TINY) RETURN
        IF (I .LT. 4) THEN
          THRESH = 0.2 * SM / (N * N)
        ELSE
	  THRESH = 0.0
        ENDIF
        DO 100 IP = 1, N - 1
          DO 90 IQ = IP + 1, N
	    G = 100. * ABS(A(IP, IQ))
	    IF ((I .GT. 4) .AND.
     1	      (ABS(D(IP)) + G .EQ. ABS(D(IP))) .AND.
     2		    (ABS(D(IQ)) + G .EQ. ABS(D(IQ)))) THEN
              A(IP,IQ) = 0.0
	    ELSE IF (ABS(A(IP, IQ)) .GT. THRESH) THEN
	      H = D(IQ) - D(IP)
	      IF (ABS(H) + G .EQ. 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 .LT. 0.0) T = -T
	      ENDIF
	      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 50 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)
   50         CONTINUE
	      DO 60 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)
   60         CONTINUE
	      DO 70 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)
   70         CONTINUE
	      DO 80 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)
   80         CONTINUE
	    ENDIF
   90     CONTINUE
  100   CONTINUE
        DO 110 IP = 1, N
	  B(IP) = B(IP) + Z(IP)
	  D(IP) = B(IP)
	  Z(IP) = 0.0
  110   CONTINUE
  120 CONTINUE
      RETURN
      END
      SUBROUTINE GEN065 (LU, PRBUF, JBUFL, JSUBST)
      CHARACTER PRBUF*(*), PCH*1, PCH0*1, PCH1*1, STR1(56)*8,
     1 STR2(56)*8, STR3(47)*6, STR4(47)*6, STR5(16)*6, STR6(16)*6,
     2 PRB*133
      DATA 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'/
      DATA 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'/
      DATA 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.250', '-0.333', '-0.375', '-0.500', '-0.625',
     6 '-0.667', '-0.750', '-0.833', '-0.875', '-1.000', '-1.125',
     7 '-1.167', '-1.250', '-1.333', '-1.375', '-1.500', '-1.625',
     8 '-1.667', '-1.750', '-1.833', '-1.875', '-2.000'/
      DATA 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', '  -1/4', '  -1/3', '  -3/8', '  -1/2', '  -5/8',
     6 '  -2/3', '  -3/4', '  -5/6', '  -7/8', '    -1', '  -9/8',
     7 '  -7/6', '  -5/4', '  -4/3', ' -11/8', '  -3/2', ' -13/8',
     8 '  -5/3', '  -7/4', ' -11/6', ' -15/8', '    -2'/
      DATA 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 '/
      DATA 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 '/
      J0  = 0
      J   = 0
      JL  = 0
      PRB = PRBUF(1:JBUFL)//' '
      IBUFL = JBUFL + 1
      IPAR   = 0
      K0     = 0
      JSUBST0 = MOD (JSUBST, 2)
      IF (JSUBST0 .EQ. 1) THEN
        DO 40 I = 2, IBUFL
          PCH = PRB(I : I)
          IF (PCH .EQ. '(') THEN
            I0   = I - 1
            J0   = I0
            PCH0 = PRB(I0 : I0)
            IF (PCH0 .EQ. '.') THEN
              IDOT = 1
            ELSE
              IDOT = 0
            ENDIF
   10       J0   = J0 - 1
            IF (J0 .EQ. 0) THEN
              PCH0 = ''''
            ELSE
              PCH0 = PRB(J0 : J0)
            ENDIF
            IF (IDOT .EQ. 1) PRB(J0 + 1 : J0 + 1) = PCH0
            IF (PCH0 .NE. ' ' .AND. PCH0 .NE. ')' .AND.
     1          PCH0 .NE. '''' .AND. PCH0 .NE. '"' .AND.
     2          PCH0 .NE. '-' .AND. J0 .GT. K0) GOTO 10
            IF (IDOT .EQ. 1) PRB(J0 : J0) = ' '
            J0 = J0 - 1 + IDOT
            IF (PCH0 .EQ. '''' .OR. PCH0 .EQ. '"') J0 = J0 + 1
            IPAR = 1
            J    = I
            JL   = I
          ELSE IF (IPAR .GT. 0) THEN
            IF (PCH .EQ. ')') THEN
              K0 = I + 1
              IF (J .GT. JL) THEN
                J            = J + 1
                PRB(J : J) = PCH
              ELSE
                J      = J - 1
              ENDIF
              IF (J .LT. I) THEN
                KMAX = J - J0
                ITAR = I + 1
                JFRM = J + 1
                DO 20 K = 1, KMAX
                  PCH1 = PRB(JFRM - K : JFRM - K)
                  PRB(ITAR - K : ITAR - K) = PCH1
   20           CONTINUE
                DO 30 K = J0 + 1, I - KMAX
                  PRB(K : K) = ' '
   30           CONTINUE
              ENDIF
              IPAR = 0
            ELSE IF (PCH .NE. ' ') THEN
              IF (PCH .EQ. '0') THEN
                IF (J .GT. JL) THEN
                  J            = J + 1
                  PRB(J : J) = PCH
                ENDIF
              ELSE
                J            = J + 1
                PRB(J : J) = PCH
              ENDIF
            ENDIF
          ENDIF
   40   CONTINUE
      ENDIF
      ISUBST  = JSUBST / 2
      JSUBST1 = MOD (ISUBST, 2)
      IF (JSUBST1 .EQ. 1) THEN
        DO 60 I = 9, IBUFL
          DO 50 K = 1, 56
            IF (PRB(I - 8 : I) .EQ. STR1(K)//' ') THEN
                PRB(I - 8 : I) = STR2(K)//' '
              GOTO 60
            ENDIF
   50     CONTINUE
   60   CONTINUE
      ENDIF
      ISUBST  = ISUBST / 2
      JSUBST2 = MOD (ISUBST, 2)
      IF (JSUBST2 .EQ. 1) THEN
        DO 80 I = 7, IBUFL
          DO 70 K = 1, 47
            IF (PRB(I - 6 : I) .EQ. STR3(K)//' ' .OR.
     1          PRB(I - 6 : I) .EQ. STR3(K)//'-') THEN
                PRB(I - 6 : I - 1) = STR4(K)
              GOTO 80
            ENDIF
   70     CONTINUE
   80   CONTINUE
      ENDIF
      ISUBST  = ISUBST / 2
      JSUBST3 = MOD (ISUBST, 2)
      IF (JSUBST3 .EQ. 1) THEN
        DO 90 I = 8, IBUFL
          IF (PRB(I - 7: I) .EQ. ' 0.0000 ' .OR.
     1        PRB(I - 7: I) .EQ. ' 0.0000-') THEN
              PRB(I - 7: I - 1)  =  '      0'
          ELSE IF (PRB(I - 7: I) .EQ. ' 1.0000 ' .OR.
     1             PRB(I - 7: I) .EQ. ' 1.0000-') THEN
              PRB(I - 7: I - 1)  =  '      1'
          ELSE IF (PRB(I - 7: I) .EQ. '-1.0000 ' .OR.
     1             PRB(I - 7: I) .EQ. '-1.0000-') THEN
              PRB(I - 7: I - 1)  =  '     -1'
          ENDIF
   90   CONTINUE
      ENDIF
      ISUBST  = ISUBST / 2
      JSUBST4 = MOD (ISUBST, 2)
      IF (JSUBST4 .EQ. 1) THEN
        DO 100 I = 6, IBUFL
          DO 110 J = 1, 16
            IF (PRB(I - 5: I) .EQ. STR5(J)) THEN
              PRB(I - 5: I) = STR6(J)
            ENDIF
  110     CONTINUE
  100   CONTINUE
      ENDIF
      PRBUF = PRB(1:JBUFL)
      IF (LU .NE. 0) WRITE (LU, '(A)') PRBUF(1 : JBUFL)
      RETURN
      END
      SUBROUTINE GEN066 (MODE, PARA, PARS, KS)
      DIMENSION PARA(6), PARS(6)
      CHARACTER KS*1
      IF (MODE .EQ. 2) THEN
        TOL = 0.5
      ELSE
        TOL = 0.1
      ENDIF
      IF (KS .EQ. 'm') THEN
        IF (ABS(PARA(4) - 90.0) + ABS(PARA(6) - 90.0) .LT. TOL) THEN
          PARA(4) = 90.0
          PARA(6) = 90.0
          IF (MODE .GT. 0) THEN
            PARS(4) = 0.0
            PARS(6) = 0.0
          ENDIF
        ENDIF
      ELSE IF (KS .EQ. 'o') THEN
        PARA(4) = 90.0
        PARA(5) = 90.0
        PARA(6) = 90.0
        IF (MODE .GT. 0) THEN
          PARS(4) = 0.0
          PARS(5) = 0.0
          PARS(6) = 0.0
        ENDIF
      ELSE IF (KS .EQ. '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 .GT. 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
        ENDIF
      ELSE IF (KS .EQ. '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 .GT. 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
        ENDIF
      ELSE IF (KS .EQ. '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 .GT. 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
        ENDIF
      ELSE IF (KS .EQ. '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 .GT. 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
        ENDIF
      ENDIF
      RETURN
      END
      SUBROUTINE GEN067 (TM, CELO, CELN, CSDO, CSDN)
      DIMENSION AA(3, 3), BB(3, 3), C(6), D(6),
     1          TM(3, 3), CELO(6), CELN(6), CSDO(6), CSDN(6)
      DEL = 0.001
      RTD = 45.0 / ATAN2 (1.0, 1.0)
      DO 20 J = 1, 6
        D(J) = 0.0
        DO 10 I = 1, 6
          CELO(I) = CELO(I) + DEL
          CALL GEN026 (1, AA, CELO(1), RTD)
          CELO(I) = CELO(I) - DEL
          CALL GEN001 (1, TM, AA, BB)
          CALL GEN026 (-1, BB, C(1), RTD)
          D(J) = D(J) + ((CELN(J) - C(J)) * CSDO(I) / DEL) ** 2
   10   CONTINUE
   20 CONTINUE
      DO 30 J = 1, 6
        CSDN(J) = SQRT (D(J))
   30 CONTINUE
      RETURN
      END
      SUBROUTINE GEN068 (CELL, V, CESD, SV)
      DIMENSION CELL(6), CESD(6), V1(3), V2(3), V3(3), V4(3)
      DTR = 45.0 / ATAN2 (1.0, 1.0)
      DO 10 I = 1, 3
        V4(I) = COS(CELL(3 + I) / DTR)
        IF (ABS(V4(I)) .LT. 1E-6) V4(I) = 0.0
        V3(I) = SIN(CELL(3 + I) / DTR)
        R = CESD(I) / CELL(I)
        IF (R .LT. 1E-9) THEN
          V1(I) = 0.0
        ELSE
          V1(I) = R**2
        ENDIF
   10 CONTINUE
      R = 1.0 - V4(1)**2 - V4(2)**2 + V4(3) *
     1    (2.0 * V4(1) * V4(2) - V4(3))
      V2(1) = V4(1) - V4(2) * V4(3)
      V2(2) = V4(2) - V4(1) * V4(3)
      V2(3) = V4(3) - V4(1) * V4(2)
      Q1    = 0.0
      Q2    = 0.0
      DO 20 I = 1, 3
        Q1 = Q1 + V1(I)
        Q3 = V3(I) * V2(I) * CESD(3 + I) / DTR
        IF (ABS(Q3) .LT. 1E-8) Q3 = 0.0
        Q2 = Q2 + Q3**2
   20 CONTINUE
      SV = V * SQRT(Q1 + Q2 / (R**2))
      RETURN
      END
      SUBROUTINE GEN069 (K, A, B, C, P, SIGMA, D, G)
      DIMENSION A(*), B(*), C(*), P(*), D(*), G(*),
     1 S1(1000), S0(1000)
      IF (K .NE. 0) GOTO 10
      D(1) = 1.0
      P(1) = C(1)
      GOTO 90
   10 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 .LE. 1) GOTO 90
      DO 20 I = 2, K
        D(I + 1) = 0.0
        P(I + 1) = 0.0
   20 CONTINUE
      K1 = K - 1
      DO 80 J = 1, K1
         S0(J + 2) = 1.0
         S0(J + 1) = S1(J) - A(J + 1)
         IF (J .GT. 1) S0(J) = S1(J - 1) - A(J + 1) * S1(J) - B(J)
         IF (J .LT. 3) GOTO 40
         J1 = J - 2
         DO 30 I1 = 1, J1
           I = J1 - I1 + 1
           S0(I + 1) = S1(I) - A(J + 1)*S1(I + 1) - B(J) * S0(I + 1)
   30    CONTINUE
   40    S0(1) = -A(J + 1) * S1(1) - B(J) * S0(1)
         J1 = J + 2
         DO 70 I = 1, J1
           IF (I .EQ. J1) GOTO 50
           H     = S1(I)
           S1(I) = S0(I)
           S0(I) = H
           GOTO 60
   50      S1(I) = S0(I)
   60      P(I)  = P(I) + C(J + 2) * S1(I)
           D(I)  = D(I) + S1(I)**2 / G(J + 2)
   70    CONTINUE
   80 CONTINUE
   90 K1 = K + 1
      DO 100 I = 1, K1
        D(I) = SIGMA * SQRT(D(I))
  100 CONTINUE
      RETURN
      END
      SUBROUTINE GEN070 (N, X, F, W, K, A, B, C, G, V)
      DIMENSION X(*), F(*), W(*), A(*), B(*), C(*), G(*), V(*)
      DELTA = 0.0
      DO 10 J = 1, N
        DELTA = DELTA + W(J) * F(J)**2
   10 CONTINUE
      K3 = K + 1
      DO 60 I3 = 1, K3, 1
        I = I3 - 1
        XS = 0.0
        FS = 0.0
        S1 = 0.0
        S0 = 0.0
        DO 40 J = 1, N
          G1 = 1.0
          G0 = 0.0
          IF (I .GT. 0) THEN
            DO 20 I1 = 1, I, 1
              S = 0.0
              IF (I1 .NE. 1) S = B(I1 - 1) * G0
              G0 = (X(J) - A(I1)) * G1 - S
              S  = G0
              G0 = G1
              G1 = S
   20       CONTINUE
          ENDIF
          S1 = S1 + G1**2 * W(J)
          FS = FS + G1 * F(J) * W(J)
          IF (I .NE. K) THEN
            S0 = S0 + G0**2 * W(J)
            XS = XS + G1**2 * X(J) * W(J)
          ENDIF
   40   CONTINUE
        IF (I .NE. K) THEN
          A(I + 1) = XS / S1
          IF (I .NE. 0) B(I) = S1 / S0
        ENDIF
        C(I + 1) = FS / S1
        G(I + 1) = S1
        IF (I .NE. 0) V(I + 1) = ABS(V(I)  - C(I + 1)**2 * S1)
        IF (I .EQ. 0) V(I + 1) = ABS(DELTA - C(I + 1)**2 * S1)
   60 CONTINUE
      RETURN
      END
      REAL FUNCTION GEN071 (K, A, B, C, T, DER)
      PARAMETER (IP5=2)
      DIMENSION A(IP5), B(IP5), C(IP5)
      D0  = 0.0
      G0  = 0.0
      S1  = C(1)
      G1  = 1.0
      DER = 0.0
      D1  = 0.0
      IF (K .EQ. 0) GOTO 20
      DO 10 I = 1, K
        S = 0.0
        IF (I .NE. 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 .NE. 1) S = B(I - 1) * G0
        G0 = (T - A(I)) * G1 - S
        S  = G0
        G0 = G1
        G1 = S
        S1 = S1 + C(I + 1) * G1
   10 CONTINUE
   20 GEN071 = S1
      RETURN
      END
      SUBROUTINE GEN072 (LINE, IFL, FN, KL, KN, LU5, LU6, IUP,
     1 JMIN, JMAX, NCHAR, NP17)
      CHARACTER LINE*80, ICL*80, IFL(*)*(*), ICH*1
      DIMENSION FN(*)
      GOTO 20
    1 IF (LU6 .NE. 0) WRITE (LU6, 99999)
   20 KN    = 0
      KL    = 0
      ICONT = 0
      CALL GEN074 (FN, 0.0, 1, NP17)
      DO 10 I = 1, NP17
        CALL GEN038 (IFL(I), 1, NCHAR)
   10 CONTINUE
   15 IMIN = JMIN
      IMAX = JMAX
      IF (LU5 .NE. 0) READ (LU5, '(A)', END = 230, ERR = 1) LINE
      IF (LINE(1:4) .EQ. 'EXTI') IMAX = 4
      IF (LINE(1:4) .EQ. 'TITL') THEN
        N = INDEX (LINE, '=')
        IF (N .NE. 0) IMAX = N - 1
      ENDIF
      IF (IMAX .EQ. 0) THEN
        IMIN = 1
        INUM = 0
        DO 30 I = JMIN, 80
          ICH  = LINE(I:I)
          CALL GEN105 (3, ICH, J)
          IF (J .GE. 0) THEN
            INUM = 1
            GOTO 45
          ENDIF
          IF (ICH .EQ. '.') THEN
            INUM = 1
            GOTO 45
          ENDIF
          IF (INUM .EQ. 1) THEN
            INUM = 0
            IF (ICH .NE. ' ') THEN
              IF (IMAX .LT. 80) THEN
                IMAX = IMAX + 1
                ICL(IMAX:IMAX) = ' '
              ENDIF
            ENDIF
          ENDIF
   45     IF (IMAX .LT. 80) THEN
            IMAX = IMAX + 1
            ICL(IMAX:IMAX) = LINE(I:I)
          ENDIF
   30   CONTINUE
      ELSE
        ICL = LINE
      ENDIF
      DO 41 I = 1, 80
        IF (ICL(I:I) .EQ. CHAR(13)) ICL(I:I) = ' '
   41 CONTINUE
      IF (IMAX .EQ. 0) GOTO 220
      IF (IUP .EQ. 1) CALL GEN020 (1, ICL, IMIN, IMAX)
      DO 4 I = IMIN, IMAX
        ICH = ICL(I:I)
        IF (ICH .EQ. '=') THEN
          IMAX  = I - 1
          ICONT = 1
          GOTO 50
        ENDIF
    4 CONTINUE
      ICONT = 0
   50 I     = IMIN - 1
   60 A     = 0.0
      IP    = 0
      NP    = 0
      L     = 0
      S     = 1.0
   70 I     = I + 1
      IF (I .GT. IMAX) GOTO 130
      ICH   = ICL(I:I)
      IF (L .EQ. 0 .AND. ICH .EQ. ' ') GOTO 70
      L     = L + 1
      CALL GEN105 (3, ICH, J)
      IF (J .GE. 0) THEN
        NP = NP + IP
        A  = 10.0 * A + J - 1
        GOTO 70
      ENDIF
      IF (ICH .EQ. '.') THEN
        IP = 1
      ELSE IF (ICH .EQ. '+') THEN
        IF (L .GT. 1) GOTO 140
        S = 1.0
      ELSE IF (ICH .EQ. '-') THEN
        IF (L .GT. 1) GOTO 140
        S = -1.0
      ELSE IF (ICH .EQ. ')') THEN
        GOTO 140
      ELSE
        IF (L .GT. 1) GOTO 140
        GOTO 160
      ENDIF
      GOTO 70
  130 IF (L .LE. 0) GOTO 220
C * END OF NUMERIC FIELD
  140 A = S * A / 10.0**NP
      IF (KN .LT. NP17) THEN
        KN     = KN + 1
        FN(KN) = A
      ENDIF
      IF (ICH .EQ. '+' .OR. ICH .EQ. '-') I = I - 1
      GOTO 60
C * START NEW LITERAL FIELD
  160 KL = KL + 1
  170 IFL(KL)(L:L) = ICH
      L = L + 1
  180 I = I + 1
      IF (I .GT. IMAX) GOTO 200
      ICH = ICL(I:I)
      IF (ICH .EQ. ' ' .OR. ICH .EQ. ',') GOTO 200
      IF (ICH .EQ. '(' .AND. L .GT. 3) GOTO 200
      IF (ICH .EQ. '+' .OR. ICH .EQ. '-' .OR. ICH .EQ. '.') GOTO 190
      IF (L .GT. NCHAR) THEN
        GOTO 180
      ELSE
        GOTO 170
      ENDIF
  190 I = I - 1
  200 GOTO 60
  220 IF (ICONT .EQ. 1) GOTO 15
      RETURN
  230 IFL(1) = 'EOF       '
      KL     = 1
      RETURN
99999 FORMAT (/, '** ^C Ignored - s[default]', $)
      END
      SUBROUTINE GEN073 (A, B, C, D, E, I, J, K)
      DIMENSION A(3, *), B(3, *), C(3, *)
      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 GEN074 (A, VALUE, NB, NE)
      DIMENSION A(*)
      DO 10 I = NB, NE
        A(I) = VALUE
   10 CONTINUE
      RETURN
      END
      SUBROUTINE GEN075 (A, B, C, I, J, K)
      DIMENSION A(3, *),B(3, *)
      X = 0.0
      DO 10 L = 1, 3
        Y = A(L, I)
        Z = B(L, J)
        X = X + Y * Z
   10 CONTINUE
      IF (K .EQ. 1) THEN
        C = X
      ELSE
        C = SQRT(X)
      ENDIF
      RETURN
      END
      SUBROUTINE GEN076 (A, B, C, I, J, K)
      DIMENSION A(3, *),B(3, *),C(3, *)
      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 GEN077 (A, B, C, I, J, N)
      DIMENSION A(3, 3, *), B(3, 3, *), C(3, 3, *), X(3, 3)
      DO 30 K = 1, 3
        DO 20 L = 1, 3
          X(K, L) = 0.0
          DO 10 M = 1, 3
            Y = A(K, M, I)
            Z = B(M, L, J)
            X(K, L) = X(K, L) + Y * Z
   10     CONTINUE
   20   CONTINUE
   30 CONTINUE
      DO 50 K = 1, 3
        DO 40 L = 1, 3
          C(K, L, N) = X(K, L)
   40   CONTINUE
   50 CONTINUE
      RETURN
      END
      SUBROUTINE GEN078 (A, B, C, I, J, K)
      DIMENSION A(3, 3, *), B(3, *), C(3, *), X(3)
      DO 20 L = 1, 3
        X(L) = 0.0
        DO 10 M = 1, 3
          Y    = A(L, M, I)
          Z    = B(M, J)
          X(L) = X(L) + Y * Z
   10   CONTINUE
   20 CONTINUE
      DO 30 L = 1, 3
        C(L, K) = X(L)
   30 CONTINUE
      RETURN
      END
      SUBROUTINE GEN079 (A, B, I, J)
      DIMENSION A(3, 3, *), B(3, 3, *)
      DO 20 K = 1, 3
        DO 10 L = 1, 3
          B(K, L, J) = A(K, L, I)
   10   CONTINUE
   20 CONTINUE
      RETURN
      END
      SUBROUTINE GEN080 (A, B, I, J)
      DIMENSION A(3, *), B(3, *)
      B(1, J) = A(1, I)
      B(2, J) = A(2, I)
      B(3, J) = A(3, I)
      RETURN
      END
      SUBROUTINE GEN081 (A, B, M, N)
      DIMENSION A(3, 3, *), B(3, 3, *), C(3, 3)
      DO 20 I = 1, 3
        DO 10 J = 1, 3
          C(I, J) = A(J, I, M)
   10   CONTINUE
   20 CONTINUE
      CALL GEN079 (C, B, 1, N)
      RETURN
      END
      SUBROUTINE GEN082 (A, I)
      DIMENSION A(3, *)
      CALL GEN075 (A, A, B, I, I, 2)
      IF (B .NE. 0.0) THEN
        DO 10 J = 1, 3
          A(J, I) = A(J, I) / B
   10   CONTINUE
      ENDIF
      RETURN
      END
      SUBROUTINE GEN083 (T, U, V, A)
      DIMENSION T(3), U(3), V(3), AA(3, 3), DD(3, 3), A(4)
      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 10 I = 1, 3
        CALL GEN079 (DD, AA, 1, 1)
        CALL GEN074 (AA(1, I), 1.0, 1, 3)
        A(I) = GEN084 (AA, 1)
   10 CONTINUE
      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
      FUNCTION GEN084 (X, N)
      DIMENSION X(3, 3, *)
      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
      SUBROUTINE GEN085 (WORD, L, K)
      CHARACTER WORD*(*)
      K = 0
      DO 10 I = 1, L
        IF (WORD(I:I) .LE. ' ' .OR. WORD(I:I) .GT. '~') GOTO 10
        K = K + 1
        WORD(K:K) = WORD(I:I)
   10 CONTINUE
      N = K + 1
      CALL GEN038 (WORD, N, L)
      RETURN
      END
      FUNCTION GEN086 (A, B, C, M, N)
      DIMENSION A(3, 3, *), B(3, 3, *)
      GEN086 = 0.0
      DO 20 I = 1, 3
        DO 10 J = 1, 3
          IF (ABS(A(I, J, M) - B(I, J, N)) .GT. C) GOTO 30
   10   CONTINUE
   20 CONTINUE
      GEN086 = 1.0
   30 RETURN
      END
      SUBROUTINE GEN087 (LINE, B, C, IA, NB)
      CHARACTER LINE*(*)
      CHARACTER CAR*23, CARA*23
      DIMENSION B(3, 3, *), C(3, *)
      CAR = '1234567890 /,+-xyz[]XYZ'
      IF (NB .EQ. 1) THEN
        GOTO 10
      ELSE IF (NB .EQ. 2) THEN
        GOTO 500
      ENDIF
   10 MCM = 1
      LR  = LEN(LINE)
      CALL GEN085 (LINE, LR, KM)
      K = 1
      COST = 1.0
      DO 16 I = 1, 3
        C(I, IA) = 0.0
        DO 15 J = 1, 3
          B(I, J, IA) = 0.0
   15   CONTINUE
   16 CONTINUE
      DO 200 I = 1, KM
        CARA = LINE(I:I)
        DO 20 J = 1, 23
          IF (CAR(J:J) .EQ. CARA) GOTO 30
   20   CONTINUE
        RETURN
   30   IF (J .EQ. 11) THEN
          GOTO 200
        ELSE IF (J .GT. 11) THEN
          GOTO 100
        ENDIF
        IF (J .EQ. 10) J = 0
        IF (MCM .EQ. 1) THEN
          IF (C(K, IA) .NE. 0.0) C(K, IA) = C(K, IA) * 10
          C(K, IA) = C(K, IA) + COST * J
          COST = 1.0
        ELSE IF (MCM .EQ. 2) THEN
          C(K, IA) = C(K, IA) / J
          MCM = 1
        ENDIF
        GOTO 200
  100   IF (J .GT. 20) J = J - 5
        J = J - 11
        IF (J .EQ. 1) THEN
          MCM = 2
        ELSE IF (J .EQ. 2) THEN
          K = K + 1
        ELSE IF (J .EQ. 3) THEN
          COST = 1.0
        ELSE IF (J .EQ. 4) THEN
          COST = -1.0
        ELSE IF (J .EQ. 5) THEN
          B(K, 1, IA) = COST
          COST = 1.0
        ELSE IF (J .EQ. 6) THEN
          B(K, 2, IA) = COST
          COST = 1.0
        ELSE IF (J .EQ. 7) THEN
          B(K, 3, IA) = COST
          COST = 1.0
        ELSE IF (J .EQ. 8) THEN
        ELSE IF (J .EQ. 9) THEN
          GOTO 210
        ENDIF
  200 CONTINUE
  210 RETURN
  500 KM = LEN(LINE)
      DO 510 I = 1, KM
        LINE(I:I) = CAR(11:11)
  510 CONTINUE
      LINE(12:12) = ','
      LINE(23:23) = ','
      DO 1000 I = 1, 3
        MCM = 11 * I
        DO 600 J = 1, 3
          L = 4 - J
          IF (NINT(B(I, L, IA)) .EQ. 0) GOTO 600
          MA = L + 15
          LINE(MCM:MCM) = CAR(MA:MA)
          K = 14
          IF (B(I, L, IA) .LT. -0.1) K = 15
          MCM = MCM - 1
          LINE(MCM:MCM) = CAR(K:K)
          MCM = MCM - 1
  600   CONTINUE
        MS = 11
        IF (ABS(C(I, IA)) .LT. 0.1) GOTO 1000
        IF (C(I, IA) .LT. 0.0) MS = 15
        DO 700 J = 1, 6
          CA = C(I, IA) * J
          K = NINT(CA)
          IF (ABS(FLOAT(K) - CA) .LT. 0.1) GOTO 800
  700   CONTINUE
  800   IF (J .EQ. 1) GOTO 900
        LINE(MCM:MCM) = CAR(J:J)
        MCM = MCM - 1
        LINE(MCM:MCM) = CAR(12:12)
        MCM = MCM - 1
  900   J = IABS(MOD(K, 10))
        LINE(MCM:MCM) = CAR(J:J)
        K = K / 10
        MCM = MCM - 1
        IF (K .GT. 0) GOTO 900
        LINE(MCM:MCM) = CAR(MS:MS)
 1000 CONTINUE
      KM1 = KM - 1
      CALL GEN085 (LINE(2:KM), KM1, K)
      IF (LINE(2:2) .EQ. '+') LINE(2:2) = ' '
      DO 1010 I = 1, 2
        K = INDEX(LINE, ',+')
        K1 = K + 1
        IF (K .NE. 0) LINE(K1:K1) = ' '
 1010 CONTINUE
      CALL GEN085 (LINE(2:KM), KM1, K)
      RETURN
      END
      SUBROUTINE GEN088 (A, I, M, MSIGN, INVERS)
      DIMENSION A(3, 3, *), B(3, 3), C(3, 3, 2)
      CALL GEN074 (C, 0.0, 1, 18)
      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 10 M = 1, 16
        IF (GEN086 (C, B, 1.E-2, 2, 1) .NE. 0.0) INVERS = 1
        IF (GEN086 (C, B, 1.E-2, 1, 1) .NE. 0.0) GOTO 20
        CALL GEN077  (A, B, B, I, 1, 1)
   10 CONTINUE
   20 IF (M .LT. 6 .OR. MSIGN .EQ. 1) RETURN
      M1 = (M / 4) * 4
      IF (M1 .NE. M) M = M / INVERS
      RETURN
      END
      SUBROUTINE GEN089 (LUA, LUB, NPAG, NLM)
      CHARACTER NULL*1, ICH*1, PRBUF*132, PSBUF*250
      NULL = CHAR(0)
      WRITE (LUB, 99999) NPAG
      WRITE (LUB, 99998)
      NB = 1
      NE = 132
      NP = 0
      NL = NLM
   10 READ (LUA, 99995, END = 30) PRBUF
      IF (PRBUF(1:1) .EQ. CHAR(12)) THEN
        BACKSPACE LUA
        READ (LUA, 99994, END = 10) PRBUF
        NP = NP + 1
        IF (NP .GT. 1) WRITE (LUB, 99996)
        WRITE (LUB, 99997) NP, NP
        NL = 0
      ENDIF
      NL = NL + 1
      IF (NL .GE. NLM) THEN
        NP = NP + 1
        IF (NP .GT. 1) WRITE (LUB, 99996)
        WRITE (LUB, 99997) NP, NP
        NL = 1
      ENDIF
      N = 0
      CALL GEN039 (1, PRBUF, 1, 132, NB, NE)
      DO 20 I = 1, NE
        ICH = PRBUF(I:I)
        IF (ICH .NE. NULL) THEN
          IF (ICH .EQ. '(' .OR. ICH .EQ. ')') THEN
            N = N + 1
            PSBUF(N:N) = CHAR(92)
          ENDIF
          N = N + 1
          PSBUF(N:N) = ICH
        ENDIF
   20 CONTINUE
      WRITE (LUB, 99993) PSBUF(1:N)
      GOTO 10
   30 WRITE (LUB, 99992)
      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  'sp', /,
     8  'bp')
99997 FORMAT ('%%Page:', 2I7)
99996 FORMAT ('np')
99995 FORMAT (A)
99994 FORMAT (1X, A)
99993 FORMAT ('(', A, ')s')
99992 FORMAT ('np', /, '%%EOF')
      END
      INTEGER FUNCTION GEN090 (I, J)
      I0 = 0
      I1 = I
      I2 = J
      I3 = 1
      N  = 1
   10 IF (MOD(I1, 2) .EQ. 1 .AND. MOD(I2, 2) .EQ. 1) I0 = I0 + I3
      IF (N .LT. 15) THEN
        N  = N  + 1
        I1 = I1 / 2
        I2 = I2 / 2
        I3 = I3 * 2
        GOTO 10
      ENDIF
      GEN090 = I0
      RETURN
      END
      SUBROUTINE GEN091 (X, T, KUSER, KUSR, NATO, NAT, ITEM)
      DIMENSION X(KUSER, KUSR), T(KUSR)
      IF (NAT .GT. 1) THEN
        INT  = 2
   10   INT  = 2 * INT
        IF (INT .LT. NAT) GOTO 10
        INT  = MIN0(NAT, (3 * INT) / 4 - 1)
   20   INT  = INT / 2
        IFIN = NAT - INT
        DO 70 II = 1, IFIN
          I = II
          J = I + INT
          IF (X(NATO + I, ITEM) .LT. X(NATO + J, ITEM)) THEN
            DO 30 K = 1, KUSR
              T(K) = X(NATO + J, K)
   30       CONTINUE
   40       DO 50 K = 1, KUSR
              X(NATO + J, K) = X(NATO + I, K)
   50       CONTINUE
            J = I
            I = I - INT
            IF (I .GT. 0) THEN
              IF (X(NATO + I, ITEM) .LT. T(ITEM)) GOTO 40
            ENDIF
            DO 60 K = 1, KUSR
              X(NATO + J, K) = T(K)
   60       CONTINUE
          ENDIF
   70   CONTINUE
        IF (INT .NE. 1) GOTO 20
      ENDIF
      RETURN
      END
      SUBROUTINE GEN092 (MODL, H, TM, NUM)
      DIMENSION H(3), TM(3, 3)
      NUM = 0
      DO 20 J = 1, 3
        DM = 0.0
        DO 10 I = 1, 3
          DM = DM + H(I) * TM(I, J)
   10   CONTINUE
        NUM = NUM + MOD(NINT(ABS(DM)), MODL)
   20 CONTINUE
      RETURN
      END
      SUBROUTINE GEN093 (IDOF, CSQ, IP)
      DIMENSION P95(20), P5(20)
      CHARACTER IP*4
      DATA 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/
      DATA 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/
      IP = '    '
      IF (IDOF .LE. 20 .AND. IDOF .GT. 0) THEN
        IF (CSQ .LE. P95(IDOF)) IP = 'P>95'
        IF (CSQ .GT. P5(IDOF))  IP = 'P<5 '
      ENDIF
      RETURN
      END
      SUBROUTINE GEN094 (X, V, IDEV, IDUM)
      DIMENSION X(3, 3), V(3)
      IDUM = 0
      DO 20 J = 1, 3
        DM = 0.0
        DO 10 I = 1, 3
          DM = DM + X(I, J) * V(I)
   10   CONTINUE
        IDUM = IDUM + MOD(NINT(ABS(DM)), IDEV)
   20 CONTINUE
      RETURN
      END
      FUNCTION GEN095 (P, IH, IK, IL)
      DIMENSION P(6)
      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
      SUBROUTINE GEN096 (T, IROTX, IROTY, IROTZ, IDET, U, PHI, ROM)
      DIMENSION T(3, 3), U(3), V(3), Z(15), ROM(3, 3)
      CALL GEN010 (T, IDET, 0)
      RTD = 0.0
      AL  = 0.0
      BE  = 0.0
      GA  = 0.0
      IF (IDET .NE. 0) THEN
        CALL GEN010 (T, IDET, -1)
        RTD = 45.0 / ATAN(1.0)
        IF (ABS(T(1, 1)) + ABS(T(2, 1)) .LT. 0.00001)  GOTO 10
        GA = ATAN2(T(2, 1), T(1, 1))
   10   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) .LT. 0.00001)  GOTO 20
        BE = ATAN2(-T(3, 1), T11A)
   20   T32A = SIN(BE) * T12A + COS(BE) * T(3, 2)
        IF (ABS(T32A) + ABS(T22A) .LT. 0.00001)  GOTO 30
        AL = ATAN2(T32A, T22A)
   30   DO 40 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
   40   CONTINUE
        IF (ABS(Z(8)) .GT. 0.9999) THEN
          Z(13) = 1.0
        ELSE
          Z(14) = 1.0
        ENDIF
        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)
        XNORM = MAX(ABS(U(1)), ABS(U(2)), ABS(U(3)))
        IF (XNORM .NE. 0) THEN
          DO 50 I = 1, 3
            U(I) = U(I) / XNORM
   50     CONTINUE
        ENDIF
        CALL GEN010 (T, IDET, -1)
      ENDIF
      IROTX = - NINT(AL * RTD)
      IROTY = - NINT(BE * RTD)
      IROTZ = - NINT(GA * RTD)
      RETURN
      END
      SUBROUTINE GEN097 (IA, N1, N2, IVALUE)
      DIMENSION IA(*)
      DO 10 I = N1, N2
        IA(I) = IVALUE
   10 CONTINUE
      RETURN
      END
      SUBROUTINE GEN098 (M, X, N, ITX, ITY, ITZ, IRES)
      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 GEN099 (A, B, C)
      DIMENSION A(3, 3), B(3), C(3, 3)
      DO 30 I = 1, 3
        DO 20 J = 1, 3
          C(I, J) = 0.0
          DO 10 K = 1, 3
            C(I, J) = C(I, J) + A(I, K) * A(J, K) * B(K)
   10     CONTINUE
   20   CONTINUE
   30 CONTINUE
      RETURN
      END
      SUBROUTINE GEN100 (AO, J, X, Y, Z)
      DIMENSION AO(20)
      CALL GEN074 (AO, 0.0, 1, 20)
      IF (J .EQ. 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 .EQ. 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 .EQ. 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 .EQ. 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 .EQ. 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 .EQ. 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
      ENDIF
      RETURN
      END
      SUBROUTINE GEN101 (M, N, DHX)
      DIMENSION DHX(3, *)
      N  = 3
      I  = -1
   10 IF (I .LT. M) THEN
        I  = I + 1
        I1 = MOD(I, 2)
        I3 = MOD(I, 3)
        I4 = MOD(I, 5)
        I5 = MOD(I, 7)
        J  = -M -1
   20   J  = J + 1
        IF (J .GT. M) GOTO 10
        J1 = MOD(J, 2)
        J3 = MOD(J, 3)
        J4 = MOD(J, 5)
        J5 = MOD(J, 7)
        K  = -M -1
   30   K  = K + 1
        IF (K .GT. M) GOTO 20
        K1 = MOD(K, 2)
        K3 = MOD(K, 3)
        K4 = MOD(K, 5)
        K5 = MOD(K, 7)
        IF (I * J * K .EQ. 0) THEN
          IF (ABS(I1) + ABS(J1) + ABS(K1) .EQ. 0) GOTO 30
          IF (ABS(I3) + ABS(J3) + ABS(K3) .EQ. 0) GOTO 30
          IF (ABS(I4) + ABS(J4) + ABS(K4) .EQ. 0) GOTO 30
          IF (ABS(I5) + ABS(J5) + ABS(K5) .EQ. 0) GOTO 30
          IF (I .LT. 0) THEN
            GOTO 30
          ELSE IF (I .EQ. 0) THEN
            IF (J .LT. 0) THEN
              GOTO 30
            ELSE IF (J .EQ. 0) THEN
              IF (K .LT. 0) GOTO 30
            ENDIF
          ENDIF
        ELSE
          IF (ABS(I1) + ABS(J1) .EQ. 0) GOTO 30
          IF (ABS(I1) + ABS(K1) .EQ. 0) GOTO 30
          IF (ABS(J1) + ABS(K1) .EQ. 0) GOTO 30
          IF (ABS(I3) + ABS(J3) .EQ. 0) GOTO 30
          IF (ABS(I3) + ABS(K3) .EQ. 0) GOTO 30
          IF (ABS(J3) + ABS(K3) .EQ. 0) GOTO 30
          IF (ABS(I4) + ABS(J4) .EQ. 0) GOTO 30
          IF (ABS(I4) + ABS(K4) .EQ. 0) GOTO 30
          IF (ABS(J4) + ABS(K4) .EQ. 0) GOTO 30
          IF (ABS(I5) + ABS(J5) .EQ. 0) GOTO 30
          IF (ABS(I5) + ABS(K5) .EQ. 0) GOTO 30
          IF (ABS(J5) + ABS(K5) .EQ. 0) GOTO 30
        ENDIF
        IJK = I * 10000 + J * 100 + K
        IF (IJK .EQ. 10000) THEN
          NN = 1
        ELSE IF (IJK .EQ. 100) THEN
          NN = 2
        ELSE IF (IJK .EQ. 1) THEN
          NN = 3
        ELSE
          N  = N + 1
          NN = N
        ENDIF
        DHX(1, NN) = I
        DHX(2, NN) = J
        DHX(3, NN) = K
        GOTO 30
      ENDIF
      RETURN
      END
      SUBROUTINE GEN102 (IS, IFL, SWS, NM)
      CHARACTER SWS(*)*4, IFL*7
      IS = 1
      DO 10 N = 1, NM
        IF (IFL(1:4) .EQ. SWS(N)(1:4)) THEN
          IS = N + 1
          GOTO 20
        ENDIF
   10 CONTINUE
   20 RETURN
      END
      SUBROUTINE GEN103 (LINE, N)
      CHARACTER LINE*(*), ICH*1
      M   = 0
      NBL = 1
      DO 10 I = 1, N
        ICH = LINE(I:I)
        IF (ICH .EQ. ' ') THEN
          NBL = NBL + 1
          IF (NBL .EQ. 1) THEN
            M = M + 1
            LINE(M:M) = ICH
          ELSE
            GOTO 10
          ENDIF
        ELSE
          M   = M + 1
          NBL = 0
          LINE(M:M) = ICH
        ENDIF
   10 CONTINUE
      CALL GEN038 (LINE, M, N)
      RETURN
      END
      BLOCKDATA GENRL
      COMMON /G104/ IT(30, 9)
      DATA ((IT (I, J), J = 1, 9), I = 1, 11) /
     1  211, 101, 110, 0, 1, 1, 0, 0, 1,
     2   11, 121, 110, 1, 1, 1, 0, 0, 1,
     3   11, 101, 112, 0, 1, 1, 0, 0, 1,
     4  121, 211, 110, 0, 0, 1, 0, 0, 1,
     5  112, 101, 211, 0, 0, 0, 0, 0, 1,
     6   11, 112, 121, 0, 0, 0, 0, 0, 1,
     7  101,  11, 110, 0, 0, 1, 0, 0, 1,
     8  110, 101,  11, 0, 0, 0, 0, 0, 1,
     9   11, 110, 101, 0, 0, 0, 0, 0, 1,
     *  221, 101, 110, 0, 0, 0, 0, 1, 0,
     1   11, 221, 110, 0, 0, 0, 0, 1, 0/
      DATA ((IT (I, J), J = 1, 9), I = 12, 21) /
     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/
      DATA ((IT (I, J), J = 1, 9), I = 22, 27) /
     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/
      DATA ((IT (I, J), J = 1, 9), I = 28, 30) /
     1  221,  11, 112, 0, 0, 0, 0, 1, 0,
     2  011, 101, 112, 0, 0, 0, 0, 1, 0,
     3  101, 221, 112, 0, 0, 0, 0, 1, 0/
      END
      SUBROUTINE GEN104 (LAT, C)
      COMMON /G104/ IT(30, 9)
      DIMENSION A(3, 3), B(3, 3), C(3, 3), E(3, 3)
      CALL GEN021 (A, 1)
      CALL GEN004 (A, C, B)
      CALL GEN003 (C, E, DET, 0)
      IF (ABS(DET - 1.0) .LT. 0.001 .AND. LAT .GT. 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 10 I = 1, 30
          IF (IT (I, LAT + 2) .NE. 0) THEN
            IF (N1 .EQ. IT(I, 1) .AND. N2 .EQ. IT(I, 2) .AND.
     1          N3 .EQ. IT(I, 3)) THEN
              CALL GEN004 (E, A, A)
              CALL GEN004 (A, B, C)
              GOTO 20
            ENDIF
          ENDIF
   10   CONTINUE
      ENDIF
   20 RETURN
      END
      SUBROUTINE GEN105 (MODE, ICH, N)
      CHARACTER ICH*1
      N = - 1
      IF (MODE .EQ. 1) THEN
        DO 10 I = ICHAR('A'), ICHAR('Z')
          IF (ICH .EQ. CHAR(I)) THEN
            N = I
            GOTO 100
          ENDIF
   10   CONTINUE
      ELSE IF (MODE .EQ. 2) THEN
        DO 20 I = ICHAR('a'), ICHAR('z')
          IF (ICH .EQ. CHAR(I)) THEN
            N = I
            GOTO 100
          ENDIF
   20   CONTINUE
      ELSE IF (MODE .EQ. 3) THEN
        DO 30 I = 1, 10
          IF (ICH .EQ. CHAR(ICHAR('0') - 1 + I)) THEN
            N = I
            GOTO 100
          ENDIF
   30   CONTINUE
      ENDIF
  100 RETURN
      END
      SUBROUTINE GEN106 (V, STH, PSI, AA, BB, V6, V8, PAR)
      DIMENSION V(3), V1(3), V2(3), V3(3), V4(3), V6(3), V8(3),
     1  AA(3, 3), BB(3, 3), PAR(6)
      CTH = SQRT(1.0 - STH**2)
      CALL GEN002 (-1, BB, V, V6, XLNG)
      CALL GEN007 (AA, V6, V1, -1)
      IF (V(1) .EQ. V(2) .AND. V(2) .EQ. 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)
      ENDIF
      CALL GEN007 (AA, V6, V2, -1)
      CALL GEN008 (V1, V2, V6, 0)
      CALL GEN002 (-1, BB, V6, V8, XLNG)
      CALL GEN007 (AA, V8, V3, -1)
      DO 10 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)
   10 CONTINUE
      RETURN
      END
      SUBROUTINE GEN107 (IA, N, M)
      DIMENSION IA(*)
      M  = 1
      MN = 99999
      DO 10 I = 1, N
        IF (IA(I) .GT. 0) MN = MIN (MN, IA(I))
   10 CONTINUE
      DO 40 I = 1, MN
        M = MN + 1 - I
        DO 20 J = 1, N
          IF (MOD (IA(J), M) .NE. 0) GOTO 40
   20   CONTINUE
        DO 30 J = 1, N
          IA(J) = IA(J) / M
   30   CONTINUE
        GOTO 50
   40 CONTINUE
   50 RETURN
      END
      SUBROUTINE GEN108 (LU, MODE)
      IF (MODE .NE. 0) ENDFILE (LU, ERR = 20)
      REWIND (LU, ERR = 10)
      RETURN
   10 WRITE (6, 99999) LU
      RETURN
   20 WRITE (6, 99998) LU
      RETURN
99999 FORMAT ('W: REWIND  PROBLEM FOR UNIT ', I5)
99998 FORMAT ('W: ENDFILE PROBLEM FOR UNIT ', I5)
      END
      SUBROUTINE GEN109 (M, N, X, Y, Z, F, NP)
      DOUBLE PRECISION F(81)
      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
      IF (N .GE. 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 .GE. 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 .GE. 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 .GE. 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)
            ENDIF
          ENDIF
        ENDIF
      ENDIF
      IF (M .GE. 1) THEN
        NP        = NP + 3
        F(NP - 2) = Z
        F(NP - 1) = X
        F(NP)     = Y
        IF (M .GE. 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 .GE. 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 .GE. 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)
            ENDIF
          ENDIF
        ENDIF
      ENDIF
      RETURN
      END
      SUBROUTINE GEN110 (NP, NN, C, B)
      DOUBLE PRECISION C(NP), B(NN), DT
      M = 0
      I = 0
      DO 40 N = 1, NP
        I = I + 1
        L = I
        M = 1
        J = 1
  10    IF (J .EQ. I) GOTO 30
        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 20 K = L, NI
          DT = DT - B(J) * B(K)
          J  = J  + 1
  20    CONTINUE
        B(I) = DT
        GOTO 10
  30    B(I) = 1.0 / DSQRT(B(I))
        C(N) = C(N) * B(I)
  40  CONTINUE
      DT   = C(M)
  50  C(M) = DT * B(I)
      I    = I - M
      M    = M - 1
      IF (M .LT. 1) GOTO 70
      DT   = C(M)
      K    = I + M
      DO 60 N = M + 1, NP
        DT = DT - C(N) * B(K)
        K  = K  + N
  60  CONTINUE
      GOTO 50
  70  RETURN
      END
      SUBROUTINE GEN111 (A, B, N, M)
      CHARACTER A*(*), B*2
      B = ' '
      M = 0
      L = 0
      DO 20 J = 1, N
        DO 10 K = 48, 122
          IF (A(J:J) .EQ. CHAR(K)) THEN
            IF (K .LT. 58) THEN
              M = M * 10 + K - 48
              GOTO 20
            ELSE IF (K .GT. 64) THEN
              IF (L .LT. 2) THEN
                IF (K .GT. 96) THEN
                  KMOVE = 32
                ELSE
                  KMOVE = 0
                ENDIF
                L = L + 1
                B(L:L) = CHAR(K - KMOVE)
              ENDIF
            ENDIF
          ENDIF
  10    CONTINUE
  20  CONTINUE
      RETURN
      END
      SUBROUTINE GEN112 (A, B, MODE)
      DIMENSION A(3, 3), B(*)
      IF (MODE .GT. 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)
      ENDIF
      RETURN
      END
      SUBROUTINE GEN115 (X, W, N)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      REAL X(*), W(*)
      M  = (N + 1) / 2
      XM = 0.5D0
      XL = 0.5D0
      DO 30 I = 1, M
        Z = COS(3.141592654D0 * (I - 0.25D0) / (N + 0.5D0))
   10   CONTINUE
          P1 = 1.D0
          P2 = 0.D0
          DO 20 J = 1, N
            P3 = P2
            P2 = P1
            P1 = ((2.0D0 * J - 1.0D0) * Z * P2 - (J - 1.0D0) * P3) / J
   20     CONTINUE
          PP = N * (Z * P1 - P2) / (Z * Z - 1.0D0)
          Z1 = Z
          Z  = Z1 - P1 / PP
        IF (ABS(Z - Z1) .GT. 3.0D-14) GOTO 10
        X(I) = XM - XL * Z
        X(N + 1 - I) = XM + XL * Z
        W(I) = 2.D0 * XL / ((1.0D0 - Z * Z) * PP * PP)
        W(N + 1 - I) = W(I)
   30 CONTINUE
      RETURN
      END
      SUBROUTINE GEN116 (P, PPF)
      DATA P0, P1, P2, P3, P4/ -0.322232431088, -1.0, -0.342242088547,
     1 -0.204231210245E-1, -0.453642210148E-4/
      DATA Q0, Q1, Q2, Q3, Q4/ 0.993484626060E-1, 0.588581570495,
     1 0.531103462366, 0.103537752850, 0.38560700634E-2/
      IF (P .EQ. 0.5) THEN
        PPF = 0.0
      ELSE
        R = P
        IF (P .GT. 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 .LT. 0.5) PPF = -PPF
      ENDIF
      RETURN
      END
      SUBROUTINE GEN117 (N, X)
      DIMENSION X(1)
      X(N) = 0.5 ** (1.0 / FLOAT(N))
      X(1) = 1.0 - X(N)
      NHALF  = (N / 2) + 1
      NEVODD = 2 * (N / 2)
      IF (N .NE. NEVODD) X(NHALF) = 0.5
      IF (N .GT. 3) THEN
        GAM  = 0.3175
        IMAX = N / 2
        DO 10 I = 2, IMAX
          AI   = I
          IREV = N - I + 1
          X(I) = (AI - GAM) / (FLOAT(N) - 2.0 * GAM + 1.0)
          X(IREV) = 1.0 - X(I)
   10   CONTINUE
      ENDIF
      RETURN
      END
      SUBROUTINE GEN118 (MODE, Y, X, N, LU)
      COMMON /NPPLOT/ YCC, YINT, YSLOPE
      CHARACTER IGRAPH(43)*109
      DIMENSION X(1), Y(1)
      DIMENSION YLABLE(11)
      CUTOFF = (10.0**10) - 1000.0
      YMIN = 0.0
      YMAX = 0.0
      HOLD = Y(1)
      DO 10 I = 2, N
        IF (Y(I) .NE. HOLD) GOTO 20
   10 CONTINUE
      RETURN
   20 HOLD = X(1)
      DO 30 I = 2, N
        IF (X(I) .NE. HOLD) GOTO 40
   30 CONTINUE
      RETURN
   40 DO 50 I = 1, N
        IF (Y(I) .LT. CUTOFF) GOTO 60
   50 CONTINUE
      RETURN
   60 DO 70 I = 1, N
        IF (X(I) .LT. CUTOFF) GOTO 80
   70 CONTINUE
      RETURN
   80 N2 = 0
      DO 90 I = 1, N
        IF (Y(I) .LT. CUTOFF .AND. X(I) .LT. CUTOFF) THEN
          N2 = N2 + 1
          IF (N2 .GE. 2) GOTO 100
        ENDIF
   90 CONTINUE
      RETURN
  100 DO 110 I = 1, N
        IF (Y(I) .GE. CUTOFF) GOTO 110
        IF (X(I) .GE. CUTOFF) GOTO 110
        YMIN = Y(I)
        YMAX = Y(I)
        GOTO 120
  110 CONTINUE
  120 DO 130 I = 1, N
        IF (Y(I) .GE. CUTOFF) GOTO 130
        IF (X(I) .GE. CUTOFF) GOTO 130
        IF (Y(I) .LT. YMIN)   YMIN = Y(I)
        IF (Y(I) .GT. YMAX)   YMAX = Y(I)
  130 CONTINUE
      IF (MODE .EQ. 1) YMIN = 0.0
      DO 140 I = 1, 9
        AIM1 = I - 1
        YLABLE(I) = YMAX - (AIM1 / 8.0) * (YMAX - YMIN)
  140 CONTINUE
      DO 150 I = 1, N
        IF (Y(I) .GE. CUTOFF) GOTO 150
        IF (X(I) .GE. CUTOFF) GOTO 150
        XMIN = X(I)
        XMAX = X(I)
        GOTO 160
  150 CONTINUE
  160 DO 170 I = 1, N
        IF (Y(I) .GE. CUTOFF) GOTO 170
        IF (X(I) .GE. CUTOFF) GOTO 170
        IF (X(I) .LT. XMIN)   XMIN = X(I)
        IF (X(I) .GT. XMAX)   XMAX = X(I)
  170 CONTINUE
      XMID = (XMIN + XMAX) / 2.0
      X25  = 0.75 * XMIN + 0.25 * XMAX
      X75  = 0.25 * XMIN + 0.75 * XMAX
      DO 180 I = 1, 43
        IGRAPH(I) = ' '
  180 CONTINUE
      DO 190 I = 2, 42
        IGRAPH(I)(5:5)     = 'I'
        IGRAPH(I)(109:109) = 'I'
  190 CONTINUE
      DO 200 I = 2, 42, 5
        IGRAPH(I)(5:5)     = '-'
        IGRAPH(I)(109:109) = '-'
  200 CONTINUE
      IGRAPH(2)(1:4)  = '=Max'
      IGRAPH(22)(1:4) = '=Mid'
      IGRAPH(42)(1:4) = '=Min'
      IF (MODE .EQ. 1) THEN
        IGRAPH(3)(7:34) = 'Half-Normal Probability Plot'
      ELSE IF (MODE .EQ. 2) THEN
        IGRAPH(3)(7:29) = 'Normal Probability Plot'
      ENDIF
      SUM1 = 0.0
      SUM2 = 0.0
      WBAR = 0.0
      DO 210 I = 1, N
        SUM1 = SUM1 + Y(I)
        IF (MODE .EQ. 1) SUM2 = SUM2 + X(I)
  210 CONTINUE
      YBAR = SUM1 / FLOAT(N)
      IF (MODE .EQ. 1) WBAR = SUM2 / FLOAT(N)
      SUM1 = 0.0
      SUM2 = 0.0
      SUM3 = 0.0
      DO 220 I = 1, N
        IF (MODE .EQ. 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 .EQ. 2) THEN
          SUM1 = SUM1 + (Y(I) - YBAR) * (Y(I) - YBAR)
          SUM2 = SUM2 + X(I) * Y(I)
          SUM3 = SUM3 + X(I) * X(I)
        ENDIF
  220 CONTINUE
      YCC    = SUM2 / SQRT(SUM3 * SUM1)
      YSLOPE = SUM2 / SUM3
      YINT   = YBAR - YSLOPE * WBAR
      WRITE (IGRAPH(5)(7:32), 99996) N
      WRITE (IGRAPH(6)(7:32), 99995) YCC
      WRITE (IGRAPH(7)(7:32), 99994) YINT
      WRITE (IGRAPH(8)(7:32), 99993) YSLOPE
      DO 230 J = 7, 107
        IGRAPH(1)(J:J)  = '-'
        IGRAPH(43)(J:J) = '-'
  230 CONTINUE
      DO 240 J = 7, 107, 25
        IGRAPH(1)(J:J)  = 'I'
        IGRAPH(43)(J:J) = 'I'
  240 CONTINUE
      DO 250 J = 20, 107, 25
        IGRAPH(1)(J:J)  = 'I'
        IGRAPH(43)(J:J) = 'I'
  250 CONTINUE
      RATIOY =  40.0 / (YMAX - YMIN)
      RATIOX = 100.0 / (XMAX - XMIN)
      DO 260 I = 1, N
        IF (Y(I) .GE. CUTOFF) GOTO 260
        IF (X(I) .GE. CUTOFF) GOTO 260
        MX = RATIOX * (X(I) - XMIN) + 0.5
        MX = MX + 7
        MY = RATIOY * (Y(I) - YMIN) + 0.5
        MY = 42 - MY
        IGRAPH(MY)(MX:MX) = 'x'
  260 CONTINUE
      DO 270 I = 1, 43
        IM2   = I - 2
        IFLAG = IM2 - (IM2 / 5) * 5
        K     = IM2 / 5 + 1
        IF (IFLAG .NE. 0) THEN
          WRITE (LU, 99999) IGRAPH(I)
        ELSE
          WRITE (LU, 99998) YLABLE(K), IGRAPH(I)
        ENDIF
  270 CONTINUE
      WRITE (LU, 99997) XMIN, X25, XMID, X75, XMAX
      RETURN
99999 FORMAT (15X, A)
99998 FORMAT (F15.3, A)
99997 FORMAT (5(9X, F16.3))
99996 FORMAT ('Sample Size    =', I10)
99995 FORMAT ('CC             =', F10.4)
99994 FORMAT ('Est. Intersept =', F10.4)
99993 FORMAT ('Est. Slope     =', F10.4)
      END
      FUNCTION GEN119 (A)
      DIMENSION A(3, 3)
      GEN119 =
     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 GEN120 (A)
      DIMENSION A(3, 3)
      GEN120 = 0.0
      DO 20 I = 1, 3
        DO 10 J = 1, 3
          IF (I .EQ. J) THEN
            IF (NINT(A(I, J)) .NE. 1) GOTO 30
          ELSE
            IF (NINT(A(I, J)) .NE. 0) GOTO 30
          ENDIF
   10   CONTINUE
   20 CONTINUE
      GEN120 = 1.0
   30 RETURN
      END
      SUBROUTINE GEN121 (NQ)
      CHARACTER NQ*7, NQ1*9
      NQ1 = NQ
      N1  = INDEX (NQ1, '(')
      N2  = INDEX (NQ1, ')')
      IF (N1 .NE. 0 .AND. N2 .NE. 0) THEN
        NQ = NQ1(1:N1 -1)//NQ1(N1+1:N2-1)//NQ1(N2+1:9)
      ENDIF
      RETURN
      END
      SUBROUTINE GEN122 (AXES, NS, ITEL)
      DIMENSION AXES(15, 23)
   10 ICHANGE = 0
      DO 30 J = 1, (ITEL - 1)
        IF (AXES(J, NS) .GT. AXES(J + 1, NS)) THEN
          DO 20 I = 1, 13
            CALL GEN018 (AXES(J, I), AXES(J + 1, I))
   20     CONTINUE
          CALL GEN018 (AXES(J, 23), AXES(J + 1, 23))
          ICHANGE = 1
        ENDIF
   30 CONTINUE
      IF (ICHANGE .NE. 0) GOTO 10
      RETURN
      END
      SUBROUTINE GEN123 (MODE, IEN, IENS, IEL, IAN)
      DIMENSION IEN(*), IENS(*), IEL(*)
      DO 10 I = 1, IAN
        IENI = IEN(I)
        IF (MODE .EQ. 1) THEN
          IF (IENI .EQ. 2) THEN
            IVAL = 0
          ELSE IF (IENI .EQ. 1) THEN
            IVAL = 1
          ELSE IF (IENI .EQ. 33) THEN
            IVAL = 2
          ELSE
            IVAL = IEL(IENI)
          ENDIF
        ELSE
          IVAL = IEL(IENI)
        ENDIF
        IENS(I) = IVAL * 100 + I
   10 CONTINUE
      CALL GEN022 (IENS, 1, IAN)
      DO 20 I = 1, IAN
        IENS(I) = MOD(IENS(I), 100)
   20 CONTINUE
      RETURN
      END
      SUBROUTINE GEN124 (NA, NB, NE)
      DIMENSION NA(*)
      NEL = (NE - NB + 1) / 2
      IF (NEL .LE. 1) GOTO 50
      ND = 2**(INT((ALOG(FLOAT(NEL)) / ALOG(2.0)) + 1.0E-5)) - 1
   10 IF (ND .LE. 0) GOTO 50
      NDS = ND + ND
      I   = NB
   20 J   = I
      NY = NA(I + NDS)
      NZ = NA(I + NDS + 1)
   30 IF (NY .GE. NA(J)) GOTO 40
      NA(J + NDS)     = NA(J)
      NA(J + NDS + 1) = NA(J + 1)
      J = J - NDS
      IF (J .GE. NB) GOTO 30
   40 NA(J + NDS)     = NY
      NA(J + NDS + 1) = NZ
      I = I + 2
      IF (I + NDS .LE. NE) GOTO 20
      ND = (ND - 1) / 2
      GOTO 10
   50 RETURN
      END
      SUBROUTINE GEN125 (U, T)
      DIMENSION U(9), T(9)
      DO 10 I = 1, 9
        T(I) = U(I)
   10 CONTINUE
      RETURN
      END
      SUBROUTINE GEN126 (C, N, M)
      CHARACTER*(*)  C(*)
      DO 10 I = N, M
        C(I) = ' '
   10 CONTINUE
      RETURN
      END
      SUBROUTINE GGIP (X, Y, Z, IVAL)
C *====================================================================C
C *                 ****    G   G   I   P   ****                       C
C *====================================================================C
C *                    (C) 1980 - 2005  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 27-Apr-2005                          C
C *                                                                    C
C * GRAPHICS DISPLAYS SUPPORTED      (DISPLAY-MODE)   SHORT NAME       C
C *                                                                    C
C *          X-WINDOW                                 - X11            C
C *          TEKTRONIX 4010                           - TEK4010        C
C *                                                                    C
C * GRAPHICS METAFILE CODE              (META-MODE)                    C
C *                                                                    C
C *          POSTSCRIPT                               - PS             C
C *          HPGL - LANGUAGE                          - HPGL           C
C *          TEKTRONIX 4014 CODE                      - TEK4014        C
C *          HPGL/XL                                  - HPXL           C
C *                                                                    C
C * ALL USER CALLS TO A GRAPHICS MEDIUM SHOULD BE DIRECTED THROUGH     C
C * THIS ROUTINE. ESSENTIALLY ONLY THE CALCOMP "CALL PLOT(X, Y, IPEN)" C
C * IS IMPLEMENTED, WHERE X,Y ARE IN CM AND IPEN = +,-2 OR +,-3.       C
C * ALL OTHER CALLS TO GGIP  SET PARAMETERS WITHIN THIS PACKAGE.       C
C * PLOTFILE ON UNIT LU98 (WHEN "META ON") FOR OFF-LINE DISPLAY/HARD-  C
C * COPY.                                                              C
C * ------------------------------------------------------------------ C
C * GENERAL CALL TO GGIP:  GGIP(X, Y, Z, I) , WHERE FOR                C
C *                                                                    C
C * X = -999.0 =====(SET PACKAGE PARAMETERS, HANDLE REQUESTS)==========C
C *   I                                                                C
C *   I --- I =  1 --> GET (0/1) XWINDOW OPEN STATUS                   C
C *   I --- I =  2 --> DISPLAY ON                                      C
C *   I --- I = -2 --> DISPLAY OFF (IMPLICITLY META ON)                C
C *   I --- I =  3 --> META ON  (PERMANENT FOR Z = -1.0)               C
C *   I --- I = -3 --> META OFF (IMPL.DISPLAY/PLOTTER) ON)             C
C *   I --- I =  4 --> LANDSCAPE POSTSCRIPT                            C
C *   I --- I = -4 --> PORTRAIT  POSTSCRIPT                            C
C *   I --- I =  5 --> BEGIN OF PROGRAM INIT  Y >  0: META-FILE  (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 --- I = -5 --> END OF PROGRAM CLOSING PROCEDURES               C
C *   I --- I =  6 --> Y =  1 :X-WINDOW       Z =  0                   C
C *   I                Y =  2 :TEKTRONIX 4010 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                                       Z =  3 :TEK4010          C
C *   I                                       Z =  4 :HPGL/XL          C
C *   I --- I =  6     Y =  0, Z =  0 --> INFORMATION IN COMMON /GGT/  C
C *   I                                   MEDIUM, IGGT(16:22)          C
C *   I --- I =  7 --> GRAPHICS HELP OPTION                            C
C *   I --- I =  8 --> INFO GRAPHICS STATUS   Y =  0 :TEK4010          C
C *   I --- I = -8 --> REPORT DISPLAY PARAMETERS                       C
C *   I                X = X-PIXEL, Y = YPIXEL, Z = DEPTH              C
C *   I                                       Y =  1 :X11              C
C *   I --- I =  9 --> Y =  0, IZ =  FRACTION OF DISPLAY SIZE (/1000)  C
C *                                                                    C
C *   X > -999 AND IABS(I) < 7 ===== (GRAPHICS) =======================C
C *                                                                    C
C *         I =  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 *         I = -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 *                                          Z > 1: GO AFTER Z SECONDS C
C *                                          Z =-1:  ,, + PLOT INTERR. C
C *                                          Z <-1: GO AFTER Z SECONDS C
C *         I =  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 *                                                                    C
C *                                   Y < 0: LINEWIDTH                 C
C *                    (Set Default)  Y = -100 : X-Win MinWidth = 1    C
C *                    (Set Default)  Y = -200 : X-Win MinWidth = 2    C
C *                                                                    C
C *         I =  2 --> DRAW(X, Y, Z)                                   C
C *         I =  3 --> MOVE(X, Y, Z)                                   C
C *         I = -3 --> MOVE TO NEW ORIGIN                              C
C *         I =  4 --> CHARACTER PLOT                                  C
C *         I =  5 --> MOUSE EVENTLOOP                                 C
C *         I =  6 --> Flush Buffer   Z = Seconds Sleep                C
C *         I =  7 --> FACTOR         Y = Multiplication fact X,Y,Z    C
C *         I =  9 --> Interruptloop                                   C
C *                                                                    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
C * THE COMMON GGT HOLDS THE COMMAND LINE ENTERED IN ENDPLT            C
C * ===================================================================C
C *                  GRAPHICS CALLING FRAMEWORK                        C
C *                  ==========================                        C
C *                                                                    C
C *  GENERAL INITIALISATION:                                           C
C *    WITH META-FILE UNIT            CALL GGIP(-999.0, UNIT, 0.0,  5) C
C *  SELECT DISPLAY TYPE (DTYP)                                        C
C *    XWINDOW(=1), TEK4010(=2)       CALL GGIP(-999.0, DTYP, 0.0,  6) C
C *  SELECT META TYPE  (TYPM)                                          C
C *      HPGL(=1), TEK4014(=2):       CALL GGIP(-999.0, 0.0,  TYPM, 6) C
C *  SELECT GRAPHICS MEDIUM  (ISEL)                                    C
C *   DISPLAY(=1), META(=2):          CALL GGIP(-999.0, 0.0, 0.0, ISEL)C
C *                                           .........                C
C *  START A NEW PLOT:                CALL GGIP(XMAX,   YMAX, 0.0,  1) C
C *  PLOT INSTRUCTIONS:                       .........                C
C *                                   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,PCAL,PLOTS, -5) C
C *                                                                    C
C *********************************************************************C
      PARAMETER (IPDS = 2, IPME = 4)
      COMMON /GGT/ MEDIUM
      COMMON /CGGT/ IGGT
      CHARACTER IGGT*80
      COMMON /CGG11/ BCD, SBCD
      CHARACTER BCD*132, SBCD*132
      COMMON /CGGIP/ ISW, ISK, IHP, ICAL, IP, SCF, IT,  ISTAT, IMETA,
     1 IHPDP, ITERM, MODE, IXO, IYO, IZO, ITEL, XR, YR, ZR, XOLD, YOLD,
     2 ZOLD, NPO, NAMP, IFLNM, IPCL, IPCLN, LU98, LU99, LPLT, LTERM,
     3 IXM, IYM, JXO, JYO, JZO, INOP, NXY, XMAX, YMAX, SCFJ, JT, JTEL,
     4 NPLOT, IBEEP, ISVPRN, ISVPLT, LU95, LU96, ZFRC, KNM, KXE(6),
     5 KYE(6), METAPL, IPSW, FACTR, KTEL, IXOHI, IXOLO, IYOHI, IYOLO,
     6 IOMETA, IOTERM, IOBEEP, IOHP, IOCAL, IXYOE, IWDO, NRPS, IPSR,
     7 IPSH, IBAW, IPSX, IPSV, IGST, IPCLD, IPSD, IPSN, IPSM, IXVERS,
     8 IDMX, IDMY, IDMZ, NDSCOD(IPDS)
      COMMON /CHGGIP/ KME(6), METAF, VERSIE, DCODE, MCODE,
     1 DSCOD(IPDS), MECOD(IPME), PLEXT(IPME)
      CHARACTER KME*1, METAF*80, VERSIE*6, DCODE*7,
     1 MCODE*7, DSCOD*7, MECOD*7, PLEXT*3
      CHARACTER HPD*3, CAL*3, MED1*7, BEEP*1
      COMMON /WINBUF/ BUF
      CHARACTER BUF*132
      XX      = X
      YY      = Y
      ZZ      = Z
      II      = IVAL
      ICHANGE = 0
    1 IF (XX .LT. -998.9) THEN
        IF (IABS(II) .LT. 10) THEN
          IF (II .NE. -5) THEN
            IY = NINT(YY)
            IZ = NINT(ZZ)
          ENDIF
          ISTAT = 1
C * FUNCTION 9: FRACTION WINDOW:DISPLAY SIZE
          IF (II .EQ. 9) THEN
            IBAW = IY
            IF (IZ .GE. 10) ISW = IZ
            IF (IWDO .NE. 0) THEN
              IDUM1 = 0
              IDUM2 = 0
              IDUM3 = 0
              IDUM4 = 0
              CALL GGIP09 (IDUM1, IDUM2, IDUM3, IDUM4)
              IWDO  = 0
            ENDIF
            WRITE (LU99, 99995) ISW / 1000.0
C * FUNCTION 8: GRAPHICS STATUS INFO
          ELSE IF (II .EQ. 8) THEN
            IF (IGST .EQ. -1) THEN
              IDUM1 = 0
              IDUM2 = 0
              IDUM3 = 0
              IDUM4 = -1
              CALL GGIP09 (IDUM1, IDUM2, IGST, IDUM4)
            ENDIF
            Y = IGST
            Z = IMETA
          ELSE IF (II .EQ. -8) THEN
            X = IDMX
            Y = IDMY
            Z = IDMZ
C * FUNCTION 7: HELP GRAPHICS
          ELSE IF (II .EQ. 7) THEN
            ISTAT = -1
            WRITE (LU96, 99998)
            WRITE (LU96, 99992) (DSCOD(III), III = 1, IPDS)
            WRITE (LU96, 99993) (MECOD(III), III = 1, IPME)
            WRITE (LU96, 99994)
C * FUNCTION 6: SET TERMINAL, ON-LINE HARDCOPY OR META-FILE TYPE
          ELSE IF (II .EQ. 6) THEN
            IF (IY .EQ. 0 .AND. IZ .EQ. 0) THEN
              MED1 = IGGT(16:22)
              IF (MED1 .EQ. 'ON     ') THEN
                II =  1
              ELSE IF (MED1 .EQ. 'OFF    ') THEN
                CALL GGIP10
                II = -1
              ELSE
                II =  6
              ENDIF
              IF (MEDIUM .EQ. 0) THEN
                IF (II .NE. 6) IBEEP = (II + 1) / 2
              ELSE IF (MEDIUM .EQ. 1) THEN
                IF (II .NE. 6) THEN
                  II = 2 * II
                ELSE
                  DO 1100 IY = 1, IPDS
                    IF (MED1 .EQ. DSCOD(IY)) GOTO 1110
 1100             CONTINUE
C * CHAR(7) = ASCII BELL = CTRL-G
                  WRITE (LU96, 99991) MED1, CHAR(7)
                  IY =  ITERM
 1110             CONTINUE
                ENDIF
               ELSE IF (MEDIUM .EQ. 2) THEN
                 IF (II .NE. 6) THEN
                   II = 3 * II
                 ELSE
                   DO 1200 IZ = 1, IPME
                     IF (MED1 .EQ. MECOD(IZ)) GOTO 1210
 1200              CONTINUE
C * CHAR(7) = ASCII BELL = CTRL-G
                   WRITE (LU96, 99991) MED1, CHAR(7)
                   IZ = IMETA
 1210              CONTINUE
                 ENDIF
               ELSE
C * CHAR(7) = ASCII BELL = CTRL-G
                 WRITE (LU96, 99990) MEDIUM, CHAR(7)
               ENDIF
               CALL GEN038 (IGGT, 1, 80)
               IF (II .NE. 6) GOTO 1
             ENDIF
             IF (IY .GT. 0) THEN
               ITERM = IY
             ELSE
               IF (NPLOT .EQ. 0) THEN
                 IMETA = IZ
               ELSE
                 IF (IMETA .NE. IZ) THEN
                   IF (LPLT .LE. 0) THEN
                     CLOSE (LU98, STATUS = 'DELETE')
                   ELSE
                     CLOSE (LU98)
                     WRITE (LU96, 99996) METAF(1:KNM), PLEXT(IMETA),
     1                                   LPLT, NPLOT
                     IMETA = IZ
                     LPLT  = -1
                     NPLOT = 0
                   ENDIF
                 ENDIF
               ENDIF
               CALL GEN038 (IGGT, 1, 80)
             ENDIF
             IF (ITERM .LT. 99) DCODE = DSCOD(ITERM)
             MCODE = MECOD(IMETA)
             IF (IOMETA .NE. IMETA) THEN
               ICHANGE = 1
               IOMETA = IMETA
             ENDIF
             IF (IOTERM .NE. ITERM) THEN
               ICHANGE = 1
               IOTERM = ITERM
             ENDIF
C * FUNCTION 5: HANDLING OF PROGRAM START/FINISH
          ELSE IF (IABS(II) .EQ. 5) THEN
            CALL GGIP07 (II, IY, IZ)
C * FUNCTION  4: LANDSCAPE/PORTRAIT HANDLING (POSTSCRIPT)
          ELSE IF (IABS(II) .EQ. 4) THEN
            IF (II .GT. 0) THEN
              IPSH = 0
              IPSV = 0
              IPSR = 0
            ELSE
              IPSH = 0
              IPSV = 6120
              IPSR = -90
            ENDIF
C * FUNCTION 3: IS IT A META(ON/OFF) REQUEST
          ELSE IF (IABS(II) .EQ. 3) THEN
            ICAL  = SIGN(1, II)
            IF (ICAL .LT. 0) IHP = 1
            IF (Z .LT. 0) THEN
              METAPL = -1
            ELSE
              METAPL =  1
            ENDIF
C * FUNCTION 2: IS IT A DISPLAY(ON/OFF) REQUEST
          ELSE IF (IABS(II) .EQ. 2) THEN
            IHPDP = 1
            IHP   = SIGN(1, II)
C * FUNCTION 1: CHECK FOR OPEN WINDOW
          ELSE IF (IABS(II) .EQ. 1) THEN
            IDUM1 = 0
            IDUM2 = 0
            IDUM3 = 0
            IDUM4 = 13
            CALL GGIP09 (IDUM1, IDUM2, IDUM3, IDUM4)
            Z     = IDUM3
          ENDIF
          IF (IHP .LT. 0) ICAL = 1
          IF (ISTAT .GT. 0) THEN
            IF (IHP .LT. 0) THEN
              HPD = 'off'
            ELSE
              HPD = 'on '
            ENDIF
            IF (IOHP .NE. IHP) THEN
              ICHANGE = 1
              IOHP = IHP
            ENDIF
            IF (ICAL .GT. 0) THEN
              CAL = 'on '
            ELSE
              CAL = 'off'
            ENDIF
            IF (IOCAL .NE. ICAL) THEN
              ICHANGE = 1
              IOCAL = ICAL
            ENDIF
            IF (IBEEP .EQ. 1) THEN
              BEEP = '!'
            ELSE
              BEEP = ' '
            ENDIF
            IF (IOBEEP .NE. IBEEP) THEN
              ICHANGE = 1
              IOBEEP = IBEEP
            ENDIF
            IF (ICHANGE .NE. 0) THEN
              WRITE (LU96, 99999) HPD, BEEP, DCODE
              WRITE (LU96, 99997) CAL, MCODE
              ICHANGE = 0
            ENDIF
            ISTAT = -1
          ENDIF
        ELSE IF (II .GT. 9) THEN
          IDUM1 = INDEX(BCD, CHAR(0))
          IDUM2 = NINT(YY)
          IDUM3 = NINT(ZZ)
          IDUM4 = IABS(II) + 90
          BUF   = BCD
          CALL GGIP09 (IDUM1, IDUM2, IDUM3, IDUM4)
        ENDIF
      ELSE
        IF (IABS(II) .LE. 9) THEN
          IF (IABS(II) .LE. 1) THEN
C * PLOT FUNCTIONS 1, -1, 0: HANDLING OF NAMPLT/ENDPLT/NEWPEN
            IF (II .EQ. 1) THEN
              CALL GGIP01 (XX, YY, ZZ)
              FACTR = 1.0
            ELSE IF (II .EQ. -1) THEN
              CALL GGIP02 (Z)
            ELSE IF (II .EQ. 0) THEN
              XX = 0.0
              IF (YY .GE. 0.0) THEN
                IF (IHP .GT. 0 .OR. ICAL .GT. 0) IPCLN = NINT(YY)
              ELSE
                IF (IHP .GT. 0 .OR. ICAL .GT. 0) THEN
                  IPSN = NINT(ABS(YY))
                  IF (IPSN .GE. 100) THEN
                    IPSX = IPSN / 100
                    IPSN = IPSN - IPSX * 100
                  ENDIF
                ENDIF
              ENDIF
            ENDIF
          ELSE IF (II .EQ. 4) THEN
            CALL GGIP08 (XX, YY)
          ELSE IF (II .EQ. 5) THEN
            IF (NAMP .GE. 0) THEN
              IF (IHPDP .EQ. 1 .AND. IWDO .EQ. 1) THEN
                IPCLN = IPCLD
                IPSN  = IPSD
                CALL GGIP03
                IBUT  = 0
                CALL GGIP09 (IX, IY, IBUT, II)
                ZZ    = IBUT
                IVENT = II
                IF (II .EQ. 1) THEN
                  XX = IX / (SCF * FACTR)
                  YY = IY / (SCF * FACTR)
                ELSE IF (II .EQ. 5) THEN
                  BCD(1:1) = BUF(1:1)
                ELSE
                  XX    = IX
                  YY    = IY
                ENDIF
              ELSE
                IVENT = -1
              ENDIF
            ELSE
              IVENT = 0
            ENDIF
            X    = XX
            Y    = YY
            Z    = ZZ
            IVAL = IVENT
          ELSE IF (II .EQ. 6) THEN
            IF (IHPDP .EQ. 1 .AND. IWDO .EQ. 1) THEN
              IDUM1 = 0
              IDUM2 = 0
              IDUM3 = 0
              IDUM4 = 7
              BUF(1:1) = CHAR(0)
              CALL GGIP09 (IDUM1, IDUM2, IDUM3, IDUM4)
            ENDIF
          ELSE IF (II .EQ. 7) THEN
            FACTR = YY
          ELSE IF (II .EQ. 9) THEN
            IF (NAMP .GE. 0) THEN
              IF (IHPDP .EQ. 1 .AND. IWDO .EQ. 1) THEN
                IDUM3 = 0
                CALL GGIP09 (IX, IY, IDUM3, II)
                IVENT = II
              ELSE
                IVENT = -1
              ENDIF
            ELSE
              IVENT = 0
            ENDIF
            IVAL = IVENT
          ELSE
C * PLOT FUNCTION 2,3: INSTRUCTION A LA CALCOMP : CALL PLOT(X, Y, I)
            CALL GGIP04 (XX, YY, II)
          ENDIF
        ENDIF
      ENDIF
      RETURN
99999 FORMAT (/, 'Current Graphics Settings: Online Display  >> ',
     1        A, '; DISPLAY ', A, '  CODE = ', A)
99998 FORMAT (/,
     1 'The graphics drivers provide for 2 types of graphics output:'/
     2 '  DISPLAY - Interactive graphics output on the Display'/
     3 '  META    - A Meta-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:')
99997 FORMAT ('===(See HELP GRAPHICS)===: Meta File       >> ',
     1        A, '; META FILE  CODE = ', A, /)
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 TEK4100,', /,
     2 'Similarly the current Metafile code may be set.', /,
     3 'The plot-ready BEEP may be set on/off with SET BEEP OFF etc.'/)
99993 FORMAT ('  META    : ',  7(A, ', '), /, 12X, 7(A, ', '))
99992 FORMAT ('  DISPLAY : ',  7(A, ', '), /, 12X, 7(A, ', '))
99991 FORMAT (':: UNKNOWN DRIVER REQUEST (IGNORED)! :', A, A)
99990 FORMAT (':: UNKNOWN MEDIUM REQUEST (IGNORED)! :', I3, A)
      END
      SUBROUTINE GGIP01 (XX, YY, ZZ)
      PARAMETER (IPDS = 2, IPME = 4)
      COMMON /CGGT/ IGGT
      COMMON /CGGIP/ ISW, ISK, IHP, ICAL, IP, SCF, IT,  ISTAT, IMETA,
     1 IHPDP, ITERM, MODE, IXO, IYO, IZO, ITEL, XR, YR, ZR, XOLD, YOLD,
     2 ZOLD, NPO, NAMP, IFLNM, IPCL, IPCLN, LU98, LU99, LPLT, LTERM,
     3 IXM, IYM, JXO, JYO, JZO, INOP, NXY, XMAX, YMAX, SCFJ, JT, JTEL,
     4 NPLOT, IBEEP, ISVPRN, ISVPLT, LU95, LU96, ZFRC, KNM, KXE(6),
     5 KYE(6), METAPL, IPSW, FACTR, KTEL, IXOHI, IXOLO, IYOHI, IYOLO,
     6 IOMETA, IOTERM, IOBEEP, IOHP, IOCAL, IXYOE, IWDO, NRPS, IPSR,
     7 IPSH, IBAW, IPSX, IPSV, IGST, IPCLD, IPSD, IPSN, IPSM, IXVERS,
     8 IDMX, IDMY, IDMZ, NDSCOD(IPDS)
      CHARACTER CMETA*1, IGGT*80, FNLU98*80
      LOGICAL CC
      COMMON /CTRLC/ CC
      COMMON /CHGGIP/ KME(6), METAF, VERSIE, DCODE, MCODE,
     1 DSCOD(IPDS), MECOD(IPME), PLEXT(IPME)
      CHARACTER KME*1, METAF*80, VERSIE*6, DCODE*7,
     1 MCODE*7, DSCOD*7, MECOD*7, PLEXT*3
      COMMON /CGG11/ BCD, SBCD
      CHARACTER BCD*132, SBCD*132
      COMMON /WINBUF/ BUF
      CHARACTER BUF*132
      BUF  = BCD
      CC = .FALSE.
      CALL SETUPCC
      IF (IHP .GT. 0 .AND. ICAL .GT. 0) THEN
        IF (METAPL .EQ. 0 .AND. IHPDP .EQ. 2) THEN
          WRITE (LU96, 99991)
          READ  (LU95, 99992) CMETA
          IF (CMETA .EQ. 'N' .OR. CMETA .EQ. 'n') ICAL   = -1
          IF (CMETA .EQ. 'A' .OR. CMETA .EQ. 'a') METAPL = -1
        ENDIF
      ENDIF
      IF (METAPL .EQ. 1) METAPL = 0
      XMAX   = ABS(XX)
      YMAX   = ABS(YY)
      ZFRC   = ABS(ZZ)
      IF (YMAX .LT. 0.01) YMAX = XMAX
      IF (ZFRC .LT. 0.01) ZFRC = 1.0
      NAMP = 1
      CALL GEN038 (IGGT, 1, 80)
      IPCL  = 0
      IPSW  = 0
      ISK   = 0
      IF (IHP .GT. 0) THEN
        LTERM = 1
        ITEL  = 0
        MODE  = 0
 1000   IHPDP = ITERM
        CALL GGIP05 (-1)
        IPCLN = IPCLD
        IPSN  = IPSD
C * X11 - XLIB GRAPHICS
        IF (IHPDP .EQ. 1) THEN
          IF (IWDO .EQ. 0) THEN
            IDUM1 = 0
            IDUM2 = 0
            CALL GGIP09 (IDUM1, IDUM2, IBAW, 12)
            IXM = ISW
            IYM = 1000
            IMENU = IXVERS
            CALL GGIP09 (IXM, IYM, IMENU, 1)
            IF (IXM .LT. 0) THEN
              ITERM = 2
              DCODE = DSCOD(ITERM)
              GOTO 1000
            ELSE
              IWDO = 1
            ENDIF
            CALL GGIP09 (IDMX, IDMY, IDMZ, 11)
          ENDIF
          IDUM1 = 0
          IDUM2 = 0
          IDUM3 = 0
          IDUM4 = 6
          CALL GGIP09 (IDUM1, IDUM2, IDUM3, IDUM4)
        ELSE IF (IHPDP .EQ. 2) THEN
          IXM  = 1023
          IYM  = 767
          INOP = 31
C * SEND <ESC>E and wait for half-a-second (= FULL RESET ON HP)
          CALL GGIP05(-2)
C * CLEAR SCREEN
          CALL GGIP05(27)
          CALL GGIP05(12)
          CALL GGIP05(-2)
        ENDIF
        IXO = IXM
        IYO = IYM
      ENDIF
      IF (ICAL .GT. 0) THEN
        IF (LPLT .LT. 0) THEN
          FNLU98 = METAF(1:KNM)//'.'//PLEXT(IMETA)
          OPEN (UNIT = LU98, FILE = FNLU98, STATUS = 'UNKNOWN')
          LPLT = 0
        ENDIF
        NPLOT = NPLOT + 1
        IF (IMETA .EQ. 2 .OR. IMETA .EQ. 4) THEN
          IF (ISVPLT .EQ. 0) THEN
            ISVPLT = 1
          ELSE
            WRITE (LU98, 99993)
          ENDIF
          IF (IMETA .EQ. 4) THEN
C * <esc>E<esc>%-1B FOR HPGL/XL
            WRITE (LU98, 99990) CHAR(27), CHAR(69), CHAR(27),
     1        CHAR(37), CHAR(45), CHAR(49), CHAR(66), IPCL
          ELSE
            WRITE (LU98, 99998) IPCL
          ENDIF
          JXO = 10000
          JYO = 7200
        ELSE IF (IMETA .EQ. 3) THEN
          CALL GGIP06(-1)
C * FORM FEED
          IF (NPLOT .GT. 1) THEN
            CALL GGIP06(27)
            CALL GGIP06(12)
          ENDIF
C * DECTEK SEQUENCE FOR LN03-PLUS - esc,[,?,3,8,h
          CALL GGIP06(27)
          CALL GGIP06(91)
          CALL GGIP06(63)
          CALL GGIP06(51)
          CALL GGIP06(56)
          CALL GGIP06(104)
          CALL GGIP06(-2)
          JXO  = 4095
          JYO  = 3071
          JTEL = 0
        ELSE IF (IMETA .EQ. 1) THEN
          NRPS = NRPS + 1
          IF (NRPS .EQ. 1) THEN
            WRITE (LU98, 99996)
          ELSE
            WRITE (LU98, 99995) NRPS, NRPS
          ENDIF
          WRITE (LU98, 99994) IPSH, IPSV, IPSR
          JXO    = 7333
          JYO    = 5500
          JTEL   = 0
          KTEL   = 0
          KXE(6) = 0
          KYE(6) = 0
          KME(6) = 'm'
        ENDIF
        NXY = 0
      ENDIF
      SCF = (IYM + 1) * ZFRC / YMAX
      IF (ICAL .GT. 0) THEN
C * SCF FOR TEK4014 -META FILE
        SCFJ  = JYO * ZFRC / YMAX
        SCFJ1 = JXO * ZFRC / XMAX
        SCFJ  = MIN(SCFJ, SCFJ1)
      ENDIF
      XR = 0.0
      YR = 0.0
      ZR = 0.0
      RETURN
99998 FORMAT ('IN;SP', I5,';')
99996 FORMAT ('%!PS-Adobe-1.0', /,
     1        '%%Creator GGIP - A.L.Spek', /,
     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')
99995 FORMAT ('%%Page:', 2I5)
99994 FORMAT (' 0.1 0.1 scale n 1 setlinecap',
     1         2I5, ' translate ', I4, ' rotate')
99993 FORMAT ('AF;')
99992 FORMAT (A)
99991 FORMAT ('Should META-file remain opened for this plot?',
     1 '(A/Y/N[Y])', $)
99990 FORMAT (7A, /,'IN;SP', I5,';SC 0,9600,0,7200,1,0,0;')
      END
      SUBROUTINE GGIP02 (Z)
      PARAMETER (IPDS = 2)
      COMMON /CGGT/ IGGT
      CHARACTER IGGT*80
      COMMON /CGGIP/ ISW, ISK, IHP, ICAL, IP, SCF, IT,  ISTAT, IMETA,
     1 IHPDP, ITERM, MODE, IXO, IYO, IZO, ITEL, XR, YR, ZR, XOLD, YOLD,
     2 ZOLD, NPO, NAMP, IFLNM, IPCL, IPCLN, LU98, LU99, LPLT, LTERM,
     3 IXM, IYM, JXO, JYO, JZO, INOP, NXY, XMAX, YMAX, SCFJ, JT, JTEL,
     4 NPLOT, IBEEP, ISVPRN, ISVPLT, LU95, LU96, ZFRC, KNM, KXE(6),
     5 KYE(6), METAPL, IPSW, FACTR, KTEL, IXOHI, IXOLO, IYOHI, IYOLO,
     6 IOMETA, IOTERM, IOBEEP, IOHP, IOCAL, IXYOE, IWDO, NRPS, IPSR,
     7 IPSH, IBAW, IPSX, IPSV, IGST, IPCLD, IPSD, IPSN, IPSM, IXVERS,
     8 IDMX, IDMY, IDMZ, NDSCOD(IPDS)
      IF (NAMP .GT. 0) THEN
        CALL GGIP10
        IF (IHP .GT. 0) THEN
          MODE = 0
          IF (IHPDP .EQ. 1) THEN
            IX   = 0
            IY   = 0
            IZ   = 0
            IWIN = 8
            CALL GGIP09 (IX, IY, IZ, IWIN)
            IWIN = 7
            CALL GGIP09 (IX, IY, IZ, IWIN)
          ELSE IF (IHPDP .EQ. 2) THEN
C * <ESC><US>
            CALL GGIP05(27)
            CALL GGIP05(31)
          ENDIF
C * CHAR(7) = ASCII BELL = CTRL-G
          IF (IBEEP .EQ. 1) CALL GGIP05(7)
          CALL GGIP05(-2)
          IPCL = 0
        ENDIF
      ENDIF
      IF (IHP .GT. 0 .AND. NAMP .GE. 0) THEN
        IF (NAMP .EQ. 1 .AND. Z .EQ. 0) THEN
          IF (IHPDP .NE. 1) THEN
            READ (LU95, '(A)', END = 5100) IGGT
 5100       CONTINUE
          ENDIF
        ELSE IF (NAMP .EQ. 1 .AND. Z .GT. 0) THEN
          WRITE (LU96, 99990)
          IF (Z .GT. 1) CALL SLEEP (NINT(Z))
        ELSE IF (NAMP .EQ. 1 .AND. Z .LT. -1) THEN
          CALL SLEEP (NINT(-Z))
        ENDIF
        IF ((IHPDP .EQ. 2) .AND. NAMP .GT. 0) THEN
          WRITE (LU99, 99995) CHAR(27),CHAR(29),CHAR(27),CHAR(12),
     1                     CHAR(27),CHAR(31),CHAR(27),CHAR(69)
        ENDIF
      ENDIF
      IF (NAMP .EQ. 1) NAMP = 0
      RETURN
99995 FORMAT (1X, 15A)
99990 FORMAT (/, ':: PLOTTING INTERRUPTED!!', /)
      END
      SUBROUTINE GGIP03
      PARAMETER (IPDS = 2, IPME = 4)
      COMMON /CGGIP/ ISW, ISK, IHP, ICAL, IP, SCF, IT,  ISTAT, IMETA,
     1 IHPDP, ITERM, MODE, IXO, IYO, IZO, ITEL, XR, YR, ZR, XOLD, YOLD,
     2 ZOLD, NPO, NAMP, IFLNM, IPCL, IPCLN, LU98, LU99, LPLT, LTERM,
     3 IXM, IYM, JXO, JYO, JZO, INOP, NXY, XMAX, YMAX, SCFJ, JT, JTEL,
     4 NPLOT, IBEEP, ISVPRN, ISVPLT, LU95, LU96, ZFRC, KNM, KXE(6),
     5 KYE(6), METAPL, IPSW, FACTR, KTEL, IXOHI, IXOLO, IYOHI, IYOLO,
     6 IOMETA, IOTERM, IOBEEP, IOHP, IOCAL, IXYOE, IWDO, NRPS, IPSR,
     7 IPSH, IBAW, IPSX, IPSV, IGST, IPCLD, IPSD, IPSN, IPSM, IXVERS,
     8 IDMX, IDMY, IDMZ, NDSCOD(IPDS)
      COMMON /CHGGIP/ KME(6), METAF, VERSIE, DCODE, MCODE,
     1 DSCOD(IPDS), MECOD(IPME), PLEXT(IPME)
      CHARACTER KME*1, METAF*80, VERSIE*6, DCODE*7,
     1 MCODE*7, DSCOD*7, MECOD*7, PLEXT*3
      IF (IPCLN .NE. IPCL) THEN
        IPCL = IPCLN
        IF (IHP .GT. 0) THEN
          IF (IHPDP .EQ. 1) THEN
            IDUM2 = 0
            IDUM3 = 0
            IDUM4 = 99
            CALL GGIP09 (IPCL, IDUM2, IDUM3, IDUM4)
          ENDIF
        ENDIF
        IF (ICAL .GT. 0) THEN
          IF (IMETA .EQ. 2 .OR. IMETA .EQ. 4) THEN
            IF (IMETA .EQ. 4) THEN
              IF (IPCL .EQ. 4) THEN
                IPCLX = 5
              ELSE IF (IPCL .EQ. 5) THEN
                IPCLX = 4
              ELSE
                IPCLX = IPCL
              ENDIF
            ELSE
              IPCLX = IPCL
            ENDIF
            WRITE (LU98, 99998) IPCLX
          ELSE IF (IMETA .EQ. 1) THEN
            IF (KTEL .GT. 0) WRITE (LU98, 99989)
     1            (KXE(I), KYE(I), KME(I), I = 1, KTEL)
            IF (KTEL .GT. 0) THEN
              KXE(1) = KXE(KTEL)
              KYE(1) = KYE(KTEL)
              KME(1) = 'm'
              KTEL   = 1
            ELSE
              KTEL = 0
            ENDIF
            JTEL = KTEL
            WRITE (LU98, 99988) IPSM
            IF (IPCL .EQ. 0) THEN
              WRITE (LU98, 99986)
            ELSE IF (IPCL .EQ. 1) THEN
              WRITE (LU98, 99997)
            ELSE IF (IPCL .EQ. 2) THEN
              WRITE (LU98, 99996)
            ELSE IF (IPCL .EQ. 3) THEN
              WRITE (LU98, 99995)
            ELSE IF (IPCL .EQ. 4) THEN
              WRITE (LU98, 99994)
            ELSE IF (IPCL .EQ. 5) THEN
              WRITE (LU98, 99993)
            ELSE IF (IPCL .EQ. 6) THEN
              WRITE (LU98, 99992)
            ELSE IF (IPCL .EQ. 7) THEN
              WRITE (LU98, 99991)
            ELSE IF (IPCL .EQ. 8) THEN
              WRITE (LU98, 99990)
            ENDIF
          ENDIF
        ENDIF
      ENDIF
      IF (IPSN .NE. IPSW) THEN
        IF (IHP .GT. 0) THEN
          IF (IHPDP .EQ. 1) THEN
            IPSY = MAX(IPSN, IPSX)
            IDUM2 = 0
            IDUM3 = 0
            IDUM4 = 10
            CALL GGIP09 (IPSY, IDUM2, IDUM3, IDUM4)
          ENDIF
        ENDIF
        IF (ICAL .GT. 0) THEN
          IF (IMETA .EQ. 1) THEN
            IF (KTEL .GT. 0) WRITE (LU98, 99989)
     1          (KXE(I), KYE(I), KME(I), I = 1, KTEL)
            IF (KTEL .GT. 0) THEN
              KXE(1) = KXE(KTEL)
              KYE(1) = KYE(KTEL)
              KME(1) = 'm'
              KTEL   = 1
            ELSE
              KTEL = 0
            ENDIF
            JTEL = KTEL
            WRITE (LU98, 99988) IPSM
          ENDIF
        ENDIF
        IPSW = IPSN
      ENDIF
99998 FORMAT ('PU;SP',I5,';')
99997 FORMAT ('0.0 0.0 0.0 c')
99996 FORMAT ('1.0 0.0 0.0 c')
99995 FORMAT ('0.0 1.0 0.0 c')
99994 FORMAT ('0.0 0.0 1.0 c')
99993 FORMAT ('1.0 1.0 0.0 c')
99992 FORMAT ('0.8 0.2 0.2 c')
99991 FORMAT ('0.31 0.18 0.31 c')
99990 FORMAT ('0.65 0.16 0.16 c')
99989 FORMAT (6(2I5, 1X, A1))
99988 FORMAT (I3, ' w s n ')
99986 FORMAT ('1.0 1.0 1.0 c')
      RETURN
      END
      SUBROUTINE GGIP04 (XXX, YYY, IPUD)
      PARAMETER (IPDS = 2, IPME = 4)
      COMMON /CGGIP/ ISW, ISK, IHP, ICAL, IP, SCF, IT,  ISTAT, IMETA,
     1 IHPDP, ITERM, MODE, IXO, IYO, IZO, ITEL, XR, YR, ZR, XOLD, YOLD,
     2 ZOLD, NPO, NAMP, IFLNM, IPCL, IPCLN, LU98, LU99, LPLT, LTERM,
     3 IXM, IYM, JXO, JYO, JZO, INOP, NXY, XMAX, YMAX, SCFJ, JT, JTEL,
     4 NPLOT, IBEEP, ISVPRN, ISVPLT, LU95, LU96, ZFRC, KNM, KXE(6),
     5 KYE(6), METAPL, IPSW, FACTR, KTEL, IXOHI, IXOLO, IYOHI, IYOLO,
     6 IOMETA, IOTERM, IOBEEP, IOHP, IOCAL, IXYOE, IWDO, NRPS, IPSR,
     7 IPSH, IBAW, IPSX, IPSV, IGST, IPCLD, IPSD, IPSN, IPSM, IXVERS,
     8 IDMX, IDMY, IDMZ, NDSCOD(IPDS)
      COMMON /CHGGIP/ KME(6), METAF, VERSIE, DCODE, MCODE,
     1 DSCOD(IPDS), MECOD(IPME), PLEXT(IPME)
      CHARACTER KME*1, METAF*80, VERSIE*6, DCODE*7,
     1 MCODE*7, DSCOD*7, MECOD*7, PLEXT*3
      IMOVE = 0
      JMOVE = 0
      JYOHI = 32
      JXYOE = 32
      JYOLO = 32
      JXOHI = 32
      JXOLO = 32
      II = IPUD
      XX = XXX * FACTR
      YY = YYY * FACTR
      XX = XR + XX
      YY = YR + YY
      IF (II .LT. 0) THEN
        II = -II
        XR =  XX
        YR =  YY
      ENDIF
      DELTA = ABS(XOLD - XX) + ABS(YOLD -YY)
      IF (II .EQ. 3) THEN
        IF (DELTA .GT. 0.001) NPO = 0
      ELSE
    5   IF (NPO .EQ. 0) THEN
          X    = XOLD
          Y    = YOLD
          IPEN = 3
        ELSE
          X    = XX
          Y    = YY
          IPEN = 2
        ENDIF
        IF (ISK .EQ. 0) CALL GGIP03
        IF (IHP .GT. 0) THEN
          IF (ISK .EQ. 0) THEN
            IX = NINT(X * SCF)
            IY = NINT(Y * SCF)
            IF (IX .LT. 0) IX = 0
            IF (IY .LT. 0) IY = 0
            IF (IX .GT. IXM) IX = IXM
            IF (IY .GT. IYM) IY = IYM
            IF (IHPDP .EQ. 1) THEN
              IDUM3 = 0
              CALL GGIP09 (IX, IY, IDUM3, IPEN)
            ELSE IF (IHPDP .EQ. 2) THEN
              IF (IPEN .EQ. 3 .OR. ITEL .EQ. 0) THEN
                CALL GGIP05 (29)
                IMOVE = 1
                IF (ITEL .EQ. 0 .AND. IPEN .EQ. 2) THEN
                  CALL GGIP05 (IYOHI)
                  CALL GGIP05 (IYOLO)
                  CALL GGIP05 (IXOHI)
                  CALL GGIP05 (IXOLO)
                ENDIF
              ENDIF
              IYHI = IY / 32 + 32
              IYLO = MOD(IY, 32) + 96
              IXHI = IX / 32 + 32
              IXLO = MOD(IX, 32) + 64
              ICH4 = 1
              ICH3 = 1
              ICH2 = 1
              IF (IMOVE .EQ. 0) THEN
                ICH4 = 0
                ICH3 = 0
                ICH2 = 0
                IF (IYOHI .NE. IYHI) THEN
                  ICH4 = 1
                ENDIF
                IF (IYOLO .NE. IYLO) THEN
                  ICH3 = 1
                ENDIF
                IF (IXOHI .NE. IXHI) THEN
                  ICH3 = 1
                  ICH2 = 1
                ENDIF
              ENDIF
              IF (ICH4 .EQ. 1)  CALL GGIP05 (IYHI)
              IF (ICH3 .EQ. 1)  CALL GGIP05 (IYLO)
              IF (ICH2 .EQ. 1)  CALL GGIP05 (IXHI)
              CALL GGIP05 (IXLO)
              IYOHI = IYHI
              IYOLO = IYLO
              IXOHI = IXHI
              IXOLO = IXLO
              IMOVE = 0
            ENDIF
            ITEL = ITEL + 1
            IXO  = IX
            IYO  = IY
            IF (IT .GT. 65) THEN
              ITEL = 0
              MODE = 0
              CALL GGIP05 (INOP)
              CALL GGIP05 (-2)
            ENDIF
          ENDIF
        ENDIF
        IF (ICAL .GT. 0) THEN
          IF (LPLT .EQ. -1) WRITE (6, '(''>> LU98-NOT OPEN YET !!'')')
          LPLT = LPLT + 1
          JXE  = NINT(X * SCFJ)
          JYE  = NINT(Y * SCFJ)
          IF (JXE .LT. 0) JXE = 0
          IF (JYE .LT. 0) JYE = 0
          IF (JXE .GT. JXO) JXE = JXO
          IF (JYE .GT. JYO) JYE = JYO
          IF (IMETA .EQ. 2 .OR. IMETA .EQ. 4) THEN
            IF (IPEN .EQ. 3) THEN
              WRITE (LU98, 99997) JXE, JYE
            ELSE IF (IPEN .EQ. 2) THEN
              WRITE (LU98, 99996) JXE, JYE
            ENDIF
          ELSE IF (IMETA .EQ. 3) THEN
            IF (IPEN .EQ. 3 .OR. JTEL .EQ. 0) THEN
              CALL GGIP06(29)
              JMOVE = 1
              IF (JTEL .EQ. 0 .AND. IPEN .EQ. 2) THEN
                CALL GGIP06 (JYOHI)
                CALL GGIP06 (JXYOE)
                CALL GGIP06 (JYOLO)
                CALL GGIP06 (JXOHI)
                CALL GGIP06 (JXOLO)
              ENDIF
            ENDIF
            JX = JXE / 4
            JY = JYE / 4
            JXYE = 96 + MOD(JYE, 4) * 4 + MOD(JXE, 4)
            JYHI = JY / 32 + 32
            JYLO = MOD(JY, 32) + 96
            JXHI = JX / 32 + 32
            JXLO = MOD(JX, 32) + 64
            JCH4 = 1
            JCH2 = 1
            IF (JMOVE .EQ. 0) THEN
              JCH4 = 0
              JCH2 = 0
              IF (JYOHI .NE. JYHI) THEN
                JCH4 = 1
              ENDIF
              IF (JXOHI .NE. JXHI) THEN
                JCH2 = 1
              ENDIF
            ENDIF
            IF (JCH4 .EQ. 1)  CALL GGIP06 (JYHI)
            CALL GGIP06 (JXYE)
            CALL GGIP06 (JYLO)
            IF (JCH2 .EQ. 1)  CALL GGIP06 (JXHI)
            CALL GGIP06 (JXLO)
            JTEL = JTEL + 1
            IF (JTEL .GT. 10) THEN
              JTEL = 0
              CALL GGIP06 (-2)
            ENDIF
            JYOHI = JYHI
            JXYOE = JXYE
            JYOLO = JYLO
            JXOHI = JXHI
            JXOLO = JXLO
            JMOVE = 0
          ELSE IF (IMETA .EQ. 1) THEN
            KTEL = KTEL + 1
            JTEL = JTEL + 1
            KXE(KTEL) = (JYO - JYE) + 200
            KYE(KTEL) = JXE + 200
            KME(KTEL) = CHAR(106 + IPEN)
            IF (KTEL .EQ. 6) THEN
              WRITE (LU98, 99993) (KXE(I), KYE(I), KME(I), I = 1, 6)
              KTEL = 0
              IF (JTEL .GE. 150) THEN
                WRITE (LU98, 99992) IPSM
                KXE(1) = KXE(6)
                KYE(1) = KYE(6)
                KME(1) = 'm'
                JTEL   = 1
                KTEL   = 1
              ENDIF
            ENDIF
          ENDIF
        ENDIF
        IF (NPO .EQ. 0) THEN
          NPO = 1
          GOTO 5
        ENDIF
      ENDIF
      XOLD = XX
      YOLD = YY
      RETURN
99997 FORMAT ('PU;PA',I5,',',I5,';')
99996 FORMAT ('PD;PA',I5,',',I5,';')
99993 FORMAT (6(2I5, 1X, A1))
99992 FORMAT (I3, ' w s n')
      END
      SUBROUTINE GGIP05 (ICH)
      PARAMETER (IPDS = 2)
      CHARACTER IPL*255, JPL*255
      COMMON /CCHAR/ IPL, JPL
      COMMON /CGGIP/ ISW, ISK, IHP, ICAL, IP, SCF, IT,  ISTAT, IMETA,
     1 IHPDP, ITERM, MODE, IXO, IYO, IZO, ITEL, XR, YR, ZR, XOLD, YOLD,
     2 ZOLD, NPO, NAMP, IFLNM, IPCL, IPCLN, LU98, LU99, LPLT, LTERM,
     3 IXM, IYM, JXO, JYO, JZO, INOP, NXY, XMAX, YMAX, SCFJ, JT, JTEL,
     4 NPLOT, IBEEP, ISVPRN, ISVPLT, LU95, LU96, ZFRC, KNM, KXE(6),
     5 KYE(6), METAPL, IPSW, FACTR, KTEL, IXOHI, IXOLO, IYOHI, IYOLO,
     6 IOMETA, IOTERM, IOBEEP, IOHP, IOCAL, IXYOE, IWDO, NRPS, IPSR,
     7 IPSH, IBAW, IPSX, IPSV, IGST, IPCLD, IPSD, IPSN, IPSM, IXVERS,
     8 IDMX, IDMY, IDMZ, NDSCOD(IPDS)
      IC  = ICH
      IF (IC .EQ. -1) THEN
        IT = 0
      ELSE IF (IC .GT. -1 .AND. IC .LT. 128) THEN
        IT = IT + 1
        IPL(IT:IT) = CHAR(IC)
      ELSE IF (IC .EQ. -2) THEN
        IF (IT .GT. 0) THEN
          WRITE (LU99, 99999) IPL(1:IT)
          IT = 0
        ENDIF
      ENDIF
      RETURN
99999 FORMAT (1X, A)
      END
      SUBROUTINE GGIP06 (ICH)
      PARAMETER (IPDS = 2)
      CHARACTER IPL*255, JPL*255
      COMMON /CCHAR/ IPL, JPL
      COMMON /CGGIP/ ISW, ISK, IHP, ICAL, IP, SCF, IT,  ISTAT, IMETA,
     1 IHPDP, ITERM, MODE, IXO, IYO, IZO, ITEL, XR, YR, ZR, XOLD, YOLD,
     2 ZOLD, NPO, NAMP, IFLNM, IPCL, IPCLN, LU98, LU99, LPLT, LTERM,
     3 IXM, IYM, JXO, JYO, JZO, INOP, NXY, XMAX, YMAX, SCFJ, JT, JTEL,
     4 NPLOT, IBEEP, ISVPRN, ISVPLT, LU95, LU96, ZFRC, KNM, KXE(6),
     5 KYE(6), METAPL, IPSW, FACTR, KTEL, IXOHI, IXOLO, IYOHI, IYOLO,
     6 IOMETA, IOTERM, IOBEEP, IOHP, IOCAL, IXYOE, IWDO, NRPS, IPSR,
     7 IPSH, IBAW, IPSX, IPSV, IGST, IPCLD, IPSD, IPSN, IPSM, IXVERS,
     8 IDMX, IDMY, IDMZ, NDSCOD(IPDS)
      IC  = ICH
      IF (IC .EQ. -1) THEN
        JT = 0
      ELSE IF (IC .GT. -1 .AND. IC .LT. 128) THEN
        JT = JT + 1
        JPL(JT:JT) = CHAR(IC)
      ELSE IF (IC .EQ. -2) THEN
        IF (JT .GT. 0) THEN
          WRITE (LU98, 99999) JPL(1:JT)
          JT = 0
        ENDIF
      ENDIF
      RETURN
99999 FORMAT (A)
      END
      SUBROUTINE GGIP07 (IMODE, IY, IZ)
      PARAMETER (IPDS = 2, IPME = 4)
      COMMON /CGGIP/ ISW, ISK, IHP, ICAL, IP, SCF, IT,  ISTAT, IMETA,
     1 IHPDP, ITERM, MODE, IXO, IYO, IZO, ITEL, XR, YR, ZR, XOLD, YOLD,
     2 ZOLD, NPO, NAMP, IFLNM, IPCL, IPCLN, LU98, LU99, LPLT, LTERM,
     3 IXM, IYM, JXO, JYO, JZO, INOP, NXY, XMAX, YMAX, SCFJ, JT, JTEL,
     4 NPLOT, IBEEP, ISVPRN, ISVPLT, LU95, LU96, ZFRC, KNM, KXE(6),
     5 KYE(6), METAPL, IPSW, FACTR, KTEL, IXOHI, IXOLO, IYOHI, IYOLO,
     6 IOMETA, IOTERM, IOBEEP, IOHP, IOCAL, IXYOE, IWDO, NRPS, IPSR,
     7 IPSH, IBAW, IPSX, IPSV, IGST, IPCLD, IPSD, IPSN, IPSM, IXVERS,
     8 IDMX, IDMY, IDMZ, NDSCOD(IPDS)
      COMMON /CHGGIP/ KME(6), METAF, VERSIE, DCODE, MCODE,
     1 DSCOD(IPDS), MECOD(IPME), PLEXT(IPME)
      CHARACTER KME*1, METAF*80, VERSIE*6, DCODE*7,
     1 MCODE*7, DSCOD*7, MECOD*7, PLEXT*3
      COMMON /CGGT/ IGGT
      CHARACTER IGGT*80
C * SUBROUTINE PERFORMES GENERAL OPEN/CLOSE PROCEDURES ON PROGRAM BEGIN/E
      ISTAT = IMODE
C * GENERAL WINDOW OPEN PREAMBLE
      IF (ISTAT .GT. 0) THEN
        ITERM = 1
        IF (IY .GT. 0) THEN
          LPLT = 0
          LU98 = IY
        ELSE IF (IY .LT. 0) THEN
          KNM = - IY
          METAF = IGGT(2:KNM + 1)
        ELSE
          METAF = 'PLOT'
          KNM   = 4
        ENDIF
        IF (IZ .GT. 0) THEN
          LTERM = 0
          LU99  = IZ
        ENDIF
        IF (ITERM .LT. 99)  DCODE = DSCOD(ITERM)
        MCODE = MECOD(IMETA)
C * GENERAL WINDOW CLOSE AND REPORT
      ELSE
        IF (IHPDP .EQ. 1) THEN
          IF (IWDO .EQ. 1) THEN
            IDUM1 = 0
            IDUM2 = 0
            IDUM3 = 0
            IDUM4 = 0
            CALL GGIP09 (IDUM1, IDUM2, IDUM3, IDUM4)
          ENDIF
        ENDIF
        IF (LPLT .LE. 0) THEN
          CLOSE (LU98, STATUS = 'DELETE')
        ELSE
          IF (IMETA .EQ. 1) WRITE (LU98, 99999) NRPS
          WRITE (LU96, 99998) METAF(1:KNM), PLEXT(IMETA),
     1                             NPLOT, LPLT
          CLOSE (LU98)
        ENDIF
      ENDIF
      RETURN
99999 FORMAT ('%%Pages:', I5, /, '%%EOF')
99998 FORMAT (/, ':: Meta-plotfile on File ', A, '.', A, /,
     1        ':: # Plot(s) =', I5, ', # Vector(s) =', I8, /)
      END
      SUBROUTINE GGIP08 (X, Y)
      COMMON /PLCHR/ ADR(91), TAB(195)
      COMMON /CGG11/ BCD, SBCD
      CHARACTER BCD*132, SBCD*132
      COMMON /DGG11/ TH, HT, IE
      INTEGER ADR, TAB
      X0 = X
      Y0 = Y
      THETA = TH * 0.017453294
      COST  = COS(THETA)
      SINT  = SIN(THETA)
      IC   = 3
      IW   = 1
      GRID = 7
      H    = HT / GRID
      XA = COST * H
      YA = SINT * H
   10 IYS = 0
      DO 20 ICH = 1, 91
        IF (CHAR(ICH + 31) .EQ. BCD(IW:IW))  GOTO 30
   20 CONTINUE
      ICH = 1
   30 JCH = ADR(ICH)
      ICH = JCH / 100
      NR  = MOD(JCH, 100)
   40 IF (ICH .EQ. 0) THEN
        IC = 3
        X0 = X0 + XA * 6.0
        Y0 = Y0 + YA * 6.0
        IW = IW + 1
        IF (IW .GT. IE)  GOTO 70
        GOTO 10
      ENDIF
   50 IWR = TAB(ICH)
      ICH = ICH + 1
      IS = 5
      IDEEL = 16777216
   60 IF (IS .EQ. 0)  GOTO 50
      IWRD  = IWR / IDEEL
      IWR   = IWR - IWRD * IDEEL
      IS    = IS - 1
      IDEEL = IDEEL / 64
      IX    = IWRD / 8
      IY    = MOD(IWRD, 8)
      IF (IX .EQ. 7) THEN
        IYS = IY
        IC = 3
      ELSE
        W1 = X0 + IX * XA - (IY - IYS) * YA
        W2 = Y0 + IX * YA + (IY - IYS) * XA
        CALL GGIP04 (W1, W2, IC)
        IC = 2
      ENDIF
      NR = NR - 1
      IF (NR .GT. 0)  GOTO 60
      ICH = 0
      GOTO 40
   70 RETURN
      END
      SUBROUTINE GGIP09 (IX, IY, IZ, IP)
      COMMON /WINBUF/ BUF
      CHARACTER BUF*132
C     CALL XWIN (IX, IY, IZ, IP, BUF)
      IX = 0
      IY = 0
      IZ = 0
      IP = 0
      RETURN
      END
      SUBROUTINE CTRLCT
      LOGICAL CC
      COMMON /CTRLC/ CC
      CC = .TRUE.
      RETURN
      END
      SUBROUTINE SETUPCC
      EXTERNAL CTRLCT
      EXTERNAL SIGNAL
      INTEGER  SIGNAL
      ISIG = SIGNAL(2, CTRLCT, -1)
      RETURN
      END
      SUBROUTINE GGIP10
      PARAMETER (IPDS = 2, IPME = 4)
      COMMON /CGGIP/ ISW, ISK, IHP, ICAL, IP, SCF, IT,  ISTAT, IMETA,
     1 IHPDP, ITERM, MODE, IXO, IYO, IZO, ITEL, XR, YR, ZR, XOLD, YOLD,
     2 ZOLD, NPO, NAMP, IFLNM, IPCL, IPCLN, LU98, LU99, LPLT, LTERM,
     3 IXM, IYM, JXO, JYO, JZO, INOP, NXY, XMAX, YMAX, SCFJ, JT, JTEL,
     4 NPLOT, IBEEP, ISVPRN, ISVPLT, LU95, LU96, ZFRC, KNM, KXE(6),
     5 KYE(6), METAPL, IPSW, FACTR, KTEL, IXOHI, IXOLO, IYOHI, IYOLO,
     6 IOMETA, IOTERM, IOBEEP, IOHP, IOCAL, IXYOE, IWDO, NRPS, IPSR,
     7 IPSH, IBAW, IPSX, IPSV, IGST, IPCLD, IPSD, IPSN, IPSM, IXVERS,
     8 IDMX, IDMY, IDMZ, NDSCOD(IPDS)
      COMMON /CHGGIP/ KME(6), METAF, VERSIE, DCODE, MCODE,
     1 DSCOD(IPDS), MECOD(IPME), PLEXT(IPME)
      CHARACTER KME*1, METAF*80, VERSIE*6, DCODE*7,
     1 MCODE*7, DSCOD*7, MECOD*7, PLEXT*3
      LOGICAL LOPEN
      IF (NAMP .GT. 0) THEN
        IF (ICAL .GT. 0) THEN
          INQUIRE (UNIT = LU98, OPENED = LOPEN)
          IF (LOPEN) THEN
            CALL GGIP04 (0.0, 0.0, 3)
            IF (IMETA .EQ. 2 .OR. IMETA .EQ. 4) THEN
              WRITE (LU98, 99996)
              IF (IMETA .EQ. 4) WRITE (LU98, 99989)
            ELSE IF (IMETA .EQ. 3) THEN
              CALL GGIP06 (-2)
C * WRITE DEKTEK TRAILER - esc,us,esc,[,?,3,8,l
              CALL GGIP06 (27)
              CALL GGIP06 (31)
              CALL GGIP06 (27)
              CALL GGIP06 (91)
              CALL GGIP06 (63)
              CALL GGIP06 (51)
              CALL GGIP06 (56)
              CALL GGIP06 (108)
              CALL GGIP06 (-2)
            ELSE IF (IMETA .EQ. 1) THEN
              IF (KTEL .GE. 0) THEN
                IF (KTEL .GT. 0) WRITE (LU98, 99992)
     1            (KXE(I), KYE(I), KME(I), I = 1, KTEL)
                WRITE (LU98, 99993) IPSM
                KTEL = -1
              ENDIF
            ENDIF
          ENDIF
        ENDIF
      ENDIF
      RETURN
99996 FORMAT ('PU;SP    0;'/'AF;')
99993 FORMAT (I3,' w s p')
99992 FORMAT (6(2I5,1X,A1))
99989 FORMAT ('PG;')
      END
      SUBROUTINE GGIP20 (THETA, BCDX, NC, HEIGHT, NK, ITHICK, X, Y)
      COMMON /CGG11/ BCD, SBCD
      CHARACTER BCDX*(*), BCD*132, SBCD*132
      COMMON /DGG11/ TH, HT, IE
      TH  = THETA
      HT  = HEIGHT
      IE  = NC
      BCD = BCDX(1:IE)
      XX  = X
      YY  = Y
      ZZ  = 0.0
      IF (NK .GE. 0) CALL GGIP (0.0, FLOAT(NK), 0.0, 0)
      IF (ITHICK .NE. 0) THEN
        CALL GGIP (0.0, - FLOAT(ITHICK), 0.0, 0)
        CALL GGIP (XX, YY, ZZ, 4)
        CALL GGIP (0.0, -1.0, 0.0, 0)
      ELSE
        CALL GGIP (XX, YY, ZZ, 4)
      ENDIF
      IF (NK .GE. 0) CALL GGIP (0.0, 1.0, 0.0, 0)
      RETURN
      END
      SUBROUTINE GGIP30 (FUNVAL, BUFF, XMN, YMN, ZMIN, XMX, YMX, ZMAX,
     1 XCENTR, YCENTR, ZCENTR, XMINP, YMINP, XMAXP, YMAXP, DELTA)
      LOGICAL MOVEUP, PENUP
      DIMENSION XX(2), YY(2), BUFF(*)
      EXTERNAL FUNVAL
      XPROJ(X, Y) = (FXX * (X - XCENTR) + FXY * (Y - YCENTR))
     1  * FACT + XORG
      YPROJ(XCX, YCY, ZCZ) = (FYX * (XCX - XCENTR) + FYY *
     1  (YCY - YCENTR) + FYZ * (ZCZ - ZCENTR)) * FACT + YORG
      PENUP = .TRUE.
      IX    = 0
      JY    = 0
      XL    = 0.0
      YL    = 0.0
      YMNL  = 0.0
      YMXL  = 0.0
      XMIN  = XMN - 0.05 * (XMX - XMN)
      XMAX  = XMX + 0.05 * (XMX - XMN)
      YMIN  = YMN - 0.05 * (YMX - YMN)
      YMAX  = YMX + 0.05 * (YMX - YMN)
      FXY   = (XMIN + XMAX) * 0.5 - XCENTR
      FXX   = (YMIN + YMAX) * 0.5 - YCENTR
      FYY   = (ZMIN + ZMAX) * 0.5 - ZCENTR
      R     = SQRT(FXY * FXY + FXX * FXX + FYY * FYY)
      FXY   = FXY / R
      FXX   = FXX / R
      FYY   = FYY / R
      FYZ   = SQRT(1.0 - FYY * FYY)
      FXX   = FXX / FYZ
      FXY   = - FXY / FYZ
      FYX   = FXY * FYY
      FYY   = - FXX * FYY
      XX(1) = XMIN
      XX(2) = XMAX
      YY(1) = YMIN
      YY(2) = YMAX
      RMIN  = 1.0E+32
      XXMAX = 0.0
      YYMAX = 0.0
      XORG  = 0.0
      YORG  = 0.0
      FACT  = 1.0
      DO 30 I = 1, 2
        DO 20 J = 1, 2
          R = SQRT((XX(I) - XCENTR)**2 + (YY(J) - YCENTR)**2)
          IF (R .GE. RMIN) GOTO 10
          RMIN = R
          IX   = I
          JY   = J
   10     XP   = ABS(XPROJ(XX(I), YY(J)))
          IF (XP .GT. XXMAX) XXMAX = XP
          YP = ABS(YPROJ(XX(I),YY(J),ZMAX))
          IF (YP .GT. YYMAX) YYMAX = YP
   20   CONTINUE
   30 CONTINUE
      FACT = (XMAXP - XMINP) * 0.5 / XXMAX
      XP   = (YMAXP - YMINP) * 0.5 / YYMAX
      IF (XP .LT. FACT) FACT = XP
      XORG = (XMINP + XMAXP) * 0.5
      YORG = (YMINP + YMAXP) * 0.5
      R    = XPROJ(0.0, 0.0)
      X    = XX(IX)
      Y    = YY(JY)
      XINC = DELTA / (XPROJ(1.0, 0.0) - R)
      IXM3 = 3 - IX
      NX   = INT((XX(IXM3) - X) / XINC)
      IF (NX .LT. 0) THEN
        NX   = - NX
        XINC = - XINC
      ENDIF
      YINC = DELTA / (XPROJ(0.0, 1.0) - R)
      JYM3 = 3 - JY
      NY   = INT((YY(JYM3) - Y) / YINC)
      IF (NY .LT. 0) THEN
        NY   = - NY
        YINC = -YINC
      ENDIF
      IF (NX .GE. NY) THEN
        NT = 2 * NY
      ELSE
        NT = 2 * NX
      ENDIF
      IP  = -1
      NNX = 0
      NNY = 0
      IM  = 0
      I   = 0
      IV  = 1
      ID  = 1
      IC  = 1
      MOVEUP = .TRUE.
      GOTO 150
   80 MOVEUP = .FALSE.
   90 IF (NNX .EQ. NX) GOTO 360
      NNX = NNX + 1
      X   = X + XINC
      IC  = 1
      I   = I + 1
      IF (NNY .EQ. 0 .OR. NNX .EQ. NX) GOTO 100
      ID = 3
      GOTO 150
  100 ID = 4
      GOTO 150
  110 NNY = NNY - 1
      Y  = Y - YINC
      IC = 2
      ID = 2
      I  = I + 1
      GOTO 150
  120 IF (NNY .EQ. NY) GOTO 360
      NNY = NNY + 1
      Y   = Y + YINC
      IC  = 1
      I   = I - 1
      IF (NNX .EQ. 0 .OR. NNY .EQ. NY) GOTO 130
      ID = 5
      GOTO 150
  130 ID = 2
      GOTO 150
  140 NNX = NNX - 1
      X   = X - XINC
      IC  = 2
      ID  = 4
      I   = I - 1
  150 IF (NT .EQ. 0) THEN
        IY = 0
      ELSE
        IY = I - (I / NT) * NT
      ENDIF
      IF (IY .LT. 0) IY = IY + NT
      IMIN = IY + NT
      IMAX = IMIN + NT
      IF (IP .GE. I) THEN
        IF (I .LT. IM) GOTO 170
        IF (IC .EQ. 1) THEN
          GOTO 190
        ELSE IF (IC .EQ. 2) THEN
          GOTO 200
        ENDIF
      ELSE
        IP = I
        GOTO 180
      ENDIF
  170 IM = I
  180 FUN   = FUNVAL (X, Y, XMN, XMX, YMN, YMX)
      HULPB = YPROJ(X, Y, FUN)
      BUFF(IMIN + 1) = HULPB
      BUFF(IY + 1)   = HULPB
      BUFF(IMAX + 1) = HULPB
      GOTO 200
  190 FUN          = FUNVAL (X, Y, XMN, XMX, YMN, YMX)
      BUFF(IY + 1) = YPROJ(X, Y, FUN)
  200 XO = XPROJ(X, Y)
      YO = BUFF(IY + 1)
      IF (IV .EQ. 1) THEN
        IF (YO .GE. BUFF(IMAX + 1)) GOTO 300
        GOTO 240
      ELSE IF (IV .EQ. 2) THEN
        IF (YO .GT. BUFF(IMAX + 1)) GOTO 240
        IF (YO .LT. BUFF(IMIN + 1)) GOTO 250
        GOTO 300
      ELSE IF (IV .EQ. 3) THEN
        IF (YO .LE. BUFF(IMIN + 1)) GOTO 300
        GOTO 250
      ENDIF
  240 IV = 3 - IV
      DV = 1.0 / (BUFF(IMAX + 1) - YO - YMXL + YL)
      DV = (YO - BUFF(IMAX + 1)) * DV
      GOTO 260
  250 IV = 5 - IV
      DV = 1.0 / (BUFF(IMIN + 1) - YO - YMNL + YL)
      DV = (YO - BUFF(IMIN + 1)) * DV
  260 HULPX = XO + (XO - XL) * DV
      HULPY = YO + (YO - YL) * DV
      IF (MOVEUP) THEN
        XLOC  = HULPX
        YLOC  = HULPY
        PENUP = .TRUE.
      ELSE
        IF (PENUP) THEN
          CALL GGIP (XLOC,  YLOC,  0.0, 3)
          CALL GGIP (HULPX, HULPY, 0.0, 2)
          PENUP = .FALSE.
        ELSE
          CALL GGIP (HULPX, HULPY, 0.0, 2)
        ENDIF
      ENDIF
      MOVEUP = .NOT. MOVEUP
      IF (IV .EQ. 1 .OR. IV .EQ. 3) GOTO 300
      IF (YO .GT. BUFF(IMAX + 1)) GOTO 240
      IF (YO .LT. BUFF(IMIN + 1)) GOTO 250
  300 IF (MOVEUP) THEN
        XLOC  = XO
        YLOC  = YO
        PENUP = .TRUE.
      ELSE
        IF (PENUP) THEN
          CALL GGIP (XLOC, YLOC, 0.0, 3)
          CALL GGIP (XO, YO, 0.0, 2)
          PENUP = .FALSE.
        ELSE
          CALL GGIP (XO, YO, 0.0, 2)
        ENDIF
      ENDIF
      XL   = XO
      YL   = YO
      YMNL = BUFF(IMIN + 1)
      YMXL = BUFF(IMAX + 1)
      IF (YO .LE. BUFF(IMAX + 1)) GOTO 340
      BUFF(IMAX + 1) = YO
      GOTO 350
  340 IF (YO .LT. BUFF(IMIN + 1)) BUFF(IMIN + 1) = YO
  350 CONTINUE
      IF (ID .EQ. 1) THEN
        GOTO 80
      ELSE IF (ID .EQ. 2) THEN
        GOTO 90
      ELSE IF (ID .EQ. 3) THEN
        GOTO 110
      ELSE IF (ID .EQ. 4) THEN
        GOTO 120
      ELSE IF (ID .EQ. 5) THEN
        GOTO 140
      ENDIF
  360 CALL GGIP (XMAXP, YMINP, 0.0, 3)
      RETURN
      END
      BLOCK DATA DGGIP
      PARAMETER (IPDS = 2, IPME = 4)
      COMMON /CGGIP/ ISW, ISK, IHP, ICAL, IP, SCF, IT,  ISTAT, IMETA,
     1 IHPDP, ITERM, MODE, IXO, IYO, IZO, ITEL, XR, YR, ZR, XOLD, YOLD,
     2 ZOLD, NPO, NAMP, IFLNM, IPCL, IPCLN, LU98, LU99, LPLT, LTERM,
     3 IXM, IYM, JXO, JYO, JZO, INOP, NXY, XMAX, YMAX, SCFJ, JT, JTEL,
     4 NPLOT, IBEEP, ISVPRN, ISVPLT, LU95, LU96, ZFRC, KNM, KXE(6),
     5 KYE(6), METAPL, IPSW, FACTR, KTEL, IXOHI, IXOLO, IYOHI, IYOLO,
     6 IOMETA, IOTERM, IOBEEP, IOHP, IOCAL, IXYOE, IWDO, NRPS, IPSR,
     7 IPSH, IBAW, IPSX, IPSV, IGST, IPCLD, IPSD, IPSN, IPSM, IXVERS,
     8 IDMX, IDMY, IDMZ, NDSCOD(IPDS)
      COMMON /CHGGIP/ KME(6), METAF, VERSIE, DCODE, MCODE,
     1 DSCOD(IPDS), MECOD(IPME), PLEXT(IPME)
      CHARACTER KME*1, METAF*80, VERSIE*6, DCODE*7,
     1 MCODE*7, DSCOD*7, MECOD*7, PLEXT*3
      COMMON /PLCHR/ ADR(91), TAB(195)
      INTEGER ADR, TAB
      LOGICAL CC
      COMMON /CTRLC/ CC
      DATA IWDO / 0/
      DATA CC /.FALSE./
      DATA ADR /0, 9405, 9209, 8411, 7712, 0, 9512, 9804, 7504, 7604,
     1 7111, 6905, 8106, 7002, 8305, 7402, 4709, 4905, 5009, 5213, 5504,
     2 5609, 5812, 6105, 6216, 6612, 8911, 10812, 10203, 8005, 10203,
     3 9911, 10415, 109, 312, 608, 807, 1007, 1206, 1410, 1606, 1806,
     4 2006, 2206, 2403, 2505, 2604, 2710, 2907, 3112, 3410, 3612, 3904,
     5 4006, 4203, 4305, 4405, 4505, 4604, 8704, 10702, 8804, 0, 0, 0,
     6 14211, 14511, 14808, 15011, 15310, 15508, 15714, 16007, 16208,
     7 16406, 16606, 16805, 16910, 17107, 17309, 17511, 17811, 18106,
     8 18310, 18508, 18707, 18903, 19005, 19105, 19211, 19504/
      DATA (TAB(I),I=1,96) /929990,259942400,1964453,470927585,
     1 402653184,645722497,140644352,1964449,402653184,656164612,
     2 8388608,1163527,654311424,645722497,140646611,1853735,536870912,
     3 140576207,520093696,33850913,654311424,1849804,536870912,
     4 117571584,1919456,1968576,496628678,18974822,1964453,470810624,
     5 563737542,18974840,310378496,1964453,470927584,18974819,
     6 472928655,530055168,274495936,117736993,654311424,121794560,
     7 119617063,10453472,122750247,127666176,563737542,18974784,
     8 240976408,85522406,621021184,104724901,473024737,404754432,
     9 410790016,18974819,470841792,53594337,404754831,530055168,
     * 102659152,202117656,562938629,104724901,469762048,18974822,
     1 524050699,462422016,290795747,59506688,290795747,319182021,
     2 553648128,10223616,407201728,138765248,23472348,202697144,
     3 390070272,605257890,138748553,285212672,138482248,76777602,
     4 941940253,419430400,660408320,123535360,153691209,942753101,
     5 201326592,358413688,631109952,273122455,574652482,494498758/
      DATA (TAB(I),I = 97,141) /92274688,494761792,85522406,625815057,
     1 268435456,554586112,25972736,443368138,292170013,219157016,
     2 125829120,138748553,299971852,189530112,307249184,609296384,
     3 307282113,140646620,340262912,307238996,301989888,307299458,
     4 575143936,302138500,541589504,307242018,340262912,306266274,
     5 340262912,302137632,301989888,311445760,536944640,303113234,
     6 608698368,311538372,186909273,543536256,302138516,273172498,
     7 42541056,311445504,301989888,307299456,302654592/
      DATA (TAB(I),I = 142, 195) /559972419,208813604,536870912,
     1 117670092,479073800, 16777216,559972419,208809984,559972419,
     2 208813607,536870912, 40515340, 50628129,137983974,940687360,
     3 990152225,664400838, 70105344,117453596,595591168, 67404825,
     4 940863488,990152225,654311424,117451027,536870912,117736473,
     5  67121939,273533152, 67121948,595591168, 17614627,559972416,
     6 989884815,530204363, 67108864,998406559,253248219,603979776,
     7   1061660,587202560, 18974810,168609571,560005711,940654592,
     8 203752993,612368384, 71450624, 69281316, 75726884,993838299,
     9 614340104, 16777216, 76548096/
      DATA DSCOD /'X11    ', 'TEK4010'/
      DATA MECOD /'PS     ', 'HPGL   ', 'TEK4014', 'HPXL   '/
      DATA PLEXT /'ps ',     'hpl',     'tek',     'hpx'/
C * DEFAULT INTERACTIVE READ  UNIT              : LU95   =  5
C * DEFAULT TEXT    OUTPUT TO UNIT              : LU96   =  6
C * DEFAULT META    OUTPUT TO UNIT              : LU98   = 98
C * DEFAULT DISPLAY OUTPUT TO UNIT              : LU99   =  6
C * DEFAULT GRAPHICS OUTPUT TO TERMINAL SET ON  : IHP    =  1
C * DEFAULT GRAPHICS META-FILE OUTPUT   SET OFF : ICAL   = -1
C * DEFAULT TERMINAL         SWITCH ON TERMINAL : IHPDP  =  1
      DATA VERSIE, IXVERS, LU98, LU99, IDMX, IDMY, IDMZ, IHP, IHPDP,
     1 NPLOT, NAMP, IPSD, IT, ICAL, LPLT, LTERM, ISTAT, ISVPRN, ISVPLT,
     2 METAPL, IBAW, ISW, NRPS, LU95, LU96, IOBEEP, IOHP, IOCAL, IOTERM,
     3 IOMETA, IPSR, IPSH, IPSV, IPSW, IPSM, IPSX, IGST, IPCLD,
     4 IBEEP, ITERM, IMETA/
     5 '100405',  100405, 98, 6, 800, 600, 8, 1, 1, 0, -1, 1, 0, -1,
     6 -1, -1, 1, 0, 0, 0, 0, 900, 0, 5, 6, -1, -9, -9, -1, -1, 0, 0, 0,
     7 0, 9, 1, -1, 1,
C * BEEP                                        : IBEEP
     8  0,
C * TERMINAL DEFAULT SET TO TEK4010 CODE        : ITERM
     9  2,
C * METAFILE DEFAULT SET TO PostScript CODE     : IMETA
     *  1/
      END
  
