C 13 MAR 06 - MN  - OK TO READ RUNTYP OF MEX
C 22 FEB 06 - TN  - LOOK FOR INPUT SETTING UP FMO AND EFP IN SAME RUN
C 17 JAN 06 - MWS - READ CR-CCL COUPLED CLUSTER OPTION
C 14 NOV 05 - CMA,DGF - KILL MOPAC+CORRELATION RUNS, BASIS SET OUTPUT
C 19 SEP 05 - MK  - MCP BASIS SET CHANGES
C 19 SEP 05 - GDF - READ H+I FUNCTIONS
C 19 SEP 05 - SPW - ATOMS,START: ADD NEO HOOKS
C  5 JUL 05 - MWS - SELECT NEW ATOM,BASIS,EFP,PCM,DAF DIMENSIONS
C  1 JUN 05 - MWS,BSD - REMOVE TRAP ON ZAPT GRADIENT, VB2000 INTERFACE
C 30 APR 05 - DGF - ADD NODEXT TO $SYSTEM, PROPER MOLECULAR STATES
C  7 MAR 05 - IA  - FIX COMMON BLOCK FRGINF
C 22 FEB 05 - MWS - ENSURE MDTYP IS INITIALIZED TO BLANKS
C 13 FEB 05 - DMC - START: READ SVP MODEL'S INPUT DATA
C 13 FEB 05 - HMN - START: ADD DIVISION OF FRAGS FOR PARALLEL EFP
C  5 FEB 05 - FRJ - INPUTA: ADD PCN BASIS SETS
C 10 NOV 04 - MWS - ADD QUADRUPLES KEYWORDS
C  7 SEP 04 - MWS - CHANGE INTTYP KEYWORD VALUES
C 23 JUL 04 - DGF - 4 PATCHES FOR FMO AND GDDI
C  3 JUN 04 - MWS - FIX PRINTOUT OF MEMORY/NODE VALUES
C 19 MAY 04 - DGF - CHANGES TO ADD THE FMO METHOD
C 19 MAY 04 - GDF,RMO,DGF,MWS - DEFAULT LOAD BALANCE CHANGED TO NXTVAL
C  7 APR 04 - MWS - START: FIX CHECK RUN DDI MEMORY ALLOCATION
C 12 DEC 03 - OQ  - START: EXTENDED TDHF RUN TYPE KEYWORD
C  5 NOV 03 - MWS - START: ALLOW NMR RUNS
C  3 SEP 03 - SPW - START: CALL TO CISINP TO ALLOW FOR CIS INPUT
C 12 AUG 03 - KRG,GNM - MORE MULT CHECKS, EQUIV. CENTER TEST 1D-6->1D-12
C  3 JUL 03 - JMM - SUPPRESS PRINTING FOR MONTE CARLO JOBS
C 16 JUN 03 - HL  - START: CALL TESIN AND PCMGIN FOR PCM
C 15 MAY 03 - MWS - ENABLE CALL TO EOM CODES
C 26 MAR 03 - MWS - START: KILL TRUDGE/NOSYM=1 COMBINATIONS
C 14 JAN 03 - JI  - PERMIT CITYP OF ORMAS
C  7 AUG 02 - JHJ - READ $STATPT FOR VSCF TO KNOW IFREEZ
C 20 JUN 02 - MWS - START: MORE TRAPPING OF BAD MOPAC INPUT
C 22 MAY 02 - MWS - PASS USING OF CARTESIAN COORDS TO Z-MATRIX READER
C 17 APR 02 - MWS - SYNCH UP FRGINF COMMON
C 26 MAR 02 - MWS - START: ALLOW FOR CCTYP INPUT
C 16 FEB 02 - JI  - START: ALLOW FSOCI CITYP INPUT
C 24 JAN 02 - BTA - START: REMOVE MP2 AIMPAC ABORT
C 25 OCT 01 - MWS - ATOMS: FIX EXTERNAL BASIS SET FOR PARALLEL RUNS
C 22 OCT 01 - MK  - ATOMS, START: MODEL CORE POTENTIAL INTERFACING
C  6 SEP 01 - HU  - START: ALLOW MCSCF PARALLEL MP2 JOBS TO PROCEED
C 25 JUN 01 - MWS - ALTER COMMON BLOCK SCFOPT AND WFNOPT
C 20 JUN 01 - DGF - START: UNCONTR. RESC, AND RUN TYPE SURFACE CHANGES
C 20 FEB 01 - RKC - ATOMS: SMALL MODIFICATION FOR SPARKLES
C 19 NOV 00 - MWS - START: GENERATE NORMALIZED CXINP COEFS
C 16 NOV 00 - HL  - START: PARTIAL HESSIAN IF IFREEZ(I) IN $STATPT
C 11 OCT 00 - PB  - INTERFACING OF EFP+PCM
C 15 AUG 00 - MWS - START,SYSINP: MEMDDI IN MWORDS IF TOTAL, BASIS PRINT
C 11 JUN 00 - GNM - ATOMS: READ EXTERNAL BASIS FILE OPTION
C  1 MAY 00 - MWS - START: PERMIT RAMAN RUNTYP
C 25 MAR 00 - KKB/LNB - CHECK FOR $COSMO INPUT GROUP
C 10 JAN 00 - DGF - FINISH ADDING NESC (RELATIVISTIC METHOD OF K. DYALL)
C 21 DEC 99 - TN,DGF - RESC, ATOMS: DON'T NORMALIZE AO-S IF RELATIVISTIC
C 25 OCT 99 - MWS - START: CALL TO SPDTR ADDED
C 29 AUG 99 - CHC - START: USER FRIENDLY INPUT FOR TINKER QMMM
C  6 JUN 99 - MWS - START: CHANGE ARGUMENTS TO DDI-MEMORY
C  9 APR 99 - MWS - SYSINP: OBTAIN INPUT REQUEST FOR DISTRIBUTED MEMORY
C 13 MAR 99 - KRG - START: READ $DFT INPUT GROUP
C 13 FEB 99 - AY  - ATOMS: CHANGE CALL TO N31G, FOR D COEFS
C 31 DEC 98 - MAF - START: READ QMTTOL INPUT VALUE
C  2 DEC 98 - MWS - START: ASK IF HESSIANS ARE USED IN GEOM SEARCH
C 12 NOV 98 - GDF - ATOMS: DELETE ISOIN USAGE
C 27 OCT 98 - MAF - START: ADD ISPHER OPTION TO $CONTRL
C  6 MAY 98 - MWS - START: TRAP ILLEGAL SEMIEMPIRICAL OR PROP JOBS
C 27 FEB 98 - MWS - START: ALLOW CI TYPE OF ALDET.
C  6 JAN 98 - JAB - ADD A VARIABLE TO ZMAT COMMON BLOCK
C  1 OCT 97 - MWS - START: CALL TO MIINP OPTION
C 16 JUL 97 - GNM - START: CHANGES FOR COORD=FRAGONLY OPTION
C 18 MAR 97 - MWS - START: READ POSSIBLE $PCM INPUT GROUP
C 21 FEB 97 - MWS - START: ALLOW UHF/ROHF PARALLEL MP2 JOBS TO PROCEED
C 18 DEC 96 - JHJ - START: CHANGES REGARDING MAKEFP
C 13 NOV 96 - DGF - ATOMS: ALLOW GVB MOPAC RUNS TO PROCEED
C 30 OCT 96 - HN  - START: CHANGES FOR MCSCF+MP2
C 29 SEP 96 - MWS - START: READ $TRANS AFTER $SCF
C 13 JUN 96 - VAG - START: READ NEW KEWORD CITYP
C  5 MAR 96 - MWS - CHANGE SHELL SYMMETRY PACKING COMMONS
C 15 NOV 95 - FRJ - START: ADD GRADEXTR AS A NEW RUNTYP
C 28 SEP 95 - MWS - START: CALL NEW ROUTINT MCIN
C 14 SEP 95 - SPW - START: ADD CALL TO LMOINP
C  6 SEP 95 - JS  - ATOMS: MAKE RMLDMP ARRAY DYNAMIC
C 31 MAY 95 - MWS - START: INITIALIZE IHESSM HESSIAN TYPE VARIABLE
C 21 APR 95 - MWS - ATOMS: CHANGE CALL TO HWBAS
C  1 FEB 95 - WC,RPM - START: ADD RUN TYPES OF MOROKUMA AND SURFACE
C 29 DEC 94 - TLW - START: ADD CALL TO EFIELD INPUT
C 11 NOV 94 - MWS - REMOVE FTNCHEK WARNINGS
C  2 NOV 94 - TT  - START: PERMIT RUN TYPE OF DRC
C 10 AUG 94 - MWS - INCREASE NUMBER OF DAF RECORDS
C  1 AUG 94 - MWS - START: RECOGNIZE THE TDHF RUN TYPE
C 19 JUL 94 - BMB - START: DON'T GENERATE ERROR FUNCTION TABLE
C  1 JUN 94 - MWS - START: PERMIT PARALLEL CI TO PROCEED
C 31 MAR 94 - MWS - START,SYSINP: CHANGES FOR MODERN MP2 CODE, XDR
C  3 DEC 93 - TLW - START: USE TRFIN TO READ TRANSFORM. INFO EARLY
C 29 OCT 93 - MWS - REMOVE UNDOC. MEM/KDIAG/TIM FROM $CONTRL GROUP
C 22 SEP 93 - MWS - ATOMS: USE FORMAT STATEMENTS FOR FRIEND OUTPUT
C 16 JUL 93 - MWS - INCREASE MAXIMUM CI ROOTS TO 100
C 11 JUN 93 - BMB - ATOMS: ADDED CFINP TO SBKBAS CALL FOR LANTHANIDES
C 18 MAR 93 - JHJ - FILL MOPAC PARAMETERS ONLY ONCE
C 12 NOV 92 - MK  - INTERFACES FOR MELDF, HONDO, GAUSSIAN, GAMESS-UK
C  9 NOV 92 - MWS - REWORK INPUT TESTS TO ENABLE ROHF+MP2 RUNS
C 16 SEP 92 - MWS - START: READ UNDOCUMENTED VARIABLE -NOSO- TO TURN
C                   OFF USE OF SYMMETRY ORBITAL CODE.
C 15 JUN 92 - MWS - MOVE INTR CALL INTO ATOMS
C 28 APR 92 - MWS - START: RUNTYP CAN BE FFIELD
C  2 APR 92 - MWS,TLW - COMMON ENRGYS MADE PURE FLOATING POINT
C 17 MAR 92 - MWS - COMPUTE ELECTRON COUNT FOR MOPAC CASE
C 12 MAR 92 - MWS - REDIMENSION TO 500 ATOMS, ESP. IN READAT
C 12 MAR 92 - TLW - CREATE SUBROUTINE SYSINP
C 10 MAR 92 - MWS - START: MAKE SURE MOPAC RUNS ARE SENSIBLE
C 24 FEB 92 - MWS - START: ADD CALL TO MICHEL'S SYMORB, SYMMOL COMMON
C 17 FEB 92 - JHJ - ATOMS:"CORRECT" NRE CALCULATED FIRST.
C  6 FEB 92 - JHJ - ATOMS: READ MOPAC HAMILTONIANS.
C 30 JAN 92 - TLW - ATOMS,READAT: FIX INTERNAL READS
C 11 JAN 92 - TLW - ATOMS,READAT: MAKE READS PARALLEL
C 10 JAN 92 - TLW - ATOMS,READAT,START: ABRT USED TO TERMINATE
C  6 JAN 92 - TLW - MAKE WRITES PARALLEL;ADD COMMON PAR
C 11 DEC 91 - MWS - KILL JOB IF MORE THAN 50 ATOMS GENERATED.
C  6 DEC 91 - MWS - START: DELETE CALL TO LMOINP.
C 26 NOV 91 - DRG,JHJ - START:CALL TO ZRFINP, EFINP AFTER ECPPAR.
C 23 OCT 91 - NM  - ABORT IF DIRECT SCF AND MP2 IN THE SAME RUN
C 18 OCT 91 - NM  - MAKE NO-ABORT FOR UMP2 RUN
C 11 OCT 91 - MWS - START: CALL NEW ROUTINE TO READ $INTGRL INPUT
C 15 AUG 91 - MWS - READ POP AS A LOCALIZATION OPTION
C 17 JUL 91 - JHJ - START:ADD CALL TO ZRFINP (ZERNER REACTION FIELD).
C 10 JUL 91 - JHJ - START:ADD IUNTRD TO EFINP CALL.
C  2 JUL 91 - MWS - CHANGE CALL TO MINI/MIDI BASIS LIBRARY
C 18 JUN 91 - JHJ - START:ADD CALL TO EFINP (EFFECTIVE FRAGMENTS).
C 11 JUN 91 - MWS - CHANGE CALL FOR SBKJC BASIS, STORE SP BASIS NAME.
C  9 APR 91 - MR  - NARROWER BASIS SET OUTPUT
C  2 APR 91 - MWS - READAT: CC NEEDS TO BE IN ANGSTROMS, ALWAYS
C 27 MAR 91 - MWS - READ RUEDENBERG LOCALIZATION AS AN OPTION.
C 28 FEB 91 - JAB - READAT: FIX HINT UNITS CONVERSION
C 29 JAN 91 - TLW - START:CHANGED COMMON DIAGSW TO MACHSW
C                   ADD COREFL TO $CONTRL
C  9 NOV 90 - JHJ - START,ATOMS: COORD ADDED TO $CONTRL, READ Z-MATS
C  5 OCT 90 - MWS - START: MOVE MOLPLT+PLTORB PUNCHING TO MAIN PROG
C 29 AUG 90 - MK  - NEGATIVE NUCLEAR CHARGES LOOK UP BASIS SETS FOR BSSE
C 10 AUG 90 - TLW - MADE K SHELLS EQUAL TO S SHELLS
C  7 AUG 90 - TLW - ADD CF AND CG TO COMMON NSHEL.
C                   ATOMS: ADDED F AND G CAPABILITIES
C 25 JUL 90 - MWS - ADD RPAC VARIABLE TO $CONTRL GROUP
C 13 JUN 90 - MWS - FIX PUNCHOUT OF INTERNALLY STORED POLARIZATION
C 12 MAY 90 - MWS - SIMPLIFY STYLE OF BASIS SET INPUT, WHILE STILL
C                   READING OLD INPUTS.  SPLIT INTO INPUTA, INPUTB
C 17 APR 90 - JHJ - ATOMS,PTGRP:MADE $DATA FREE FORMAT
C  4 APR 90 - JHJ - BASISS: ACCOMODATED FOR MK'S CHANGES.
C 30 MAR 90 - JHJ - BASISS: INTRODUCED IN ITS ORIGINAL FORM.
C                   ATOMS: INFORMATION FROM $BASIS IS FED IN.
C 14 MAR 90 - MK  - NEW BASIS SET CODES: DZV(=DH), DZP, TZV(=MC IN
C                   SOME CASES PLUS MORE), TZP
C  8 MAR 90 - MWS - ADD MOLMEM,MOLPLT TO PUNCH MOLPLT INPUT FILE.
C                   SETLAB CAN RETURN CHEMICAL SYMBOL.
C  6 FEB 90 - MWS - ADD PLTMEM,PLTORB TO PUNCH PLTORB INPUT FILE.
C 23 JAN 90 - MWS - ATOMS: PRINT NON-UNIT NORMALIZATION FACTORS
C 22 JAN 90 - MWS - START: REMOVE INITIALIZATION OF /MACHIN/
C 29 NOV 89 - KAN,MWS - START: ADD ECP TO $CONTRL, CALL TO ECPPAR,
C                   ATOMS: CALLS TO SBKBAS AND HWBAS
C 25 SEP 89 - MWS - ADD AIMPAC TO $CONTROL INPUT
C 22 SEP 89 - MWS - CHANGE ANGSTROMS-BOHR CONVERSION FACTOR
C  9 AUG 89 - MWS - ATOMS: ZERO 9008 DATA BEFORE READ("FEATURE" OF AIX)
C  5 AUG 89 - MWS - ADD MEMORY TO $CONTRL, CALL SETFM FROM START
C 21 MAR 89 - MWS - CHANGE MESSAGE ABOUT GROUPS USED BY MP2 RUNS
C 27 FEB 89 - STE - ATOMS: REWORK CONTRACTION NORMALIZATION
C 30 JAN 89 - MWS - ADD MPLEVL TO $CONTRL, MP2INP CALLED FROM START
C                   FILL NEW COMMON /MASSES/ FROM START,
C                   DETERMINE IF LINEAR MOLECULE FROM START.
C 15 JAN 89 - MWS - REMOVE OPTOL,NHOPT(IOPTRD) FROM $CONTRL INPUT
C 17 DEC 88 - MWS - INTRODUCE /SYMSHL/ TO ATOMS, /SYMSPD/ TO SPDTR
C 11 DEC 88 - MWS - ISO RECORD ON DAF SHOULD HAVE LENGTH MXSH*12
C 17 NOV 88 - MWS - ADD SCHWRZ TO $INTGRL, AND COMMON /INTOPT/
C 11 AUG 88 - JAB - DELAY CALL OF ZMATIN IF RUNTYP=FORCE, NHOPT=1
C 10 AUG 88 - MWS - MXSH,MXGSH,MXGTOT FROM 120,10,440 TO 1000,30,5000
C 30 JUN 88 - MR  - CORRECT STOSF N=5 CALLS
C 30 MAY 88 - MWS - USE PARAMETERS TO DIMENSION COMMONS
C 13 MAY 88 - MWS - REMOVE CALL TO SPCHCK IN START
C  8 MAY 88 - MWS - UP AO-S LIMIT FROM 255 TO 2047
C 22 APR 88 - MWS - DELETE SCFWFN FROM ROUTINE START
C  2 APR 88 - MWS - UP AO LIMIT FROM 254 TO 255, DON'T CALL GUESMO,
C                   REMOVE IOVLP INPUT, AND ROUTINE PUOVLP
C 27 MAR 88 - MWS - CHANGE KDIAG DEFAULT TO 0
C 27 JAN 88 - MWS - TIGHTEN ATOM UNIQUENESS CRITERION (ATTOL WAS 1D-10)
C 14 NOV 87 - STE - BOYIN DETERMINES VALUE OF TLOCAL, SCFIN TO SCFLIB
C  6 NOV 87 - STE - CALL FORCIN MOVED TO FORCX
C  1 NOV 87 - STE - EXETYP IN $INTGRL, FIX TYPINT
C 19 JUL 87 - MWS - RENAME $INTGRL NOCORE VARIABLE TO NOMEM (STE)
C 12 FEB 87 - MWS - REPLACE MSREAD/MSWRIT WITH DAREAD/DAWRIT
C  3 NOV 86 - STE - PTGRP: USE /FRAMES/; USE PARAMETERS
C 13 OCT 86 - JAB - CHANGE R*8 TO DOUBLE PRECISION
C 30 JUL 86 - MWS - PAD COMMON ENRGYS, ALTER ITS DAF TREATMENT
C 11 JUL 86 - MWS - SANITIZE FLOATING POINT CONSTANTS,
C                   USE INTERNAL FILE IN SETLAB
C 25 JUN 86 - LAM - CREATE GEOM IN $CONTRL, FIX BUG FOR MCONV IN SCFIN
C                   LET IREST.LT.0 FOR MOSAVED WITH NEW GEOM IN START
C 20 JUN 86 - MWS - SKIP WRITING SCFWFN COMMON ONTO DICTIONARY FILE
C 17 JUN 86 - MWS - REMOVE NVIB,VIBSIZ FROM $CONTRL, CALL
C                   FORCIN INSTEAD, DELETE /FOROPT/ IN START
C 28 APR 86 - LAM - CHANGE $SCF IN SCFIN TO HANDLE DIIS
C 21 MAR 86 - LAM - INITIALIZE MINF TO 1,1,2,1 IN ATOMS
C 14 MAR 86 - LAM - CHANGE DEFAULT OF MAXREC TO 4700 IN START
C  8 JAN 86 - STE - MODIFY COMMON RUNOPT IN START TO COUNT WFN CALLS
C  6 NOV 85 - STE - SCFIN: CLEANUP MAXFM DEFINITION
C  1 NOV 85 - STE - READAT: DEFINE TWO;$CONTRL KILL POLAR,BASIS,IPTOPT
C                   USE GENERIC ABS,ACOS,COS,SIN,SQRT; ADD ATOMSS
C                   DELETE MACHIN FROM SPDTR ; INITIAL NVAR IN START
C 28 OCT 85 - LAM - ADD /RECMAX/MAXREC(DEF 5000) TO $INTGRL IN START
C 22 OCT 85 - LAM - DEFAULT NINTMX TO 2725 IF PANDK .F., 1635 IF .T.
C  5 AUG 85 - MWS - CHANGE CALL TO INITIAL ORBITAL GUESS
C 30 JUL 85 - MWS - CHANGES IN ATOMS FOR N-21G IMPROVEMENTS
C 10 JUL 85 - MWS - CHANGE DATA STATEMENT TO HOLLERITH
C 21 JUN 85 - MWS - PASS ALL SCALE FACTOR INPUT TO HUZINAGA BASES
C 11 JUN 85 - MWS - DELETE ROUTINES DENSIN,GRID,GRIDIN, CALL PROPIN
C 23 MAY 85 - MWS - IMPLEMENT THE HUZINAGA MINI/MIDI BASIS SETS
C 16 APR 85 - MWS - IMPLEMENT THE 6-311G BASIS
C 12 APR 85 - MWS - IMPLEMENT MCLEAN/CHANDLER BASES, CHANGE NAMES
C                   OF DUNNING/HAY BASIS ROUTINES AND INPUT.
C 10 APR 85 - MWS - EXTENSIVE CHANGES IN ATOMS. M SHELL CHANGED TO
C                   MEAN SPD SHELL. PROVISIONS ARE MADE TO ALLOW
C                   INPUT OF F, M, AND N TYPE SHELLS. NOTE THAT THESE
C                   HAVE SERIOUS CONSEQUENCES IN THE INTEGRAL PACKAGE,
C                   AND SO THESE ARE NOT FULLY IMPLEMENTED HERE.
C                   STO-NG AND N-31G SCALE FACTORS CHANGED FROM DATA
C                   STATEMENTS TO FUNCTIONS. 4TH AND 5TH ROW MINIMAL
C                   STO-NG BASES ARE NOW IMPLEMENTED HERE.
C 17 MAR 85 - MWS - ONLY 32 ARGS TO NAMEIO CALL FOR $INTGRL,
C                   CALL RASIZE TO GET DIRECT ACCESS LENGTH
C 19 FEB 85 - MWS - ADD JERRY'S PUOVLP, MOVE BOYIN TO BOYLOC SECTION
C 22 AUG 84 - STE - INCLUDE NEW ROUTINES DENSIN,GRIDIN CALLED BY START
C                   REMOVE UNUSED MSREAD/WRIT PARM IN ATOMS,MOLE
C 21 AUG 84 - MWS - IN INPUT:  NEW STO-NG SCALE FACTORS FOR 3RD ROW;
C                   CHECK AGREEMENT BETWEEN NO. E- AND MULTIPLICITY
C  3 MAY 84 - STE - CHANGE ENERGY DATA DICTIONARY RECORD 2 IN ATOMS
C                   DELETE CALL EXIT IN BERROR
C 24 MAR 84 - STE - FIX INTEGRAL FILE LRECL IN START, MOVE OPENDA
C 18 JAN 84 - STE - SHORTEN BFLAB IN MOLE
C 29 DEC 83 - STE - OPEN PK FILE IF NEEDED IN START
C 20 DEC 83 - STE - DYNAMIC INTEGRAL BUFFERS
C 15 DEC 83 - STE - MOVE $INTGRL TO START, OPEN IS AND IPK IN START
C 14 DEC 83 - STE - MERGE /DMPTST/ INTO /DMPING/, INITIALIZE SHIFTO/V
C  3 DEC 83 - STE - INITIALIZE NZMAT TO 0 IN START
C 21 NOV 83 - STE - MOVE DEFINITIONS OF LOGICAL UNITS 7,8,9 TO MAIN
C 18 NOV 83 - STE - FPS PACKING IN SETLAB, INTEGER HOLL. TO REAL
C  7 NOV 83 - STE - MOVE GAMESS VERSION BANNER TO MAIN ROUTINE
C  3 NOV 83 - STE - IBM ACOS = DARCOS, ZMATPR TO PZANDG
C                   DELETE CALLS TO SETFM AND SYMORB IN START
C  8 JUL 83 - MWS - FIX TYPO IN READING HONDO INTERNALS
C  6 JUL 83 - MWS - NEW N-31G SCALE FACTORS, NEW DATE IN BOX,
C                   SHIFTV,SHIFTO IN $SCF INPUT
C MAR 22 83 - MWS - WRITE ENUC ON DAF, CHANGE DATE IN BOX
C MAR  7 83 - MWS - SPLIT OUT ZMAT ROUTINES, CHANGE DATE IN BOX
C FEB  3 83 - MWS - FIX BUG IN TORS, CHANGE DATE IN BOX
C DEC 14 82 - MWS - MOVE CALL TO TIMIT, CHANGE DATE IN BOX
C NOV 24 82 - MWS - TIME LIMIT INPUT IN MINUTES, DEFAULT=10HR
C NOV  2 82 - MWS - PAGE EJECT BEFORE TRADEMARK BOX
C OCT 30 82 - MWS - IMPROVE PUNCH OUTPUT, TIME INITIALIZE
C                   TAKEN OUT OF ROUTINE START
C OCT 24 82 - MWS - ADD NDSU VERSION TO TRADEMARK BOX
C OCT 21 82 - MWS - PROVIDE ENOUGH ARGUMENTS FOR NAMEIO
C  8 OCT 82 - MWS,NDSU - CONVERT TO IBM
C 20 JUN 82 - MWS - PUT IN REWIND BEFORE READING $DATA
C
C*MODULE INPUTA  *DECK ATOMS
      SUBROUTINE ATOMS(IUNTRD,CSINP,CPINP,CDINP,CFINP,CGINP,
     *                 CHINP,CIINP,RMLDMP,
     *                 MAXGSH,MAXATM,MAXGAU,ICOORD,RELNORM)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DOUBLE PRECISION MCP_DZP, MCP_TZP, MCP_QZP
      DOUBLE PRECISION IMCP_NR1, IMCP_NR2, IMCP_SR1, IMCP_SR2
C
      LOGICAL MIDI,NEWWAY,STOTYP,GENTYP,RELNORM
      LOGICAL GOPARR,DSKWRK,MASWRK,ISGDDI,PAROUT
      LOGICAL AIMPAC,PLTORB,MOLPLT,RPAC,FRNDLY
      LOGICAL ELEMENT,SPRKLE
C
      EXTERNAL REREAD
C
      PARAMETER (MXSH=5000, MXGSH=30, MXGTOT=20000, MXAO=8192,
     *           MXATM=2000, MXRT=100)
      PARAMETER ( MAXA=103, MAXL=7, MXUNIT=299)
C
      CHARACTER*10 ATOMNM,ENDWRD,UATOM
      CHARACTER*8 CTYPE,CBASIS,MLDLAB,BASSTR,STR8
      CHARACTER*4 ATMSYM(MXATM)
      CHARACTER*256 BASPTH,ENVBUF
      CHARACTER*4 STR4
      CHARACTER*1 NULL
C
      DOUBLE PRECISION LINE,LINEV,LETK,LABEL(27)
C
      DIMENSION CSINP(MAXGAU),CPINP(MAXGAU),CDINP(MAXGAU),
     *          CFINP(MAXGAU),CGINP(MAXGAU),CHINP(MAXGAU),
     *          CIINP(MAXGAU),RMLDMP(MAXGSH,5,MAXATM)
      DIMENSION SKIPS(20),INTYP(MXSH),NS(MXATM),KS(MXATM),
     *          EXX(6),CSS(6),CPP(6),CDD(6),SCFAC(4),
     *          NBFS(27),MINF(27),MAXF(27),NANGM(27)
      DIMENSION XMELD(40), SMELD(40), PMELD(40), MELDIX(5)
C
      COMMON /BASISC/ GBASIS,AEX(MAXA,MAXL),ABASIS(MAXA,MAXL),
     *                IAGAUS(MAXA,MAXL),IRDBAS
      COMMON /BASSPH/ QMTTOL,ISPHER
      COMMON /CIFILS/ NFT11,NFT12,NFT13,NFT14,NFT15,NFT16,IDAF20,NEMEMX
      COMMON /COORDN/ UZNUC(MXATM),CUNIQ(MXATM,3),NATREL,UATOM(MXATM)
      COMMON /CORE  / CORE(107)
      COMMON /ENRGYS/ ENUCR,EELCT,ETOT,SZ,SZZ,ECORE,ESCF,EERD,E1,E2,
     *                VEN,VEE,EPOT,EKIN,ESTATE(MXRT),STATN,EDFT(2)
      COMMON /ENVIR/  ENVBUF(MXUNIT)
      COMMON /FMOINF/ NFG,NLAYER,NATFMO,NBDFG,NAOTYP,NBODY
      COMMON /GDDI/   ISCOPE,NGROUPS,MYGROUP,MEGLOB,NPGLOB,NNGLOB,JBTYP,
     *                ISGDDI,PAROUT
      COMMON /GEOMOP/ GEOM
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /INTNAL/ BOND(MXATM),ALPHA(MXATM),BETA(MXATM),SIGN(MXATM),
     *                ICONX(MXATM),IATCON(3,MXATM),INATOM(MXATM),
     *                NATIN,IUNT
      COMMON /INTOPT/ ISCHWZ,IECP,NECP,IEXTFLD
      COMMON /INTRFC/ FRIEND,AIMPAC,RPAC,PLTORB,MOLPLT
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /MASSES/ ZMASS(MXATM)
      COMMON /MMPDOC/ MPTYP(MXATM)
      COMMON /NEOJOB/ NEORUN,NELERM
      COMMON /NEOSHL/ NGAUSS,NGAUSE,NGAUSN,NTSHEL,NNUCSH
      COMMON /NSHEL / EX(MXGTOT),CS(MXGTOT),CP(MXGTOT),CD(MXGTOT),
     *                CF(MXGTOT),CG(MXGTOT),CH(MXGTOT),CI(MXGTOT),
     *                KSTART(MXSH),KATOM(MXSH),KTYPE(MXSH),KNG(MXSH),
     *                KLOC(MXSH),KMIN(MXSH),KMAX(MXSH),NSHELL
      COMMON /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /RESTAR/ TIMLIM,IREST,NREC,INTLOC,IST,JST,KST,LST
      COMMON /RUNLAB/ TITLE(10),A(MXATM),B(MXATM),BFLAB(MXAO)
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      COMMON /SYMTRY/ MAPSHL(MXSH,48),MAPCTR(MXATM,48),
     *                T(432),INVT(48),NT
      COMMON /TRANSF/ XSMAL,YSMAL,ZSMAL,XNEW,YNEW,ZNEW,XP,YP,ZP
      COMMON /WFNOPT/ SCFTYP,CITYP,DFTYPE,CCTYP,MPLEVL,MPCTYP
C
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00, HALF=0.5D+00, TWO=2.0D+00,
     *           PT75=0.75D+00, PT187=1.875D+00, PT6562=6.5625D+00,
     *           PT2953=29.53125D+00, PT1624=162.421875D+00,
     *           UNITS = ONE/0.52917724924D+00,
     *           TM6=1.0D-06, TM10=1.0D-10)
C
      DATA BASMMP       /8HMCP     /
      DATA BASMD3,BASMND/8HMINDO   ,8HMNDO    /
      DATA BASAM1,BASPM3/8HAM1     ,8HPM3     /
      DATA BASSTO,BASN31,BASN21/8HSTO     ,8HN31     ,8HN21     /
      DATA BASDH, BASBC /8HDH      ,8HBC      /
      DATA BASMC, BAS311/8HMC      ,8HN311    /
      DATA BASDZV,BASTZV/8HDZV     ,8HTZV     /
      DATA BASMIN,BASMID/8HMINI    ,8HMIDI    /
      DATA BASSBK,BASSB2,BASHW /8HSBKJC     ,8HSBK     ,8HHW      /
      DATA BASPC0,BASPC1,BASPC2/8HPC0       ,8HPC1     ,8HPC2     /
      DATA BASPC3,BASPC4/8HPC3     ,8HPC4     /
      DATA BAAPC0,BAAPC1,BAAPC2/8HAPC0      ,8HAPC1    ,8HAPC2    /
      DATA BAAPC3,BAAPC4/8HAPC3    ,8HAPC4    /
      DATA BASCCD,BASCCT,BASCCQ/8HCCD       ,8HCCT     ,8HCCQ     /
      DATA BASCC5,BASCC6/8HCC5     ,8HCC6     /
      DATA BASACD,BASACT,BASACQ/8HACCD      ,8HACCT    ,8HACCQ    /
      DATA BASAC5,BASAC6/8HACC5    ,8HACC6    /
      DATA BACCCD,BACCCT,BACCCQ/8HCCDC      ,8HCCTC    ,8HCCQC    /
      DATA BACCC5,BACCC6/8HCC5C    ,8HCC6C    /
      DATA BACACD,BACACT,BACACQ/8HACCDC     ,8HACCTC   ,8HACCQC   /
      DATA BACAC5,BACAC6/8HACC5C   ,8HACC6C   /
      DATA MCP_DZP, MCP_TZP, MCP_QZP/8HMCP-DZP ,8HMCP-TZP ,8HMCP-QZP /
      DATA IMCP_NR1, IMCP_NR2, IMCP_SR1, IMCP_SR2
     +   /8HIMCP-NR1, 8HIMCP-NR2, 8HIMCP-SR1, 8HIMCP-SR2/
C
      DATA SKIPS/8H1       ,8H2       ,8H3       ,8H4       ,
     *           8H5       ,8H6       ,8H7       ,8H8       ,
     *           8H9       ,8H10      ,8H11      ,8H12      ,
     *           8H13      ,8H14      ,8H15      ,8H16      ,
     *           8H17      ,8H18      ,8H19      ,8H20      /
      DATA SV/8HSV      /
      DATA BLANK/8H        /
      DATA RHF,UHF,ROHF,GVB/8HRHF     ,8HUHF     ,8HROHF    ,8HGVB     /
      DATA SPLAB/8HSP      /
      DATA FRNDLY/.FALSE./
      DATA NONE/4HNONE/
      DATA KMINDO,KMNDO,KAM1,KPM3/4HMIND,4HMNDO,4HAM1 ,4HPM3 /
C
C           THIS ROUTINE IS PARTIALLY SET TO READ M AND N SHELLS,
C           BUT THESE ARE NOT IMPLEMETED IN THE INTEGRAL PACKAGE.
C
      DATA LETK/8HK       /
      DATA LABEL/8HS       ,8HP       ,8HD       ,8HF       ,
     *           8HG       ,8HH       ,8HI       ,8HL       ,
     *           8H1S      ,8H2S      ,8H2P      ,8H2SP     ,
     *           8H3S      ,8H3P      ,8H3D      ,8H3SP     ,8H3SPD    ,
     *           8H4S      ,8H4P      ,8H4D      ,8H4SP     ,8H4SPD    ,
     *           8H5S      ,8H5P      ,8H5D      ,8H5SP     ,8H5SPD    /
C
      DATA NBFS/ 1, 3, 6,10,15,21,28,    4,
     *           1, 1, 3, 4,             1, 3, 6, 4,10,
     *           1, 3, 6, 4,10,          1, 3, 6, 4,10/
      DATA MINF/ 1, 2, 5,11,21,36,57,    1,
     *           1, 1, 2, 1,             1, 2, 5, 1, 1,
     *           1, 2, 5, 1, 1,          1, 2, 5, 1, 1/
      DATA MAXF/ 1, 4,10,20,35,56,84,    4,
     *           1, 1, 4, 4,             1, 4,10, 4,10,
     *           1, 4,10, 4,10,          1, 4,10, 4,10/
      DATA NANGM/1, 2, 3, 4, 5, 6, 7,    2,
     *           1, 1, 2, 2,             1, 2, 3, 2, 3,
     *           1, 2, 3, 2, 3,          1, 2, 3, 2, 3/
C
      DATA LINE,LINEV /8H * * * *,8H       */
      DATA ENDWRD /'$END      '/
      DATA DAF/8HDAF     /
      DATA AMEX/8HMEX     /
C
      IERR1=0
      IERR2=0
C
      STR4='    '
      STR8='        '
      CTYPE='        '
      CBASIS='        '
C
      IF(IRDBAS.EQ.1  .AND.  ICOORD.GT.0) THEN
         IF (MASWRK) THEN
         WRITE(IW,*) 'ERROR! USE OF COORD=CART/ZMT/ZMTMPC REQUIRES'
         WRITE(IW,*) 'THAT YOU SPECIFY THE BASIS SET WITH $BASIS!'
         END IF
         CALL ABRT
      END IF
C
      IF (FRIEND.NE.BLANK) FRNDLY = .TRUE.
C
      IF(FRNDLY) THEN
         DO 70 I=1,MAXATM
            DO 60 J=1,5
               DO 50 K=1,MAXGSH
                   RMLDMP(K,J,I)=0
   50          CONTINUE
   60       CONTINUE
   70    CONTINUE
      END IF
C
C     ... HONDO 8.2
C
      IF (FRNDLY) THEN
         WRITE(NFT16,7010)
         WRITE(NFT16,7020)
         WRITE(NFT16,7030)
         WRITE(NFT16,7040) (TITLE(I),I=1,10)
C
 7010 FORMAT('HOND!!!! (1) INSERT BLANK LINES IN $ECP GROUP FOR ATOMS',
     * ' WITHOUT ECPS'/
     * 'HOND!!!! (2) IF USING ECPS, CHANGE 2ND SET OF ... IN BASIS',
     * ' GROUP TO ECP'/
     * 'HOND!!!! (3) REMOVE !!!! LINES')
 7020 FORMAT('HOND $CNTRL  RUNFLG=0, QMTTOL=1.0D-04, ISPHER=0, $END'/
     *  'HOND $GUESS  NGUESS=2, $END'/
     *  'HOND $INTGRL NHONDO=1, CUTOFF=1.0D-12, $END'/
     *  'HOND $TRF    CUTOFF=1.0D-12, $END'/
     *  'HOND $WFN    WFNFLG=0, $END')
 7030 FORMAT('HOND $SCF    CHARGE=0, NCO=, $END'/
     *  'HOND $OPT    CVGOPT=0.0005, NPTOPT=50, $END'/
     *  'HOND $FORCE  IFINIT=1, VIBPUN=1, $END'/
     *  'HOND $ZMAT   IZMAT=0, A=0.,0.,0., $END'/
     *  'HOND $PRP    NODIP=0, NOQDP=0, NOOTP=0, NOPOP=0,'/
     *  'HOND         NODEN=0, NOELP=0, NOELF=0, NOELFG=0, $END')
 7040 FORMAT('HOND $GUGDIA PRTTOL=0.05, $END'/
     *  'HOND $BASIS'/'HOND',10A8/
     *  'HOND    0    0   20   -1  ...  ...'/
     *  'HONDDNH      2    0')
C
C     ... GAMESS-UK
C
         WRITE(NFT16,7110)
         WRITE(NFT16,7120)
         WRITE(NFT16,7130) (TITLE(I),I=1,10)
         WRITE(NFT16,7140)
C
 7110 FORMAT('GAME!!!! (1) BUILD YOUR OWN ZMAT, OR COPY CART XYZ'/
     *  'GAME!!!! (2) SOME BASIS SET DEFINITIONS MAY BE DUPLICATED'/
     *  'GAME!!!! (3) REMOVE !!!! LINES')
 7120 FORMAT('GAME#'/
     *  'GAMESETENV ED2 SCR/XXX.ED2'/
     *  'GAMESETENV ED3 SCR/XXX.ED3'/
     *  'GAMESETENV ED7 SCR/XXX.ED7'/
     *  'GAME#'/ 'GAMEGAMESS-UK << EOF'/ 'GAMEMEMORY 4000000'/
     *  'GAMETIME   240')
 7130 FORMAT('GAMEIPRINT ADAPT DIST'/
     *  'GAMEACCURACY 20 9 ! IF GREATER ACCURACY, USE INTEGRAL HIGH'/
     *  'GAMETITLE'/
     *  'GAME',10A8)
 7140 FORMAT('GAMEMULT   1'/'GAMECHARGE 0'/'GAMEGEOMETRY AU'/
     *  'GAME!!!! INSERT HERE ATOMIC COORDINATES BLOCK OR DEFINE ZMAT'/
     *  'GAMEEND'/'GAMEBASIS')
C
C     ... GAUSSIAN 9X
C
         WRITE(NFT16,7210)
         WRITE(NFT16,7220)
         WRITE(NFT16,7230) (TITLE(I),I=1,10)
C
 7210 FORMAT( 'GAUS!!!! (1) BUILD YOUR OWN ZMAT, OR COPY CART XYZ'/
     *  'GAUS!!!! (2) SOME BASIS SET DEFINITIONS MAY BE DUPLICATED'/
     *  'GAUS!!!! (3) REMOVE !!!! LINES')
 7220 FORMAT('GAUS$ RUNGAUSS'/'GAUS%MEM=1000000'/
     *  'GAUS%INT=/SCRATCH/FDATAFILE.INT'/
     *  'GAUS%RWF=/SCRATCH/FDATAFILE.RWF'/
     *  'GAUS%D2E=/SCRATCH/FDATAFILE.D2E'/
     *  'GAUS%CHK=/SCRATCH/FDATAFILE.CHK')
 7230 FORMAT('GAUS# TEST OPT MP2=(MAXDISK=40000000)/GEN 6D',
     *  ' PSEUDO=CARDS GFPRINT UNITS=AU'/
     *  'GAUS '/'GAUS',10A8/'GAUS '/'GAUS0 1'/
     *  'GAUSZMAT GOES HERE...'/'GAUS ')
C
C     ... MELDF
C
         WRITE(NFT16,7310)
         WRITE(NFT16,7320) (TITLE(I),I=1,9)
         WRITE(NFT16,7330)
C
 7310 FORMAT(
     *  'MELD!!!! (1) SOME BASIS SET DEFINITIONS MAY BE DUPLICATED'/
     *  'MELD!!!! (2) ADD SUFFIXES TO LABELS OF SYMMETRY-EQUIVALENT',
     *  ' ATOMS'/
     *  'MELD!!!!     BOTH IN THE LIST OF ATOMS AND IN BASIS-SET',
     *  '-TO-ATOM MAPPING SECTIONS'/
     *  'MELD!!!! (3) REMOVE !!!! LINES')
 7320 FORMAT('MELD* ',9A8,' *'/
     *  'MELD BSTOTAL=?  $ THE TOTAL NUMBER OF SYMMETRY-UNIQUE',
     *  ' CONTRACTED BASIS FUNCTIONS'/
     *  'MELD BSINPUT=?  $ THE TOTAL NUMBER OF USER-DEFINED FUNCTIONS'/
     *  'MELD PROP=1     $ REQUEST ALL PROPERTIES'/
     *  'MELD C.M.       $ TRANSFORMATION TO CENTER OF MASS'/
     *  'MELD UNITS=BOHRS  $ OR UNITS=ANGSTROMS'/
     *  'MELD PTGROUP=C2VZ $ SPECIFY CORRECT POINT GROUP')
 7330 FORMAT('MELD NPSEUDO=0  $ READ IN PSEUDOPOTENTIAL(S)'/
     *  'MELD BPRINT     $ PRINT ALL BASIS FUNCTIONS'/
     *  'MELD **         $ END OF OPTIONS')
 7340 FORMAT('MELD$'/
     *       'MELD$ USER-DEFINED ',A8,2X,1H(,F3.0,1H),' BASIS SET'/
     *       'MELD$   AT',3F10.5)
 7350 FORMAT('MELD$ ===>',
     *  ' THE TOTAL NUMBER OF USER-DEFINED FUNCTIONS IS',I4/
     *  'MELD$'/'MELD$  COORDINATES OF ALL ATOMS (IN A.U.)'/
     *  'MELD$   NOTES:'/
     *  'MELD$  (1) C.O.M. AS ORIGIN IF C.M. REQUESTED IN OPTIONS'/
     *  'MELD$  (2) CHANGE NUCLEAR CHARGE FOR ECP RUNS'/
     *  'MELD$  (3) MELDF NEEDS ONLY THE SYMMETRY-UNIQUE ATOMS'/
     *  'MELD$      IN D2H OR ITS SUBGROUPS; REMOVE THE REDUNDANT',
     *  ' ATOMS MANUALLY'/'MELDGEOMETRY'/
     *  'MELD$  ATOM',2X,6HCHARGE,8X,4HMASS,5X,1HX,16X,1HY,16X,1HZ)
 7360 FORMAT(4HMELD,4X,A2,F6.0,3X,5HMASS=,F9.5,3F17.12)
C
      END IF
C
      PI = ACOS(-ONE)
      PI32 = PI * SQRT(PI)
      IDUM = 0
      IGAUSS = 0
      BASIS = BLANK
C
C     READ IN MOLECULE INFORMATION (CHARGE,MULTIPLICITY,UNITS)
C     READ IN UNIQUE CENTERS AND ATOMIC BASIS SETS GROUPED
C     IN SHELLS
C     GENERATE ALL NEW CENTERS
C     SET TABLE ( CENTERS VERSUS TRANSFORMATIONS )
C     SET TABLE ( SHELLS VERSUS TRANSFORMATIONS )
C
      IUNT = IUNTRD
      DO 100 I = 1,MXGTOT
         EX(I) = ZERO
         CS(I) = ZERO
         CP(I) = ZERO
         CD(I) = ZERO
         CF(I) = ZERO
         CG(I) = ZERO
         CH(I) = ZERO
         CI(I) = ZERO
         CSINP(I) = ZERO
         CPINP(I) = ZERO
         CDINP(I) = ZERO
         CFINP(I) = ZERO
         CGINP(I) = ZERO
         CHINP(I) = ZERO
         CIINP(I) = ZERO
  100 CONTINUE
      ICNT2 = 0
      NAT = 0
      NATIN = 0
      NE = 0
      NSHELL = 0
      LOC = 0
      NGAUSS = 0
      ZNUC = ZERO
      X = ZERO
      Y = ZERO
      Z = ZERO
      SCFAC(1) = ZERO
      SCFAC(2) = ZERO
      SCFAC(3) = ZERO
      SCFAC(4) = ZERO
      INPATM = 0
C
C     ----- OBTAIN NEXT UNIQUE ATOM, IN ANGSTROM UNITS -----
C     IF IT IS NAMED "$END" THEN WE ARE DONE.
C
  120 CONTINUE
      ICNT2 = ICNT2 + 1
      IF(ICOORD.LE.0) THEN
         CALL READAT(ATOMNM,ZNUC,X,Y,Z,C,NAT,ICOORD,IUNTRD)
      ELSE
         ATOMNM = UATOM(ICNT2)
         ZNUC = UZNUC(ICNT2)
         X = CUNIQ(ICNT2,1)
         Y = CUNIQ(ICNT2,2)
         Z = CUNIQ(ICNT2,3)
      END IF
      INPATM=INPATM+1
C
      IF(ATOMNM.EQ.ENDWRD) GO TO 900
      NAT = NAT+1
      MPTYP(NAT) = 0
C ... FOR MCP RUNS AND EXTERNAL BASIS SET FILE, ALL ATOMS ARE MCP
      IF(IRDBAS.EQ.2 .AND. IECP.EQ.5) MPTYP(NAT) = 3
C ... EXCEPT FOR HYDROGEN
      IF (MPTYP(NAT).EQ.3 .AND. ZNUC.EQ.ONE) MPTYP(NAT) = 0
      IF(NAT.GT.MXATM) GO TO 1540
C
      IF (MASWRK) WRITE(IP,9008) ATOMNM,ZNUC,X,Y,Z
      READ(UNIT=ATOMNM,FMT='(A8,A2)') A(NAT),B(NAT)
      NS(NAT) = 0
      KS(NAT) = NSHELL+1
C
C                    STORE THE COORDINATES IN BOHR UNITS
C
      X = X * UNITS
      Y = Y * UNITS
      Z = Z * UNITS
      C(1,NAT) = X
      C(2,NAT) = Y
      C(3,NAT) = Z
C
C          INTEGER CHARGES ARE REAL NUCLEI, WITH MINUS SIGN
C          IMPLYING A GHOST ATOM FOR BSSE (CHARGE WILL BE
C          RESET TO ZERO, BUT A STANDARD BASIS SET WILL BE
C          PLACED ON THAT CENTER BELOW).
C
C          FRACTIONAL CHARGES ARE TAKEN TO BE SPARKLES, NOTE
C          SPARKLES MAKE NO CONTRIBUTION TO THE ELECTRON COUNT.
C          THESE MUST HAVE NO BASIS SET, AND MUST BE AT THE END
C          OF THE $DATA INPUT GROUP, BUT THESE REQUIREMENTS ARE
C          NOT CHECKED FOR.  IT IS BETTER TO USE GUESS=MOREAD
C          FROM A JOB THAT DID NOT HAVE THE SPARKLES.  IT IS
C          NONSENSE TO CONSIDER ANYTHING BUT RUNTYP=ENERGY.
C
      ZEXTRA = ABS(ZNUC) - INT(ABS(ZNUC))
      SPRKLE = ZEXTRA.GT.1.0D-05
C
      IF(.NOT.SPRKLE) THEN
         IF(ZNUC.GT.ZERO) THEN
            ZAN(NAT) = ZNUC
            NE = NE + INT(ZNUC)
         ELSE
            ZAN(NAT) = ZERO
            ZNUC = ABS(ZNUC)
         END IF
      ELSE
         ZAN(NAT) = ZNUC
      END IF
C
C     ----- READ IN THE BASIS FUNCTIONS ON THIS CENTER -----
C     NORMALLY A GENERAL BASIS SET INPUT SHOULD BE IN THE CARD INPUT,
C     BUT WE MIGHT USE AN EXTERNAL DISK FILE, WHICH MUST BE OPENED.
C     NOTE THAT THE OPEN STATEMENT ASSUMES A UNIX FILE SYSTEM.
C
      IF(IRDBAS.EQ.2) THEN
C        --- GENERATE PERIODIC TABLE. ---
         CALL SETLAB(3,ATMSYM)
C
         SCFAC(1) = ZERO
         SCFAC(2) = ZERO
         SCFAC(3) = ZERO
         SCFAC(4) = ZERO
C
C        --- GET PATH TO BASIS SET DIRECTORY ---
C        --- REMOVE BLANKS FROM BASPTH, ADD FILE NAME COMPONENT ---
C
         IBFILE = 3
         IF(ISGDDI) THEN
            BASPTH=ENVBUF(IBFILE)
         ELSE
            CALL GETENV('EXTBAS',BASPTH)
         END IF
C
C ... FOR MCP-**** BASIS SETS GET PATH TO BASIS SET LIBRARIES
C
         IF(GBASIS.EQ.MCP_DZP .OR. GBASIS.EQ.MCP_TZP  .OR.
     +      GBASIS.EQ.MCP_QZP .OR. GBASIS.EQ.IMCP_NR1 .OR.
     +      GBASIS.EQ.IMCP_NR2.OR. GBASIS.EQ.IMCP_SR1 .OR.
     +      GBASIS.EQ.IMCP_SR2) THEN
             CALL GETENV('MCPPATH',BASPTH)
         END IF
C
         NULL = CHAR(0)
         DO KOL = 1,256
            IF (BASPTH(KOL:KOL) .EQ. ' ' .OR.
     *          BASPTH(KOL:KOL) .EQ. NULL) GO TO 190
            KOLMAX = KOL
         END DO
  190    CONTINUE
C
C        --- OPEN EXTERNAL BASIS SET FILE IBFILE ---
C
         IF(MASWRK) THEN
C
C ... FOR MCP-**** BASIS SETS APPEND THE GBASIS FILE NAME TO BASPTH
C                  IN ORDER TO CREATE THE FULL FILE NAME TO OPEN.
C                  THERE IS SIMILAR CODE IN MCPINP.SRC, CHANGE BOTH!
C
           IF(GBASIS.EQ.MCP_DZP .OR. GBASIS.EQ.MCP_TZP  .OR.
     +        GBASIS.EQ.MCP_QZP) THEN
               WRITE(UNIT=BASPTH(KOLMAX+1:KOLMAX+8),FMT='(1H/,A7)')
     +               GBASIS
               KOLMAX=KOLMAX+8
           END IF
           IF(GBASIS.EQ.IMCP_NR1 .OR.  GBASIS.EQ.IMCP_NR2  .OR.
     *        GBASIS.EQ.IMCP_SR1 .OR.  GBASIS.EQ.IMCP_SR2) THEN
               WRITE(UNIT=BASPTH(KOLMAX+1:KOLMAX+9),FMT='(1H/,A8)')
     +               GBASIS
               KOLMAX=KOLMAX+9
           END IF
C
            IF(NAT.EQ.1) WRITE(IW,7405) BASPTH(1:KOLMAX)
            OPEN(UNIT=IBFILE,FILE=BASPTH(1:KOLMAX),STATUS='OLD',
     *           IOSTAT=IERR,ERR=192,FORM='FORMATTED')
            IERR=0
            GO TO 193
  192       CONTINUE
            WRITE(IW,*)
     *        'UNABLE TO OPEN THE REQUESTED EXTERNAL BASIS FILE'
            CALL ABRT
            STOP
  193       CONTINUE
            IF (GOPARR) CALL DDI_BCAST(300,'I',IERR,1,MASTER)
         ELSE
            IF (GOPARR) CALL DDI_BCAST(300,'I',IERR,1,MASTER)
         END IF
         IF(IERR.NE.0) THEN
            IF(MASWRK) WRITE(IW,7400) BASPTH(1:KOLMAX)
            CALL ABRT
         END IF
C
C        --- SET FREE FORMAT READER TO FIRST CARD IN FILE IBFILE ---
C
         CALL OPNCRD(IBFILE,-IW)
      END IF
C
      ICNT = 0
  200 CONTINUE
      ICNT = ICNT + 1
C
C     ----- READ BASIS DESCRIPTOR IN EITHER OLD OR NEW FORMAT -----
C     NEW:   READ (IR,*) BASIS,IGAUSS,(SCFAC(I),I=1,4)
C                     -OR-
C     OLD:   READ (IR,*) ISHELL,TYPE,IGAUSS,BASIS,(SCFAC(I),I=1,4)
C
      NUCZ = INT(ZNUC)
      MPCORE = 0
C                               BASIS SPECIFIED BY $BASIS GROUP
      IF(IRDBAS.EQ.0) THEN
         IF(NUCZ.GT.0) THEN
            BASIS =ABASIS(NUCZ,ICNT)
            IGAUSS=IAGAUS(NUCZ,ICNT)
         ELSE
            BASIS =BLANK
            IGAUSS=0
         END IF
         SCFAC(1)=ZERO
         SCFAC(2)=ZERO
         SCFAC(3)=ZERO
         SCFAC(4)=ZERO
      END IF
C                               EXPLICIT BASIS INPUT IN $DATA GROUP
      IF(IRDBAS.EQ.1) THEN
         IEOF = 0
         IERR = 0
         CALL RDCARD('$DATA 6U',IEOF)
         KSIZE = -8
         CALL GSTRNG(CBASIS,KSIZE)
         READ(UNIT=CBASIS,FMT='(A8)') BASIS
C
C        --- IF MCP IS SPECIFIED, READ MODEL-POTENTIAL INFORMATION ---
C
         IF(BASIS.EQ.BASMMP) THEN
           IF (IECP.EQ.5) THEN
             CALL MMPINP(NUCZ,CSINP,CPINP,CDINP,CFINP,
     *         IERR1,IERR2,INTYP,NANGM,NBFS,MINF,MAXF,
     *         LOC,NGAUSS,NS)
             GO TO 200
           ELSE IF (IECP.EQ.6) THEN
             CALL MMPINF(NUCZ,CSINP,
     *         IERR1,IERR2,INTYP,
     *         LOC,NGAUSS,NS)
             GO TO 200
           ELSE
             WRITE(IW,*) 'MCP WAS SPECIFIED IN $DATA GROUP,'
             WRITE(IW,*) 'BUT NOT IN $CONTRL GROUP VIA PP=MCP'
             CALL ABRT
           END IF
         END IF
C
C                ARE WE READING THE NEW WAY OR THE UNDOCUMENTED,
C                AND NOW QUITE ANCIENT AND FORGOTTEN OLD WAY?
C
         NEWWAY=.TRUE.
         DO 202 I=1,20
            IF(BASIS.EQ.SKIPS(I)) NEWWAY=.FALSE.
 202     CONTINUE
         IF(NEWWAY) THEN
            IF (BASIS.EQ.LETK) BASIS=LABEL(1)
            IGAUSS = IFIND('NGAUSS  ',IERR)
         ELSE
C                THE OLD WAY ALWAYS BEGAN WITH AN UNUSED SHELL NUMBER
            CALL REREAD
            IDUM = IFIND('ISHELL  ',IERR)
                          IF(IERR.NE.0) CALL ABRT
C                    SKIP OVER ANY INTERVENING "SV" TAG.
            KSIZE = -8
            CALL GSTRNG(CTYPE,KSIZE)
            READ(UNIT=CTYPE,FMT='(A8)') TYPE
            IF(TYPE.EQ.LETK) TYPE=LABEL(1)
            IF(TYPE.EQ.SV) THEN
               KSIZE = -8
               CALL GSTRNG(CTYPE,KSIZE)
               READ(UNIT=CTYPE,FMT='(A8)') TYPE
            END IF
C                WE MIGHT HAVE A "S", "P",...,"I" OR "L" GENERAL TYPE.
C                WE MIGHT HAVE A "1S", "2SP" ... STO TYPE.
C                IF WE DON'T, ITS AN INTEGER VALUE FOR -IGAUSS-
            STOTYP=.FALSE.
            GENTYP=.FALSE.
            DO 206 ITYP=1,8
               IF(TYPE.EQ.LABEL(ITYP)) GENTYP=.TRUE.
  206       CONTINUE
            DO 207 ITYP=9,27
               IF(TYPE.EQ.LABEL(ITYP)) STOTYP=.TRUE.
  207       CONTINUE
            IF(STOTYP .OR.  GENTYP) THEN
               BASIS=TYPE
               IGAUSS=IFIND('NGAUSS  ',IERR)
C                      SKIP OVER 'STO' TO POSITION SCALE FACTORS
               KSIZE = -8
               IF(STOTYP) CALL GSTRNG(CTYPE,KSIZE)
            ELSE
               CALL REREAD
               IGAUSS = IFIND('NGAUSS  ',IERR)
                             IF(IERR.NE.0) CALL ABRT
               KSIZE = -8
               CALL GSTRNG(CBASIS,KSIZE)
               READ(UNIT=CBASIS,FMT='(A8)') BASIS
            END IF
         END IF
         DO 210 I=1,4
            SCFAC(I) = RFIND('SCFAC   ',IERR)
                       IF(IERR.NE.0) CALL ABRT
  210    CONTINUE
      END IF
C                               BASIS TO BE READ FROM EXTERNAL FILE
      IF(IRDBAS.EQ.2) THEN
         IF (ICNT .EQ. 1) ELEMENT = .FALSE.
C
C           WE MUST POSITION THE EXTERNAL FILE TO THE
C           DESIRED ELEMENT NAME AND GBASIS STRING.
C
         IF(.NOT.ELEMENT) THEN
            WRITE(UNIT=BASSTR,FMT='(A8)') GBASIS
  215       CONTINUE
            IEOF = 0
            CALL RDCARD('EXT.FILE',IEOF)
            IF (IEOF.EQ.1) THEN
               WRITE(IW,7500) ATMSYM(NUCZ),GBASIS,BASPTH(1:KOLMAX)
               CALL ABRT
            END IF
            KSIZE = -4
            CALL GSTRNG(STR4,KSIZE)
            IF(STR4.NE.ATMSYM(NUCZ)) GO TO 215
            KSIZE = -8
            CALL GSTRNG(STR8,KSIZE)
            IF(STR8.NE.BASSTR) GO TO 215
         END IF
         ELEMENT = .TRUE.
C
C     --- WE HAVE FOUND THE ELEMENT AND BASIS IN THE EXTERNAL FILE ---
C         NOW READ THE SHELL TO SEE IF ITS S,P,D,F,G,L AND
C         THEN CARRY ON INTO THE NORMAL CODE FOR READING
C         EXPONENTS AND CONTRACTION COEFFICIENTS, BUT WITH
C         THE FREE FORMAT ROUTINES POINTED INTO FILE IBFILE
C         INSTEAD OF THE $DATA GROUP.   WHEN A BLANK LINE
C         IS FOUND, WE ARE DONE, AND POINT THE INPUT READER
C         BACK INTO THE NORMAL INPUT FILE.
C
         CALL RDCARD('SHELLDEF',IEOF)
         KSIZE = -1
         CALL GSTRNG(CBASIS,KSIZE)
         READ(UNIT=CBASIS,FMT='(A8)') BASIS
         IF (BASIS .EQ. BLANK) THEN
            IF(MASWRK) CLOSE(UNIT=IBFILE)
            CALL OPNCRD(IR,-IW)
            GO TO 219
         END IF
         KERR = 0
         IGAUSS = IFIND('NGAUSS  ',KERR)
      END IF
C
  219 CONTINUE
      IF(ICNT.EQ.1  .AND.  IRDBAS.GT.0) THEN
         ABASIS(NUCZ,1) = BASIS
         IAGAUS(NUCZ,1) = IGAUSS
      END IF
C
C        A BLANK STRING FOR BASIS MEANS THIS ATOM IS ALL DONE
C
      IF(BASIS.EQ.BLANK) THEN
         IF (MASWRK) WRITE (IP,8000) BLANK
         GO TO 800
      ELSE
         IF (MASWRK) WRITE (IP,8000) BASIS,IGAUSS
      END IF
C
      IF(IGAUSS .GT. MXGSH) THEN
         IF (MASWRK) THEN
            WRITE(IW,9010) MXGSH
            WRITE(IW,9005) NAT,INPATM,ATOMNM,ZNUC,
     *                     X/UNITS,Y/UNITS,Z/UNITS
         END IF
         CALL ABRT
      END IF
C
C     ----- DETERMINE IF WE ARE USING A SEMIEMPIRICAL HAMILTONIAN -----
C
      IF(BASIS.EQ.BASMD3) MPCTYP=KMINDO
      IF(BASIS.EQ.BASMND) MPCTYP=KMNDO
      IF(BASIS.EQ.BASAM1) MPCTYP=KAM1
      IF(BASIS.EQ.BASPM3) MPCTYP=KPM3
      IF(MPCTYP.EQ.NONE) GO TO 220
C
      IF(MPCTYP.EQ.KMINDO) THEN
         WRITE(IW,*) 'MINDO HAS NOT BEEN WELL TESTED IN GAMESS'
         WRITE(IW,*) 'MINDO HAS BEEN SUPERCEDED BY BETTER PARAMETERS'
         WRITE(IW,*) 'THEREFORE, THIS JOB DIES SO YOU CAN PICK FROM'
         WRITE(IW,*) 'THE FOLLOWING PARAMETER SETS: PM3, AM1, MNDO'
         CALL ABRT
      END IF
C
      IF(SCFTYP.NE.RHF  .AND.  SCFTYP.NE.UHF  .AND.
     *   SCFTYP.NE.ROHF .AND.  SCFTYP.NE.GVB) THEN
         WRITE(IW,*) 'MOPAC CALCULATIONS ARE ALLOWED ONLY FOR'
         WRITE(IW,*) 'SCFTYP= RHF, UHF, ROHF, OR GVB.'
         CALL ABRT
      END IF
C
      CALL DERCHK(NDER)
      IF(SCFTYP.EQ.GVB  .AND.  NDER.NE.0) THEN
         WRITE(IW,*) 'MOPAC-GVB COMPUTATIONS DO NOT HAVE GRADIENTS'
         CALL ABRT
      END IF
C
C     ----- FILL MOPAC PARAMETER ARRAYS -----
C     IN SPITE OF ITS NAME, 'CORE' CONTAINS VALENCE E- COUNT
C
      IF(NAT.EQ.1) CALL MPCDAT
      MPCORE = NUCZ - INT(CORE(NUCZ))
      NE = NE - MPCORE
      ITYP = 1
      IF(NUCZ.GT.2) ITYP = 8
      GO TO 500
C
C     ----- SET UP AB INITIO BASIS SETS -----
C
  220 CONTINUE
      IF(BASIS.EQ.BASN31) GO TO 300
      IF(BASIS.EQ.BASN21) GO TO 300
      IF(BASIS.EQ.BASDH)  GO TO 300
      IF(BASIS.EQ.BASBC)  GO TO 300
      IF(BASIS.EQ.BASMC)  GO TO 300
      IF(BASIS.EQ.BAS311) GO TO 300
      IF(BASIS.EQ.BASMIN) GO TO 300
      IF(BASIS.EQ.BASMID) GO TO 300
      IF(BASIS.EQ.BASSB2) BASIS=BASSBK  ! SBK FORCED TO CORRECT SBKJC
      IF(BASIS.EQ.BASSBK) GO TO 300
      IF(BASIS.EQ.BASHW)  GO TO 300
      IF(BASIS.EQ.BASDZV) GO TO 300
      IF(BASIS.EQ.BASTZV) GO TO 300
      IF(BASIS.EQ.BASSTO) GO TO 300
      IF(BASIS.EQ.BASPC0) GO TO 300
      IF(BASIS.EQ.BASPC1) GO TO 300
      IF(BASIS.EQ.BASPC2) GO TO 300
      IF(BASIS.EQ.BASPC3) GO TO 300
      IF(BASIS.EQ.BASPC4) GO TO 300
      IF(BASIS.EQ.BAAPC0) GO TO 300
      IF(BASIS.EQ.BAAPC1) GO TO 300
      IF(BASIS.EQ.BAAPC2) GO TO 300
      IF(BASIS.EQ.BAAPC3) GO TO 300
      IF(BASIS.EQ.BAAPC4) GO TO 300
      IF(BASIS.EQ.BASCCD) GO TO 300
      IF(BASIS.EQ.BASCCT) GO TO 300
      IF(BASIS.EQ.BASCCQ) GO TO 300
      IF(BASIS.EQ.BASCC5) GO TO 300
      IF(BASIS.EQ.BASCC6) GO TO 300
      IF(BASIS.EQ.BASACD) GO TO 300
      IF(BASIS.EQ.BASACT) GO TO 300
      IF(BASIS.EQ.BASACQ) GO TO 300
      IF(BASIS.EQ.BASAC5) GO TO 300
      IF(BASIS.EQ.BASAC6) GO TO 300
      IF(BASIS.EQ.BACCCD) GO TO 300
      IF(BASIS.EQ.BACCCT) GO TO 300
      IF(BASIS.EQ.BACCCQ) GO TO 300
      IF(BASIS.EQ.BACCC5) GO TO 300
      IF(BASIS.EQ.BACCC6) GO TO 300
      IF(BASIS.EQ.BACACD) GO TO 300
      IF(BASIS.EQ.BACACT) GO TO 300
      IF(BASIS.EQ.BACACQ) GO TO 300
      IF(BASIS.EQ.BACAC5) GO TO 300
      IF(BASIS.EQ.BACAC6) GO TO 300
C
C     IT MUST BE EITHER S,P,D,F,G,H,I, OR -L- OR -STO- SHELL
C
      ITYP = 0
      DO I=1,27
         IF(BASIS.EQ.LABEL(I)) ITYP=I
      ENDDO
      IF(ITYP.GT.0) GO TO 500
C
C     BASIS IS A COMPLETELY UNRECOGNIZED STRING.  KILL JOB.
C
      IF(MASWRK) THEN
         WRITE(IW,9020) BASIS,IGAUSS
         WRITE(IW,9005) NAT,INPATM,ATOMNM,ZNUC,
     *                  X/UNITS,Y/UNITS,Z/UNITS
      END IF
      CALL BERROR(4)
      CALL ABRT
C
C     HERE WE BEGIN TO SET UP THE INTERNALLY STORED BASES.
C     EACH OF THESE IS ASSUMED TO DEAL WITH THE NORMALIZATION.
C
  300 CONTINUE
      NUCZ=INT(ZNUC)
C
C     ----- STO-NG -----
C
      IF(BASIS .NE. BASSTO) GO TO 310
      CALL STONG(NUCZ,IGAUSS,CSINP,CPINP,CDINP,IERR1,IERR2,
     *           INTYP,NANGM,NBFS,MINF,MAXF,LOC,NGAUSS,NS)
      IF(IERR1.NE.0) GO TO 1560
      IF(IERR2.NE.0) GO TO 1600
      GO TO 200
C
C     ----- N-21G -----
C
  310 CONTINUE
      IF(BASIS .NE. BASN21) GO TO 320
      CALL N21G(NUCZ,IGAUSS,CSINP,CPINP,CDINP,SCFAC,IERR1,IERR2,
     *          INTYP,NANGM,NBFS,MINF,MAXF,LOC,NGAUSS,NS)
      IF(IERR1.NE.0) GO TO 1560
      IF(IERR2.NE.0) GO TO 1600
      GO TO 200
C
C     ----- N-31G BASIS SET -----
C
  320 CONTINUE
      IF(BASIS .NE. BASN31) GO TO 330
      CALL N31G(NUCZ,IGAUSS,CSINP,CPINP,CDINP,SCFAC,IERR1,IERR2,
     *          INTYP,NANGM,NBFS,MINF,MAXF,LOC,NGAUSS,NS)
      IF(IERR1.NE.0) GO TO 1560
      IF(IERR2.NE.0) GO TO 1600
      GO TO 200
C
C     ----- N-311G BASIS SET -----
C
  330 CONTINUE
      IF(BASIS .NE. BAS311) GO TO 340
      CALL N311G(NUCZ,IGAUSS,CSINP,CPINP,IERR1,IERR2,
     *           INTYP,NANGM,NBFS,MINF,MAXF,LOC,NGAUSS,NS)
      IF(IERR1.NE.0) GO TO 1560
      IF(IERR2.NE.0) GO TO 1600
      GO TO 200
C
C     ----- HUZINAGA GROUP MINI/MIDI BASIS SETS -----
C
  340 CONTINUE
      IF(BASIS.NE.BASMIN  .AND.  BASIS.NE.BASMID) GO TO 350
      MIDI=.FALSE.
      IF(BASIS.EQ.BASMID) MIDI=.TRUE.
      CALL BASHUZ(NUCZ,MIDI,CSINP,CPINP,CDINP,CFINP,SCFAC,IERR1,IERR2,
     *            INTYP,NANGM,NBFS,MINF,MAXF,LOC,NGAUSS,NS,
     *            EX,CS,CP,CD,CF,KSTART,KATOM,KTYPE,KNG,KLOC,
     *            KMIN,KMAX,NSHELL,MXGTOT,MXSH)
      IF(IERR1 .NE. 0) GO TO 1560
      IF(IERR2 .NE. 0) GO TO 1600
      GO TO 200
C
C     ----- "DOUBLE ZETA" BASIS SETS -----
C
  350 CONTINUE
      IF(BASIS.NE.BASDH  .AND.  BASIS.NE.BASDZV
     *      .AND.BASIS.NE.BASBC) GO TO 360
      CALL DZVBAS(NUCZ,CSINP,CPINP,CDINP,SCFAC,IERR1,IERR2,
     *            INTYP,NANGM,NBFS,MINF,MAXF,LOC,NGAUSS,NS)
      IF(IERR1 .NE. 0) GO TO 1560
      IF(IERR2 .NE. 0) GO TO 1600
      GO TO 200
C
C     ----- "TRIPLE ZETA" BASIS SETS -----
C
  360 CONTINUE
      IF(BASIS.NE.BASMC .AND. BASIS.NE.BASTZV) GO TO 370
      CALL TZVBAS(NUCZ,CSINP,CPINP,CDINP,SCFAC,IERR1,IERR2,
     *            INTYP,NANGM,NBFS,MINF,MAXF,LOC,NGAUSS,NS,.FALSE.)
      IF(IERR1 .NE. 0) GO TO 1560
      IF(IERR2 .NE. 0) GO TO 1600
      GO TO 200
C
C     ----- HAY AND WADT -ECP- BASIS SET -----
C
  370 CONTINUE
      IF(BASIS.NE.BASHW) GO TO 380
      IF(IECP.EQ.0) THEN
         IF (MASWRK) WRITE(IW,*)
     *      '*** ERROR, -HW- BASIS REQUIRES USE OF ECP'
         CALL ABRT
      END IF
C
C          AT PRESENT WE HAVE SEMI-CORE HW BASIS SETS BUILT IN,
C          BUT WE HAVE THE FULL CORE POTENTIALS BUILT IN.  THUS
C          ANY RUN MIXING THESE TWO SHOULD BE BOMBED HERE.  THIS
C          IS ALL TRANSITION METALS EXCEPT ZN,CD,HG.
C
      IMIX=0
      IF(NUCZ.GE.21  .AND.  NUCZ.LE.29) IMIX=1
      IF(NUCZ.GE.39  .AND.  NUCZ.LE.47) IMIX=1
      IF(NUCZ.EQ.57)                    IMIX=1
      IF(NUCZ.GE.72  .AND.  NUCZ.LE.79) IMIX=1
      IF(IMIX.EQ.1) THEN
         IF(MASWRK) WRITE(IW,*) '-HW- TM BASIS SETS ARE NOT BUILT IN'
         CALL ABRT
      END IF
C
      CALL HWBAS(2,NUCZ,CSINP,CPINP,CDINP,IERR1,IERR2,
     *           INTYP,NANGM,NBFS,MINF,MAXF,LOC,NGAUSS,NS,
     *           EX,CS,CP,CD,KSTART,KATOM,KTYPE,KNG,KLOC,
     *           KMIN,KMAX,NSHELL,MXGTOT,MXSH)
      IF(IERR1.NE.0) GO TO 1560
      IF(IERR2.NE.0) GO TO 1600
      GO TO 200
C
C     ----- STEVENS, BASCH, KRAUS, JASIEN, CUNDARI -ECP- BASIS SET -----
C
  380 CONTINUE
      IF(BASIS.NE.BASSBK) GO TO 390
      IF(IECP.EQ.0) THEN
         IF (MASWRK) WRITE(IW,*)
     *      '*** ERROR, -SBKJC- BASIS REQUIRES USE OF ECP IN $CONTRL'
         CALL ABRT
      END IF
      CALL SBKBAS(NUCZ,CSINP,CPINP,CDINP,CFINP,IERR1,IERR2,
     *            INTYP,NANGM,NBFS,MINF,MAXF,LOC,NGAUSS,NS)
      IF(IERR1.NE.0) GO TO 1560
      IF(IERR2.NE.0) GO TO 1600
      GO TO 200
C
C     ----- PC-N BASIS SET -----
C
  390 CONTINUE
      IF(BASIS.NE.BASPC0 .AND. BASIS.NE.BASPC1 .AND.
     $   BASIS.NE.BASPC2 .AND. BASIS.NE.BASPC3 .AND.
     $   BASIS.NE.BASPC4 .AND. BASIS.NE.BAAPC0 .AND.
     $   BASIS.NE.BAAPC1 .AND. BASIS.NE.BAAPC2 .AND.
     $   BASIS.NE.BAAPC3 .AND. BASIS.NE.BAAPC4) GO TO 400
      NPOL = 999
      IF(BASIS.EQ.BASPC0) NPOL = 0
      IF(BASIS.EQ.BASPC1) NPOL = 1
      IF(BASIS.EQ.BASPC2) NPOL = 2
      IF(BASIS.EQ.BASPC3) NPOL = 3
      IF(BASIS.EQ.BASPC4) NPOL = 4
      IF(BASIS.EQ.BAAPC0) NPOL = 10
      IF(BASIS.EQ.BAAPC1) NPOL = 11
      IF(BASIS.EQ.BAAPC2) NPOL = 12
      IF(BASIS.EQ.BAAPC3) NPOL = 13
      IF(BASIS.EQ.BAAPC4) NPOL = 14
      CALL PCNBAS(NUCZ,CSINP,CPINP,CDINP,CFINP,CGINP,IERR1,IERR2,
     *            INTYP,NANGM,NBFS,MINF,MAXF,LOC,NGAUSS,NS,NPOL)
      IF(IERR1.NE.0) GO TO 1560
      IF(IERR2.NE.0) GO TO 1600
      GO TO 200
C
C     ----- CC-PVNZ BASIS SET -----
C
  400 CONTINUE
      IF(BASIS.NE.BASCCD .AND. BASIS.NE.BASCCT .AND.
     $   BASIS.NE.BASCCQ .AND. BASIS.NE.BASCC5 .AND.
     $   BASIS.NE.BASCC6 .AND. BASIS.NE.BASACD .AND.
     $   BASIS.NE.BASACT .AND. BASIS.NE.BASACQ .AND.
     $   BASIS.NE.BASAC5 .AND. BASIS.NE.BASAC6 .AND.
     $   BASIS.NE.BACCCD .AND. BASIS.NE.BACCCT .AND.
     $   BASIS.NE.BACCCQ .AND. BASIS.NE.BACCC5 .AND.
     $   BASIS.NE.BACCC6 .AND. BASIS.NE.BACACD .AND.
     $   BASIS.NE.BACACT .AND. BASIS.NE.BACACQ .AND.
     $   BASIS.NE.BACAC5 .AND. BASIS.NE.BACAC6) GO TO 410
      NPOL = 999
      IF(BASIS.EQ.BASCCD) NPOL = 1
      IF(BASIS.EQ.BASCCT) NPOL = 2
      IF(BASIS.EQ.BASCCQ) NPOL = 3
      IF(BASIS.EQ.BASCC5) NPOL = 4
      IF(BASIS.EQ.BASCC6) NPOL = 5
      IF(BASIS.EQ.BASACD) NPOL = 11
      IF(BASIS.EQ.BASACT) NPOL = 12
      IF(BASIS.EQ.BASACQ) NPOL = 13
      IF(BASIS.EQ.BASAC5) NPOL = 14
      IF(BASIS.EQ.BASAC6) NPOL = 15
      IF(BASIS.EQ.BACCCD) NPOL = 101
      IF(BASIS.EQ.BACCCT) NPOL = 102
      IF(BASIS.EQ.BACCCQ) NPOL = 103
      IF(BASIS.EQ.BACCC5) NPOL = 104
      IF(BASIS.EQ.BACCC6) NPOL = 105
      IF(BASIS.EQ.BACACD) NPOL = 111
      IF(BASIS.EQ.BACACT) NPOL = 112
      IF(BASIS.EQ.BACACQ) NPOL = 113
      IF(BASIS.EQ.BACAC5) NPOL = 114
      IF(BASIS.EQ.BACAC6) NPOL = 115
      CALL CCNBAS(NUCZ,CSINP,CPINP,CDINP,CFINP,CGINP,IERR1,IERR2,
     *            INTYP,NANGM,NBFS,MINF,MAXF,LOC,NGAUSS,NS,NPOL)
      IF(IERR1.NE.0) GO TO 1560
      IF(IERR2.NE.0) GO TO 1600
      GO TO 200
C
  410 CONTINUE
      IF (MASWRK) WRITE(IW,*) 'IT IS NOT POSSIBLE TO GET HERE!'
      CALL ABRT
C
C     ----- GET READY FOR GENERAL BASIS SET -----
C     THIS ALSO INCLUDES SPECIFIC STO-NG CONTROL, WHERE SEQUENCES
C     OF SHELLS (AND MAYBE SCALE FACTORS) ARE ENTERED EXPLICITLY.
C
  500 CONTINUE
      NSHELL = NSHELL + 1
      IF(NSHELL.GT.MXSH) GO TO 1560
      KMIN(NSHELL) = MINF(ITYP)
      KMAX(NSHELL) = MAXF(ITYP)
      KSTART(NSHELL) = NGAUSS+1
      KATOM(NSHELL) = NAT
      KTYPE(NSHELL) = NANGM(ITYP)
      INTYP(NSHELL) = ITYP
      KNG(NSHELL) = IGAUSS
      KLOC(NSHELL) = LOC+1
      NGAUSS = NGAUSS+IGAUSS
      IF(NGAUSS.GT.MXGTOT) GO TO 1600
      LOC = LOC+NBFS(ITYP)
      K1 = KSTART(NSHELL)
      K2 = K1+KNG(NSHELL)-1
      NS(NAT) = NS(NAT)+1
      IF(ITYP.GT.8) GO TO 600
      IF(MPCTYP.NE.NONE) GO TO 800
C
C     ----- GENERAL BASIS SET (S, P, D, F, G, OR L) -----
C
      IF(SCFAC(1) .LE. ZERO) SCFAC(1) = ONE
      IDUM=0
      DO 520 K = K1,K2
         C1 = ZERO
         C2 = ZERO
C                 READ (IR,*) IDUM,EX(K),C1,C2
         IF(IRDBAS.NE.0) THEN
            IEOF = 0
            IERR = 0
            CALL RDCARD('$DATA 7U',IEOF)
            IDUM = IFIND('IDUM    ',IERR)
                      IF(IERR.NE.0) CALL ABRT
            EX(K) = RFIND('ZETA   ',IERR)
                      IF(IERR.NE.0) CALL ABRT
                      IF(EX(K).EQ.ZERO) THEN
                         IF (MASWRK) WRITE(IW,9043) NATIN,LABEL(ITYP)
                         CALL ABRT
                      END IF
            C1 = RFIND('C1     ',IERR)
                      IF(IERR.NE.0) CALL ABRT
            C2 = RFIND('C2     ',IERR)
                      IF(IERR.NE.0) CALL ABRT
            IF(C1.EQ.ZERO  .AND.  EX(K).EQ.ONE) THEN
               IF (MASWRK) THEN
                  WRITE(IW,*) 'DID YOU FORGET THE LEADING INTEGER?'
                  WRITE(IW,*) 'CONTRACTION COEFFICIENT NOT FOUND!'
                  WRITE(IW,9005) NAT,INPATM,ATOMNM,ZNUC,
     *                           X/UNITS,Y/UNITS,Z/UNITS
               END IF
               CALL ABRT
            END IF
         ELSE
            IDUM = IDUM+1
            EX(K) = AEX(NUCZ,ICNT)
            IF(EX(K).LE.ZERO) THEN
               IF (MASWRK) WRITE(IW,9030) ATOMNM,NUCZ,BASIS
               CALL ABRT
            END IF
         END IF
C
         IF(RELNORM) THEN
            IF(IGAUSS.EQ.1) C1=ONE
            IF(IGAUSS.EQ.1) C2=ONE
         END IF
C
         IF (MASWRK) THEN
            IF(ITYP.LE.7) WRITE (IP,8010) IDUM,EX(K),C1
            IF(ITYP.EQ.8) WRITE (IP,8010) IDUM,EX(K),C1,C2
         END IF
         EX(K) = EX(K) * SCFAC(1)**2
         IF(ITYP.EQ.1) CSINP(K) = C1
         IF(ITYP.EQ.2) CPINP(K) = C1
         IF(ITYP.EQ.3) CDINP(K) = C1
         IF(ITYP.EQ.4) CFINP(K) = C1
         IF(ITYP.EQ.5) CGINP(K) = C1
         IF(ITYP.EQ.6) CHINP(K) = C1
         IF(ITYP.EQ.7) CIINP(K) = C1
C            L SHELL HAS S AND P CONTRACTION COEFS
         IF(ITYP.EQ.8) CSINP(K) = C1
         IF(ITYP.EQ.8) CPINP(K) = C2
C
         CS(K) = CSINP(K)
         CP(K) = CPINP(K)
         CD(K) = CDINP(K)
         CF(K) = CFINP(K)
         CG(K) = CGINP(K)
         CH(K) = CHINP(K)
         CI(K) = CIINP(K)
  520 CONTINUE
      GO TO 700
C
C     ----- STO-NG BASIS SET -----
C     EXPLICITLY INPUT BY MEANS OF 1S, 2S, 2P, 2SP, ... SHELLS
C     THIS IS AN UNDOCUMENTED INPUT OPTION.
C
  600 CONTINUE
      ATNUM = ZNUC
      NUCZ = INT(ATNUM)
      IF(NUCZ .GT. 54) CALL BERROR(1)
      DO 630 I = 1,IGAUSS
         EXX(I) = ZERO
         CSS(I) = ZERO
         CPP(I) = ZERO
         CDD(I) = ZERO
  630 CONTINUE
      IBRNCH = ITYP-8
C
      GO TO (601,602,603,604,605,606,607,608,609,610,611,
     *       612,613,614,615,616,617,618,619), IBRNCH
C
  601 CALL S1S(EXX,CSS,IGAUSS)
      STOSC = STOSF(NUCZ,1,0)
      GO TO 640
C
  602 CALL S2S(EXX,CSS,IGAUSS)
      STOSC = STOSF(NUCZ,2,0)
      GO TO 640
C
  603 CALL S2P(EXX,CPP,IGAUSS)
      STOSC = STOSF(NUCZ,2,0)
      GO TO 640
C
  604 CALL S2SP(EXX,CSS,CPP,IGAUSS)
      STOSC = STOSF(NUCZ,2,0)
      GO TO 640
C
  605 CALL S3S(EXX,CSS,IGAUSS)
      STOSC = STOSF(NUCZ,3,0)
      GO TO 640
C
  606 CALL S3P(EXX,CPP,IGAUSS)
      STOSC = STOSF(NUCZ,3,0)
      GO TO 640
C
  607 CALL S3D(EXX,CDD,IGAUSS)
      STOSC = STOSF(NUCZ,3,1)
      GO TO 640
C
  608 CALL S3SP(EXX,CSS,CPP,IGAUSS)
      STOSC = STOSF(NUCZ,3,0)
      GO TO 640
C
  609 CALL S3SPD(EXX,CSS,CPP,CDD,IGAUSS)
      STOSC = STOSF(NUCZ,3,0)
      IF(MASWRK) WRITE(IW,*) 'STO -3M- SHELLS DO NOT EXIST'
      CALL ABRT
      GO TO 640
C
  610 CALL S4S(EXX,CSS,IGAUSS)
      STOSC = STOSF(NUCZ,4,0)
      GO TO 640
C
  611 CALL S4P(EXX,CPP,IGAUSS)
      STOSC = STOSF(NUCZ,4,0)
      GO TO 640
C
  612 CALL S4D(EXX,CDD,IGAUSS)
      STOSC = STOSF(NUCZ,4,1)
      GO TO 640
C
  613 CALL S4SP(EXX,CSS,CPP,IGAUSS)
      STOSC = STOSF(NUCZ,4,0)
      GO TO 640
C
  614 CALL S4SPD(EXX,CSS,CPP,CDD,IGAUSS)
      STOSC = STOSF(NUCZ,4,0)
      IF(MASWRK) WRITE(IW,*) 'STO -4M- SHELLS DO NOT EXIST'
      CALL ABRT
      GO TO 640
C
  615 CALL S5S(EXX,CSS,IGAUSS)
      STOSC = STOSF(NUCZ,5,0)
      GO TO 640
C
  616 CALL S5P(EXX,CPP,IGAUSS)
      STOSC = STOSF(NUCZ,5,0)
      GO TO 640
C
  617 CALL S5D(EXX,CDD,IGAUSS)
      STOSC = STOSF(NUCZ,5,0)
      GO TO 640
C
  618 CALL S5SP(EXX,CSS,CPP,IGAUSS)
      STOSC = STOSF(NUCZ,4,0)
      GO TO 640
C
  619 CALL BERROR(1)
      STOSC = ZERO
C
  640 CONTINUE
      IF(SCFAC(1) .GT. ZERO) STOSC=SCFAC(1)
      DO 650 I = 1,IGAUSS
         K = K1+I-1
         EX(K) = EXX(I)*STOSC*STOSC
         CSINP(K) = CSS(I)
         CPINP(K) = CPP(I)
         CDINP(K) = CDD(I)
         CS(K) = CSINP(K)
         CP(K) = CPINP(K)
         CD(K) = CDINP(K)
  650 CONTINUE
C
C     IF(NORMP.NE.1) ... UNNORMALIZATION OF THE PRIMITIVE FUNCTIONS.
C     IF CONTRACTION COEFFICIENTS ARE GIVEN IN TERMS OF NORMALIZED
C     PRIMITIVE FUNCTIONS, CHANGE THEM TO GO WITH UNNORMALIZED
C     PRIMITIVES.
C     FOR D SHELLS, THE INPUT COEFFICIENTS CD MUST BE THE COEFFICIENTS
C     CORRESPONDING TO THE NORMALIZED PRIMITIVE X**2 *EXP(-A*R**2).
C
  700 CONTINUE
      IF(NORMP .EQ. 1) GO TO 730
      DO 720 IG = K1,K2
         EE = EX(IG)+EX(IG)
         FACS = PI32/(EE*SQRT(EE))
         FACP = HALF  *FACS/EE
         FACD = PT75  *FACS/(EE*EE)
         FACF = PT187 *FACS/(EE**3)
         FACG = PT6562*FACS/(EE**4)
         FACH = PT2953*FACS/(EE**5)
         FACI = PT1624*FACS/(EE**6)
         CS(IG) = CS(IG)/SQRT(FACS)
         CP(IG) = CP(IG)/SQRT(FACP)
         CD(IG) = CD(IG)/SQRT(FACD)
         CF(IG) = CF(IG)/SQRT(FACF)
         CG(IG) = CG(IG)/SQRT(FACG)
         CH(IG) = CH(IG)/SQRT(FACH)
         CI(IG) = CI(IG)/SQRT(FACI)
  720 CONTINUE
C
C     IF(NORMF.NE.1) NORMALIZE THE CONTRACTED BASIS FUNCTIONS.
C
  730 CONTINUE
      IF(NORMF .EQ. 1) GO TO 200
      FACS = ZERO
      FACP = ZERO
      FACD = ZERO
      FACF = ZERO
      FACG = ZERO
      FACH = ZERO
      FACI = ZERO
      DO 770 IG = K1,K2
         DO 760 JG = K1,IG
            EE = EX(IG)+EX(JG)
            FAC = EE*SQRT(EE)
            DUMS = CS(IG)*CS(JG)/FAC
            DUMP = HALF  *CP(IG)*CP(JG)/(EE*FAC)
            DUMD = PT75  *CD(IG)*CD(JG)/(EE*EE*FAC)
            DUMF = PT187 *CF(IG)*CF(JG)/(EE**3*FAC)
            DUMG = PT6562*CG(IG)*CG(JG)/(EE**4*FAC)
            DUMH = PT2953*CH(IG)*CH(JG)/(EE**5*FAC)
            DUMI = PT1624*CI(IG)*CI(JG)/(EE**6*FAC)
            IF(IG .NE. JG) THEN
               DUMS = DUMS+DUMS
               DUMP = DUMP+DUMP
               DUMD = DUMD+DUMD
               DUMF = DUMF+DUMF
               DUMG = DUMG+DUMG
               DUMH = DUMH+DUMH
               DUMI = DUMI+DUMI
            END IF
            FACS = FACS+DUMS
            FACP = FACP+DUMP
            FACD = FACD+DUMD
            FACF = FACF+DUMF
            FACG = FACG+DUMG
            FACH = FACH+DUMH
            FACI = FACI+DUMI
  760    CONTINUE
  770 CONTINUE
C
      IF(FACS .LT. TM10) THEN
         FACS=ZERO
      ELSE
         FACS = ONE/SQRT(FACS*PI32)
         IF((ABS(FACS-ONE).GT.TM6).AND.MASWRK)
     *      WRITE(IW,9040) NAT,NSHELL,'S',FACS
      END IF
C
      IF(FACP .LT. TM10) THEN
         FACP=ZERO
      ELSE
         FACP = ONE/SQRT(FACP*PI32)
         IF((ABS(FACP-ONE).GT.TM6).AND.MASWRK)
     *      WRITE(IW,9040) NAT,NSHELL,'P',FACP
      END IF
C
      IF(FACD .LT. TM10) THEN
         FACD=ZERO
      ELSE
         FACD = ONE/SQRT(FACD*PI32)
         IF((ABS(FACD-ONE).GT.TM6).AND.MASWRK)
     *      WRITE(IW,9040) NAT,NSHELL,'D',FACD
      END IF
C
      IF(FACF .LT. TM10) THEN
         FACF=ZERO
      ELSE
         FACF = ONE/SQRT(FACF*PI32)
         IF((ABS(FACF-ONE).GT.TM6).AND.MASWRK)
     *      WRITE(IW,9040) NAT,NSHELL,'F',FACF
      END IF
C
      IF(FACG .LT. TM10) THEN
         FACG=ZERO
      ELSE
         FACG = ONE/SQRT(FACG*PI32)
         IF((ABS(FACG-ONE).GT.TM6).AND.MASWRK)
     *      WRITE(IW,9040) NAT,NSHELL,'G',FACG
      END IF
C
      IF(FACH .LT. TM10) THEN
         FACH=ZERO
      ELSE
         FACH = ONE/SQRT(FACH*PI32)
         IF((ABS(FACH-ONE).GT.TM6).AND.MASWRK)
     *      WRITE(IW,9040) NAT,NSHELL,'H',FACH
      END IF
C
      IF(FACI .LT. TM10) THEN
         FACI=ZERO
      ELSE
         FACI = ONE/SQRT(FACI*PI32)
         IF((ABS(FACI-ONE).GT.TM6).AND.MASWRK)
     *      WRITE(IW,9040) NAT,NSHELL,'I',FACI
      END IF
C
      IF(.NOT.RELNORM) GO TO 200
C
      DO 790 IG = K1,K2
         CS(IG) = CS(IG) * FACS
         CP(IG) = CP(IG) * FACP
         CD(IG) = CD(IG) * FACD
         CF(IG) = CF(IG) * FACF
         CG(IG) = CG(IG) * FACG
         CH(IG) = CH(IG) * FACH
         CI(IG) = CI(IG) * FACI
         CSINP(IG) = CSINP(IG) * FACS
         CPINP(IG) = CPINP(IG) * FACP
         CDINP(IG) = CDINP(IG) * FACD
         CFINP(IG) = CFINP(IG) * FACF
         CGINP(IG) = CGINP(IG) * FACG
         CHINP(IG) = CHINP(IG) * FACH
         CIINP(IG) = CIINP(IG) * FACI
  790 CONTINUE
      GO TO 200
C
C     ----- GENERATE EQUIVALENT CENTERS (ATOMS) -----
C
  800 CONTINUE
      XS = X
      YS = Y
      ZS = Z
      CALL LOCAL(X,Y,Z,XS,YS,ZS)
      XSMAL = XS
      YSMAL = YS
      ZSMAL = ZS
      NAT0 = NAT
      DO 820 IT = 1,NT
         IF(IT .EQ. 1) GO TO 820
         NN = 9*(IT-1)
         CALL TRANS(NN)
         CALL ROT
         DO 810 IAT = 1,NAT
            TEST = (XP-C(1,IAT))**2+(YP-C(2,IAT))**2+(ZP-C(3,IAT))**2
            IF(TEST .LE. 1.0D-12) GO TO 820
  810    CONTINUE
         NUAT = NAT
         NAT = NAT+1
         IF(NAT.GT.MXATM) GO TO 1540
         C(1,NAT) = C(1,NUAT)
         C(2,NAT) = C(2,NUAT)
         C(3,NAT) = C(3,NUAT)
         C(1,NUAT) = XP
         C(2,NUAT) = YP
         C(3,NUAT) = ZP
         NS(NAT) = NS(NAT0)
         KS(NAT) = KS(NAT-1)+NS(NAT0)
         A(NAT) = A(NAT0)
         B(NAT) = B(NAT0)
         ZAN(NAT) = ZAN(NAT0)
         MPTYP(NAT)=MPTYP(NAT0)
         NE = NE + INT(ZAN(NAT)) - MPCORE
         NSHELL = NSHELL+NS(NAT)
         NS1 = NS(NAT)
         J = KS(NAT0)
         JJ = KS(NAT)
         CALL ATOMSS(NBFS,NAT,LOC,NS1
     *              ,KMIN(J),KMAX(J),KSTART(J),KTYPE(J),KNG(J),INTYP(J)
     *              ,KATOM(JJ)
     *              ,KMIN(JJ),KMAX(JJ),KSTART(JJ),KTYPE(JJ),KNG(JJ)
     *              ,INTYP(JJ),KLOC(JJ))
  820 CONTINUE
      IF(ICOORD.EQ.0) INATOM(NATIN) = NAT
      GO TO 120
C
C     ----- ALL ATOMS HAVE NOW BEEN READ IN -----
C
  900 CONTINUE
C
C     --- IF PP=MCPINFO WAS SPECIFIED, TERMINATE AT THIS POINT
C
      IF (IECP.EQ.6) THEN
        IF (MASWRK) THEN
          WRITE(IW,'(//A)') '*** END OF MCPINFO PART ***'
          WRITE(IW,'(/A/)') '... TO CONTINUE SPECIFY  PP=MCP'
        END IF
        CALL ABRT
      END IF
      IF (MASWRK) WRITE (IP,9009) ENDWRD
C
C FOR COORD=CART,ZMT,ZMTMPC CHECK TO SEE
C 1.IF THE SAME NUMBER ATOMS HAVE BEEN GENERATED AS WAS
C   ORIGINALLY READ IN
C 2.HOW THE ATOMS WERE RESHUFFLED
C
      IF(ICOORD.GT.0) THEN
         NRATM = IABS(NATREL)
         IF(NAT.NE.NRATM) THEN
            IF (MASWRK) WRITE(IW,9045) NAT,NRATM
            DO 910 I=1,NRATM
               IF(UATOM(I).EQ.ENDWRD) THEN
                  CALL ABRT
               END IF
               IF (MASWRK) WRITE(IW,9046)
     *            UATOM(I),UZNUC(I),(CUNIQ(I,J),J=1,3)
  910       CONTINUE
            CALL ABRT
         END IF
         CALL RESHUF
      END IF
C
C     ----- NGAUSS WILL BE 0 FOR MOPAC WAVEFUNCTIONS -----
C
      IF((NGAUSS.EQ.0  .OR.  NSHELL.EQ.0) .AND. MPCTYP.EQ.NONE) THEN
         IF (MASWRK) THEN
            WRITE(IW,*) 'ERROR!  THERE ARE NO BASIS FUNCTIONS DEFINED.'
            WRITE(IW,*) 'CHECK YOUR $BASIS/$DATA INPUT FOR ERRORS.'
         END IF
         CALL ABRT
      END IF
C
C     FORM TRANSFORMATION TABLES FOR ATOMS AND SHELLS.
C
      DO 1050 IAT = 1,NAT
         NS1 = KS(IAT)-1
         NS2 = NS(IAT)
         X = C(1,IAT)
         Y = C(2,IAT)
         Z = C(3,IAT)
         XS = X
         YS = Y
         ZS = Z
         CALL LOCAL(X,Y,Z,XS,YS,ZS)
         XSMAL = XS
         YSMAL = YS
         ZSMAL = ZS
         DO 1040 IT = 1,NT
            NN = 9*(IT-1)
            CALL TRANS(NN)
            CALL ROT
            ICTR = -2**20
            DO 1010 I = 1,NAT
               TEST = (XP-C(1,I))**2+(YP-C(2,I))**2+(ZP-C(3,I))**2
               IF(TEST .GT. TM10) GO TO 1010
               ICTR = I
               GO TO 1020
 1010       CONTINUE
 1020       MAPCTR(IAT,IT) = ICTR
            NS3 = KS(ICTR)-1
            DO 1030 ISH = 1,NS2
               MAPSHL(NS1+ISH,IT) = NS3+ISH
 1030       CONTINUE
 1040    CONTINUE
 1050 CONTINUE
C
C     ----- READ COORDINATES FROM DAF IF REQUESTED -----
C     THESE WILL BE USED IN PLACE OF THOSE JUST READ.
C
      IF(GEOM.EQ.DAF) CALL DAREAD(IDAF,IODA,C,3*NAT,1,0)
C
C     ----- PRINT ATOMIC COORDINATES AND SHELL DESCRIPTIONS -----
C
      IF (MASWRK) THEN
         IF(NFG.EQ.0) THEN
            WRITE (IW,9050)
            DO 1100 IAT = 1,NAT
               WRITE (IW,9060) A(IAT),B(IAT),ZAN(IAT),
     *                         C(1,IAT),C(2,IAT),C(3,IAT)
 1100       CONTINUE
         ELSE
            WRITE (IW,9055)
            DO 1150 IAT = 1,NAT
               WRITE (IW,9065) A(IAT),B(IAT),ZAN(IAT)
 1150       CONTINUE
         END IF
      END IF
C
C     ----- PRINT INTERNUCLEAR DISTANCE TABLE -----
C
      IF(NFG.EQ.0) CALL INTR
C
C     ----- FILL MPC COORDINATE ARRAY AND SKIP BASIS SET OUTPUT -----
C
      IF(MPCTYP.NE.NONE) THEN
         CALL RDMOL
         GO TO 1530
      END IF
C
C     ----- PRINT OUT THE BASIS FUNCTIONS USED -----
C
      IF (MASWRK) THEN
      IF(NFG.EQ.0) THEN
        WRITE (IW,9080)
      ELSE
        WRITE (IW,9085)
      END IF
      IF(NORMP .NE. 1) WRITE (IW,9090)
      IF(NORMF .NE. 1) WRITE (IW,9100)
      WRITE (IW,9110)
      MLDUDF=0
      MLDNDA=0
C
      DO 1420 IAT = 1,NAT
         DO 1260 IT = 1,NT
            IF(MAPCTR(IAT,IT) .GT. IAT) GO TO 1420
 1260    CONTINUE
         WRITE (IW,9120) A(IAT),B(IAT)
         IF(FRNDLY) THEN
            CALL SETLAB(2,ATMSYM)
            WRITE (NFT16,FMT='(4HHOND/4HHOND,A8,A2,F5.1,3F20.10)')
     1         A(IAT),B(IAT),ZAN(IAT),C(1,IAT),C(2,IAT),C(3,IAT)
            WRITE (NFT16,FMT='(8HGAME!!!!,3F20.10,F5.0,2X,A2)')
     1         C(1,IAT),C(2,IAT),C(3,IAT),ZAN(IAT),ATMSYM(IAT)
            WRITE (NFT16,FMT='(4HGAUS,A2,2X,1H0)') ATMSYM(IAT)
            WRITE (NFT16,7340) ATMSYM(IAT),ZAN(IAT),(C(JJ,IAT),JJ=1,3)
         END IF
         NS1 = KS(IAT)
         NS2 = NS1+NS(IAT)-1
         MLDNDA=MLDNDA+1
         DO 1270 ISH=1,5
           MELDIX(ISH)=0
 1270    CONTINUE
         DO 1400 ISH = NS1,NS2
            WRITE (IW,9130)
            I1 = KSTART(ISH)
            I2 = I1+KNG(ISH)-1
            ITYP = INTYP(ISH)
            IF(FRNDLY) THEN
            TEMPLA=LABEL(ITYP)
            IF(TEMPLA.EQ.LABEL(6)) TEMPLA=SPLAB
            IF(TEMPLA.EQ.SPLAB) THEN
              WRITE(NFT16,FMT='(4HHOND,I5,3X,A2,I5)') ISH,TEMPLA,
     1                                                I2-I1+1
            ELSE
              WRITE(NFT16,FMT='(4HHOND,I5,4X,A1,I5)') ISH,TEMPLA,
     1                                                I2-I1+1
            END IF
            WRITE(NFT16,FMT='(4HGAME,A2,4X,A2)')
     *              LABEL(ITYP),ATMSYM(IAT)
            WRITE(NFT16,FMT='(4HGAUS,2X,A2,I5,2X,4H1.00)')
     *              TEMPLA,I2-I1+1
            MLDUDF=MLDUDF+1
            MELDMP=0
            IF(ITYP.LT.5) THEN
              MELDIX(ITYP)=MELDIX(ITYP)+1
              WRITE(UNIT=MLDLAB,FMT='(I2,A1,A2,1X,A2)')
     *              MELDIX(ITYP),LABEL(ITYP),ATMSYM(IAT),ATMSYM(IAT)
              READ(UNIT=MLDLAB,FMT='(A8)')
     *              RMLDMP(MELDIX(ITYP),ITYP,MLDNDA)
            ELSE
              MLDUDF=MLDUDF+1
              MELDIX(1)=MELDIX(1)+1
              MELDIX(2)=MELDIX(2)+1
              WRITE(UNIT=MLDLAB,FMT='(I2,1HS,A2,1X,A2)')
     *              MELDIX(1),ATMSYM(IAT),ATMSYM(IAT)
              READ(UNIT=MLDLAB,FMT='(A8)')
     *              RMLDMP(MELDIX(1),1,MLDNDA)
              WRITE(UNIT=MLDLAB,FMT='(I2,1HP,A2,1X,A2)')
     *              MELDIX(2),ATMSYM(IAT),ATMSYM(IAT)
              READ(UNIT=MLDLAB,FMT='(A8)')
     *              RMLDMP(MELDIX(2),2,MLDNDA)
            END IF
            END IF
C
C       PRINT ALL GAUSSIAN EXPONENTS AND CONTRACTION COEFS IN THIS AO
C
            DO 1380 IG = I1,I2
C
C         -ITYP- IS AN INDEX INTO THE TABLE OF -LABEL- VALUES ABOVE.
C         1-7=S,P,D,F,G,H,I AND 8=L ARE THE BASIC TYPES OF MOST SETS.
C         9-27 ARE ARCHAIC UNDOCUMENTED STO SUBSHELLS STRINGS, WHICH
C         CONSIST OF S,P,D,L AND UNIMPLEMENTED -M- SHELLS.
C
               GO TO (1280,1290,1300,1310,
     *                1320,1330,1340,1350,
     *                1280,
     *                1280,1290,     1350,
     *                1280,1290,1300,1350,1360,
     *                1280,1290,1300,1350,1360,
     *                1280,1290,1300,1350,1360), ITYP
C
 1280          CONTINUE
               C1=CSINP(IG)
               WRITE(IW,9140) ISH,LABEL(ITYP),IG,EX(IG),C1
C
               IF (FRNDLY) THEN
               WRITE(NFT16,FMT='(4HHOND,I5,G15.9,2G20.10)') IG,EX(IG),C1
               WRITE(NFT16,FMT='(4HGAME,2G17.8)') C1,EX(IG)
               WRITE(NFT16,FMT='(4HGAUS,2G20.10)') EX(IG),C1
               MELDMP=MELDMP+1
               XMELD(MELDMP)=EX(IG)
               SMELD(MELDMP)=C1
               END IF
               GO TO 1380
C
 1290          CONTINUE
               C1=CPINP(IG)
               WRITE(IW,9140) ISH,LABEL(ITYP),IG,EX(IG),C1
C
               IF (FRNDLY) THEN
               WRITE(NFT16,FMT='(4HHOND,I5,G15.9,2G20.10)') IG,EX(IG),C1
               WRITE(NFT16,FMT='(4HGAME,2G17.8)') C1,EX(IG)
               WRITE(NFT16,FMT='(4HGAUS,2G20.10)') EX(IG),C1
               MELDMP=MELDMP+1
               XMELD(MELDMP)=EX(IG)
               SMELD(MELDMP)=C1
               END IF
               GO TO 1380
C
 1300          CONTINUE
               C1=CDINP(IG)
               WRITE(IW,9140) ISH,LABEL(ITYP),IG,EX(IG),C1
C
               IF (FRNDLY) THEN
               WRITE(NFT16,FMT='(4HHOND,I5,G15.9,2G20.10)') IG,EX(IG),C1
               WRITE(NFT16,FMT='(4HGAME,2G17.8)') C1,EX(IG)
               WRITE(NFT16,FMT='(4HGAUS,2G20.10)') EX(IG),C1
               MELDMP=MELDMP+1
               XMELD(MELDMP)=EX(IG)
               SMELD(MELDMP)=C1
               END IF
               GO TO 1380
C
 1310          CONTINUE
               C1=CFINP(IG)
               WRITE(IW,9140) ISH,LABEL(ITYP),IG,EX(IG),C1
C
               IF (FRNDLY) THEN
               WRITE(NFT16,FMT='(4HHOND,I5,G15.9,2G20.10)') IG,EX(IG),C1
               WRITE(NFT16,FMT='(4HGAME,2G17.8)') C1,EX(IG)
               WRITE(NFT16,FMT='(4HGAUS,2G20.10)') EX(IG),C1
               MELDMP=MELDMP+1
               XMELD(MELDMP)=EX(IG)
               SMELD(MELDMP)=C1
               END IF
               GO TO 1380
C
 1320          CONTINUE
               C1=CGINP(IG)
               WRITE(IW,9140) ISH,LABEL(ITYP),IG,EX(IG),C1
C
               IF (FRNDLY) THEN
               WRITE(NFT16,FMT='(4HHOND,I5,G15.9,2G20.10)') IG,EX(IG),C1
               WRITE(NFT16,FMT='(4HGAME,2G17.8)') C1,EX(IG)
               WRITE(NFT16,FMT='(4HGAUS,2G20.10)') EX(IG),C1
               MELDMP=MELDMP+1
               XMELD(MELDMP)=EX(IG)
               SMELD(MELDMP)=C1
               END IF
               GO TO 1380
C
 1330          CONTINUE
               C1=CHINP(IG)
               WRITE(IW,9140) ISH,LABEL(ITYP),IG,EX(IG),C1
C
               IF (FRNDLY) THEN
               WRITE(NFT16,FMT='(4HHOND,I5,G15.9,2G20.10)') IG,EX(IG),C1
               WRITE(NFT16,FMT='(4HGAME,2G17.8)') C1,EX(IG)
               WRITE(NFT16,FMT='(4HGAUS,2G20.10)') EX(IG),C1
               MELDMP=MELDMP+1
               XMELD(MELDMP)=EX(IG)
               SMELD(MELDMP)=C1
               END IF
               GO TO 1380
C
 1340          CONTINUE
               C1=CIINP(IG)
               WRITE(IW,9140) ISH,LABEL(ITYP),IG,EX(IG),C1
C
               IF (FRNDLY) THEN
               WRITE(NFT16,FMT='(4HHOND,I5,G15.9,2G20.10)') IG,EX(IG),C1
               WRITE(NFT16,FMT='(4HGAME,2G17.8)') C1,EX(IG)
               WRITE(NFT16,FMT='(4HGAUS,2G20.10)') EX(IG),C1
               MELDMP=MELDMP+1
               XMELD(MELDMP)=EX(IG)
               SMELD(MELDMP)=C1
               END IF
               GO TO 1380
C                                THIS IS -L- SHELLS OF -S- AND -P-
 1350          CONTINUE
               C1=CSINP(IG)
               C2=CPINP(IG)
               WRITE (IW,9140) ISH,LABEL(ITYP),IG,EX(IG),C1,C2
C
               IF (FRNDLY) THEN
               WRITE(NFT16,FMT='(4HHOND,I5,G15.9,2G20.10)') IG,EX(IG),
     1                                                      C1,C2
               WRITE(NFT16,FMT='(4HGAME,3G17.8)') C1,EX(IG),C2
               WRITE(NFT16,FMT='(4HGAUS,3G20.10)') EX(IG),C1,C2
               MELDMP=MELDMP+1
               XMELD(MELDMP)=EX(IG)
               SMELD(MELDMP)=C1
               PMELD(MELDMP)=C2
               END IF
               GO TO 1380
C
 1360          CONTINUE
               IF(MASWRK) WRITE(IW,*) 'STO -M- SHELLS DO NOT EXIST'
               CALL ABRT
C
 1380       CONTINUE
C
C         PREPARE BASIS INPUT FOR OTHER PROGRAMS
C
      IF (FRNDLY) THEN
C
      IF(ITYP.LT.8) THEN
C     ... S, P, D, F, G, H, I ORBITALS
       IF(MELDMP.LE.2) THEN
        WRITE(NFT16,FMT='(4HMELD,I2,A1,A2,2X,I2,2X,A1,4X,4G16.8)')
     1   MELDIX(ITYP),LABEL(ITYP),ATMSYM(IAT),MELDMP,LABEL(ITYP),
     2   (SMELD(IG),IG=1,MELDMP),
     3   (XMELD(IG),IG=1,MELDMP)
       ELSE IF(MELDMP.GT.2 .AND. MELDMP.LE.4) THEN
        WRITE(NFT16,FMT='(4HMELD,I2,A1,A2,2X,I2,2X,A1,4X,4G16.8)')
     1   MELDIX(ITYP),LABEL(ITYP),ATMSYM(IAT),MELDMP,LABEL(ITYP),
     2   (SMELD(IG),IG=1,MELDMP)
        WRITE(NFT16,FMT='(4HMELD,16X,4G16.8)')
     1   (XMELD(IG),IG=1,MELDMP)
       ELSE
        WRITE(NFT16,FMT='(4HMELD,I2,A1,A2,2X,I2,2X,A1)')
     1   MELDIX(ITYP),LABEL(ITYP),ATMSYM(IAT),MELDMP,LABEL(ITYP)
        WRITE(NFT16,FMT='(4HMELD,5G16.8)') (SMELD(IG),IG=1,MELDMP)
        WRITE(NFT16,FMT='(4HMELD,5G16.8)') (XMELD(IG),IG=1,MELDMP)
       END IF
      ELSE
C      ...      SP SHELLS
       IF(MELDMP.LE.2) THEN
        WRITE(NFT16,FMT='(4HMELD,I2,1HS,A2,2X,I2,2X,1HS,4X,4G16.8)')
     1   MELDIX(1),               ATMSYM(IAT),        MELDMP,
     2   (SMELD(IG),IG=1,MELDMP),
     1   (XMELD(IG),IG=1,MELDMP)
        WRITE(NFT16,FMT='(4HMELD,I2,1HP,A2,2X,I2,2X,1HP,4X,4G16.8)')
     1   MELDIX(1),               ATMSYM(IAT),        MELDMP,
     2   (PMELD(IG),IG=1,MELDMP),
     1   (XMELD(IG),IG=1,MELDMP)
       ELSE IF(MELDMP.GT.2 .AND. MELDMP.LE.4) THEN
        WRITE(NFT16,FMT='(4HMELD,I2,1HS,A2,2X,I2,2X,1HS,4X,4G16.8)')
     1   MELDIX(1),               ATMSYM(IAT),        MELDMP,
     2   (SMELD(IG),IG=1,MELDMP)
        WRITE(NFT16,FMT='(4HMELD,16X,4G16.8)')
     1   (XMELD(IG),IG=1,MELDMP)
        WRITE(NFT16,FMT='(4HMELD,I2,1HP,A2,2X,I2,2X,1HP,4X,4G16.8)')
     1   MELDIX(1),               ATMSYM(IAT),        MELDMP,
     2   (PMELD(IG),IG=1,MELDMP)
        WRITE(NFT16,FMT='(4HMELD,16X,4G16.8)')
     1   (XMELD(IG),IG=1,MELDMP)
       ELSE
        WRITE(NFT16,FMT='(4HMELD,I2,1HS,A2,2X,I2,2X,1HS)')
     1   MELDIX(1),               ATMSYM(IAT),        MELDMP
        WRITE(NFT16,FMT='(4HMELD,5G16.8)') (SMELD(IG),IG=1,MELDMP)
        WRITE(NFT16,FMT='(4HMELD,5G16.8)') (XMELD(IG),IG=1,MELDMP)
        WRITE(NFT16,FMT='(4HMELD,I2,1HP,A2,2X,I2,2X,1HP)')
     1  MELDIX(2),                ATMSYM(IAT),        MELDMP
        WRITE(NFT16,FMT='(4HMELD,5G16.8)') (PMELD(IG),IG=1,MELDMP)
        WRITE(NFT16,FMT='(4HMELD,5G16.8)') (XMELD(IG),IG=1,MELDMP)
       END IF
      END IF
      END IF
C              END LOOP OVER SHELLS FOR THIS ATOM
 1400    CONTINUE
C
      IF (FRNDLY) THEN
        WRITE(NFT16,FMT='(4HGAUS,4H****)')
      END IF
C              END LOOP OVER ATOMS
 1420 CONTINUE
C
      IF (FRNDLY) THEN
      WRITE(NFT16,FMT='(4HGAUS,1H )')
      WRITE(NFT16,FMT='(8HGAMEEND )')
      WRITE(NFT16,7350) MLDUDF
C
C     ... WATCH OUT -- RAMS(VIBANL) WILL BE CALLED AGAIN !
C     ... IF THIS CAUSES PROBLEMS, KILL THE CALL HERE
C     ... AND PRINT 0.0 INSTEAD OF ZMASS(IAT)
C
      CALL RAMS(ZMASS,0)
      WRITE(NFT16,
     1   FMT='(''GAME!!!! ATOMIC COORDINATES BLOCK (IN A.U.)'')')
      WRITE(NFT16,
     1   FMT='(''GAUS!!!! CART COORDINATES TO REPLACE ZMAT ABOVE'')')
      DO 1431 IAT = 1,NAT
         WRITE (NFT16,FMT='(4HGAME,3F17.12,F6.0,2X,A2)')
     1      C(1,IAT),C(2,IAT),C(3,IAT),ZAN(IAT),ATMSYM(IAT)
         WRITE(NFT16,7360) ATMSYM(IAT), ZAN(IAT),ZMASS(IAT),
     *                     C(1,IAT),C(2,IAT),C(3,IAT)
         WRITE(NFT16,FMT='(4HGAUS,A2,3F17.12)')
     1                   ATMSYM(IAT),
     2                   C(1,IAT),C(2,IAT),C(3,IAT)
 1431 CONTINUE
      WRITE(NFT16,FMT='(''GAME!!!! END OF ATOMIC COORDINATES BLOCK'')')
C
      WRITE(NFT16,FMT='(''MELDENDGEOMETRY'')')
      WRITE(NFT16,FMT='(''MELD$''/''MELD$ BASIS_SET-TO-ATOM MAPPING'')')
      MLDSUM=0
      DO 1437 MLD2S=1,5
        DO 1436 MLD2A=1,MLDNDA
          MLD2X=0
          DO 1435 MLD2C=1,MAXGSH
            IF(RMLDMP(MLD2C,MLD2S,MLD2A).NE.0) MLD2X=MLD2X+1
 1435     CONTINUE
          IF(MLD2X.GT.0) THEN
            WRITE(NFT16,FMT='((4HMELD,6(1X,A8,1X,2H**)))')
     *         (RMLDMP(MLD2C,MLD2S,MLD2A),MLD2C=1,MLD2X)
            MLDSUM=MLDSUM+MLD2X
          END IF
 1436   CONTINUE
 1437 CONTINUE
      WRITE(NFT16,1439) MLDSUM
 1439 FORMAT('MELDEND  $ OF BASIS_SET-TO-ATOM MAPPING SECTION'/
     *       'MELD$ ===> THE TOTAL NO. OF SYMMETRY-UNIQUE FUNCTIONS IS',
     *        I4)
C
      WRITE(NFT16,FMT='(4HHOND/''HOND $END'')')
C
      CALL FLSHBF(NFT16)
      END IF
C
C     ----- OPTIONAL PRINTOUT OF BASIS SYMMETRY INFO -----
C
      IF(NPRINT .NE. 1) GO TO 1530
      WRITE (IW,9150)
      WRITE (IW,9160)
      IMAX = 0
 1440 IMIN = IMAX+1
      IMAX = IMAX+15
      IF(IMAX .GT. NT) IMAX = NT
      IMAX1 = IMAX+1
      WRITE (IW,9170)
      WRITE (IW,9180) (LINEV,I = IMIN,IMAX1)
      WRITE (IW,9180) (LINEV,I = IMIN,IMAX1)
      WRITE (IW,9190) LINEV,(I,I = IMIN,IMAX)
      WRITE (IW,9180) (LINEV,I = IMIN,IMAX1)
      WRITE (IW,9180) (LINEV,I = IMIN,IMAX1)
      WRITE (IW,9180) (LINE ,I = IMIN,IMAX1)
      DO 1460 IAT = 1,NAT
         WRITE (IW,9180) (LINEV,I = IMIN,IMAX1)
         WRITE (IW,9180) (LINEV,I = IMIN,IMAX1)
         WRITE (IW,9200) IAT,(MAPCTR(IAT,I),I = IMIN,IMAX)
         WRITE (IW,9180) (LINEV,I = IMIN,IMAX1)
         WRITE (IW,9180) (LINEV,I = IMIN,IMAX1)
         WRITE (IW,9180) (LINE ,I = IMIN,IMAX1)
 1460 CONTINUE
      IF(IMAX .LT. NT) GO TO 1440
      WRITE (IW,9150)
      WRITE (IW,9210)
      IMAX = 0
 1480 IMIN = IMAX+1
      IMAX = IMAX+15
      IF(IMAX .GT. NT) IMAX = NT
      IMAX1 = IMAX+1
      WRITE (IW,9170)
      WRITE (IW,9180) (LINEV,I = IMIN,IMAX1)
      WRITE (IW,9180) (LINEV,I = IMIN,IMAX1)
      WRITE (IW,9190) LINEV,(I,I = IMIN,IMAX)
      WRITE (IW,9180) (LINEV,I = IMIN,IMAX1)
      WRITE (IW,9180) (LINEV,I = IMIN,IMAX1)
      WRITE (IW,9180) (LINE ,I = IMIN,IMAX1)
      DO 1500 ISH = 1,NSHELL
         WRITE (IW,9180) (LINEV,I = IMIN,IMAX1)
         WRITE (IW,9180) (LINEV,I = IMIN,IMAX1)
         WRITE (IW,9200) ISH,(MAPSHL(ISH,I),I = IMIN,IMAX)
         WRITE (IW,9180) (LINEV,I = IMIN,IMAX1)
         WRITE (IW,9180) (LINEV,I = IMIN,IMAX1)
         WRITE (IW,9180) (LINE ,I = IMIN,IMAX1)
 1500 CONTINUE
      IF(IMAX .LT. NT) GO TO 1480
      WRITE (IW,9150)
      WRITE (IW,9220)
      IMAX = 0
 1520 IMIN = IMAX+1
      IMAX = IMAX+15
      IF(IMAX .GT. NT) IMAX = NT
      IMAX1 = IMAX+1
      WRITE (IW,9170)
      WRITE (IW,9180) (LINEV,I = IMIN,IMAX1)
      WRITE (IW,9180) (LINEV,I = IMIN,IMAX1)
      WRITE (IW,9190) LINEV,(I,I = IMIN,IMAX)
      WRITE (IW,9180) (LINEV,I = IMIN,IMAX1)
      WRITE (IW,9180) (LINEV,I = IMIN,IMAX1)
      WRITE (IW,9180) (LINE ,I = IMIN,IMAX1)
      WRITE (IW,9180) (LINEV,I = IMIN,IMAX1)
      WRITE (IW,9180) (LINEV,I = IMIN,IMAX1)
      WRITE (IW,9190) LINEV,(INVT(I),I = IMIN,IMAX)
      WRITE (IW,9180) (LINEV,I = IMIN,IMAX1)
      WRITE (IW,9180) (LINEV,I = IMIN,IMAX1)
      WRITE (IW,9180) (LINE ,I = IMIN,IMAX1)
      IF(IMAX .LT. NT) GO TO 1520
      END IF
 1530 CONTINUE
C
C     KILL JOB IF DIMENSIONS HAVE BEEN EXCEEDED
C
 1540 CONTINUE
      IF(NAT .LE. MXATM) GO TO 1560
      IF (MASWRK) WRITE (IW,9230) MXATM
      CALL ABRT
C
 1560 IF(NSHELL .LE. MXSH) GO TO 1580
      IF (MASWRK) WRITE (IW,9240) MXSH
      CALL ABRT
C
 1580 IF(LOC .LE. MXAO) GO TO 1600
      IF (MASWRK) WRITE (IW,9250) MXAO
      CALL ABRT
C
 1600 IF(NGAUSS .LE. MXGTOT) GO TO 1620
      IF (MASWRK) WRITE (IW,9260) MXGTOT
      CALL ABRT
C
C     ESTABLISH NUMBER OF ELECTRONS, MULTIPLICITY, ETC.
C     LATER, NQMT MAY BE RESET TO VALUES SMALLER THAN NUM.
C
 1620 CONTINUE
C
C     --- SOME NEO RUNS REQUIRE REMOVAL OF ELECTRONS
C     DUE TO EXTRA BASIS FUNCTIONS ---
C
      NE = NE - NELERM
C
      NUM  = LOC
      NQMT = LOC
      NE = NE-ICH
      NA = (NE+MUL-1)/2
      NB = (NE-MUL+1)/2
      IF (MASWRK) THEN
         WRITE(IW,9270) NSHELL,NUM
         IF(NFG.EQ.0) THEN
            IF(ISPHER.EQ.1) WRITE(IW,9271)
            WRITE(IW,9272) NE,ICH,MUL,NA,NB,NAT
         END IF
      END IF
C
C     ----- CALCULATE "CORRECT" NRE FIRST -----
C     THIS UTILIZES TRUE NUCLEAR CHARGES, NOT OMITTING
C     ANY PROTONS YET FOR SEMI-EMPIRICAL OR FOR ECP RUNS.
C
      MPCSAV = MPCTYP
      MPCTYP = NONE
      ENUCR  = ENUC(NAT,ZAN,C)
      MPCTYP = MPCSAV
      IF (MASWRK.AND.NFG.EQ.0) THEN
         WRITE(IW,9280) ENUCR
         IF(IECP.NE.0) WRITE(IW,9282)
      END IF
C
C       MULTIPLICITY CHECKS
C       FMO RUNS DO NOT READ $DATA AND THEREFORE DO NOT KNOW -NE-
C       RUNTYP=MEX SETS ITS WAVEFUNCTIONS LATER, SKIP CHECKING HERE
C
      IF(SCFTYP.EQ.RHF .AND. MUL.NE.1  .AND.  RUNTYP.NE.AMEX) THEN
         IF (MASWRK) WRITE(IW,9300)
         CALL ABRT
      END IF
C
      IF(NFG.EQ.0  .AND.  RUNTYP.NE.AMEX) THEN
         IF(NA+NB .NE. NE) THEN
            IF (MASWRK) WRITE(IW,9290) NE,ICH,MUL
            CALL ABRT
         END IF
C              IMPOSSIBLY HIGH, LOW, OR MISMATCHED TO E- COUNT
         IDUM=MUL+NE
         IF(MUL.GT.NE+1 .OR. MUL.LT.0 .OR. 2*INT(IDUM/2).EQ.IDUM) THEN
           IF (MASWRK) WRITE(IW,*) ' IMPOSSIBLE SPIN MULTIPLICITY '
           CALL ABRT
         END IF
      END IF
C
C     WRITE ENERGY, MULTIPLICITY RECORD TO DAF
C
      IF(IREST.GT.0) CALL DAREAD(IDAF,IODA,ENUCR,MXRT+15,2,0)
      IF(IREST.GT.0) RETURN
      EELCT= ZERO
      ETOT = ENUCR
      SZ   = (MUL+1)/TWO
      SZZ  = SZ*(SZ+ONE)
      ECORE= ZERO
      ESCF = ZERO
      EERD = ZERO
      E1   = ZERO
      E2   = ZERO
      VEN  = ZERO
      VEE  = ZERO
      EPOT = ZERO
      EKIN = ZERO
      DO 1640 I=1,10
         ESTATE(I)=ZERO
 1640 CONTINUE
      STATN=ZERO
      CALL DAWRIT(IDAF,IODA,ENUCR,MXRT+15,2,0)
C
C     --- FILL APPROPRIATE PARAMETER ARRAYS FOR MOPAC WAVEFUNCTIONS ---
C
      IF(MPCTYP.NE.NONE) CALL MOLDAT(0)
C
      RETURN
C
 7400 FORMAT(1X,'*** EXTERNAL BASIS SET FILE NOT FOUND ***'/
     *       1X,'FILE NAME SOUGHT WAS'/1X,A)
 7405 FORMAT(/1X,'THE EXTERNAL BASIS SET FILE BEING READ IS'/
     *        5X,'"',A,'"')
 7500 FORMAT(1X,'*** ELEMENT "',A2,'" BASIS "',A8,
     *          '" WAS NOT FOUND IN THE EXTERNAL BASIS FILE ***'/
     *       1X,'BASIS FILE NAME SEARCHED WAS'/1X,A)
C
 8000 FORMAT(3X,A5,I4)
 8010 FORMAT(3X,I3,1X,F25.10,2F12.8)
C
 9005 FORMAT(1X,'ERROR OCCURED READING ATOM NO.',I4,
     *          ', INPUT ATOM NO.',I5,', NAME=',A10/
     *       1X,'CHARGE=',F5.1,' X,Y,Z=',3F15.8)
 9008 FORMAT(A10,F5.1,3F18.10)
 9009 FORMAT(1X,A10)
 9010 FORMAT(1X,'*** ERROR, NO MORE THAN',I6,' GAUSSIANS PER SHELL')
 9020 FORMAT(1X,'*** ERROR, ILLEGAL BASIS FUNCTION TYPE=',A8,
     *       1X,'IGAUSS=',I4)
 9030 FORMAT(1X,'ATOM ',A10,' CHARGE ',F5.1,' POLARIZATION TYPE ',A4,
     *       ' HAS NO EXPONENT DEFINITION.')
 9040 FORMAT(1X,'*** WARNING! ATOM',I4,' SHELL',I5,' TYPE ',A1,
     *       ' HAS NORMALIZATION',F13.8)
 9043 FORMAT(1X,'*** ERROR, INPUT ATOM',I4,' HAS ZERO EXPONENT FOR ',
     *         'BASIS FUNCTION TYPE',A4)
 9045 FORMAT(//1X,'ERROR!'/
     *       1X,'YOUR CART/ZMT/ZMTMPC INPUT GENERATED',I5,' ATOMS,'/
     *       1X,'BUT ONLY',I5,' ATOMS WERE PRESENT IN YOUR $DATA.'/
     *       1X,'THIS MEANS THERE IS A MISTAKE IN YOUR COORDINATES,'/
     *       1X,'OR YOUR CHOICE OF GROUP.   ADIOS, MY FRIEND!!'//
     *       1X,'AFTER PRINCIPAL AXIS TRANSFORMATION, THE PROGRAM'/
     *       1X,'HAS CHOSEN THE FOLLOWING ATOMS AS BEING UNIQUE:')
 9046 FORMAT(1X,A10,F5.1,3F16.10)
 9050 FORMAT(/1X,'ATOM',6X,'ATOMIC',22X,'COORDINATES (BOHR)'/
     *         11X,'CHARGE',9X,'X',19X,'Y',19X,'Z')
 9055 FORMAT(/1X,'ATOM',3X,'ATOMIC CHARGE')
 9060 FORMAT(1X,A8,A2,F5.1,F17.10,2F20.10)
 9065 FORMAT(1X,A8,A2,F5.1)
 9080 FORMAT(/5X,'ATOMIC BASIS SET'/5X,16(1H-))
 9085 FORMAT(/5X,'ATOMIC BASIS SET LIBRARY'/5X,16(1H-))
 9090 FORMAT(1X,'THE CONTRACTED PRIMITIVE FUNCTIONS HAVE BEEN',
     *          ' UNNORMALIZED')
 9100 FORMAT(1X,'THE CONTRACTED BASIS FUNCTIONS ARE NOW NORMALIZED',
     *          ' TO UNITY')
 9110 FORMAT(/1X,' SHELL TYPE  PRIMITIVE        EXPONENT',
     *       10X,'CONTRACTION COEFFICIENT(S)')
 9120 FORMAT(/1X,A8,A2)
 9130 FORMAT(1X)
C        BRETT SAYS MACMOLPLT HAS 5 COLUMN ASSUMPTION BETWEEN
C        SHELL COUNTER AND BASIS TYPE, HENCE 3X,A2 IS THE ONLY
C        RIGIDLY UNCHANGEABLE PART OF THIS FORMAT STATEMENT:
 9140 FORMAT(1X,I6,3X,A2,I7,F22.7,2F18.12)
 9150 FORMAT('1')
 9160 FORMAT(/' **** TRANSFORMATION TABLE OF ATOMS *****'/
     *       30X,15H ROWS ARE ATOMS/
     *       30X,'COLUMNS ARE SYMMETRY OPERATIONS')
 9180 FORMAT(1X,16A8)
 9190 FORMAT(1X,A8,15(2X,I2,3X,1H*))
 9170 FORMAT(/)
 9200 FORMAT(1X,16(2X,I2,3X,1H*))
 9210 FORMAT(/1X,5H*****,31H TRANSFORMATION TABLE OF SHELLS, 5H*****/
     *        30X,16H ROWS ARE SHELLS/
     *        30X,32H COLUMNS ARE SYMMETRY OPERATIONS)
 9220 FORMAT(/1X,'***** INVERSE TRANSFORMATIONS *****')
 9230 FORMAT(1X,'*** ERROR, NO MORE THAN',I6,' TOTAL ATOMS')
 9240 FORMAT(1X,'*** ERROR, NO MORE THAN',I6,' TOTAL SHELLS')
 9250 FORMAT(1X,'*** ERROR, NO MORE THAN',I6,' TOTAL BASIS FUNCTIONS')
 9260 FORMAT(1X,'*** ERROR, NO MORE THAN',I6,' TOTAL GAUSSIANS')
 9270 FORMAT(/1X,'TOTAL NUMBER OF BASIS SET SHELLS             =',I5/
     *        1X,'NUMBER OF CARTESIAN GAUSSIAN BASIS FUNCTIONS =',I5)
 9271 FORMAT(1X,'NOTE: THIS RUN WILL RESTRICT THE MO VARIATION SPACE',
     *          ' TO SPHERICAL HARMONICS.'/
     *       1X,'THE NUMBER OF ORBITALS KEPT IN THE VARIATIONAL SPACE',
     *          ' WILL BE PRINTED LATER.')
 9272 FORMAT( 1X,'NUMBER OF ELECTRONS                          =',I5/
     *        1X,'CHARGE OF MOLECULE                           =',I5/
     *        1X,'SPIN MULTIPLICITY                            =',I5/
     *        1X,'NUMBER OF OCCUPIED ORBITALS (ALPHA)          =',I5/
     *        1X,'NUMBER OF OCCUPIED ORBITALS (BETA )          =',I5/
     *        1X,'TOTAL NUMBER OF ATOMS                        =',I5)
 9280 FORMAT(1X,'THE NUCLEAR REPULSION ENERGY IS',F20.10)
 9282 FORMAT(1X,'NOTE THIS RUN IS USING CORE POTENTIALS, AND THE',
     *          ' NUMBER OF ELECTRONS,'/
     *       1X,'OCCUPIED ORBITALS, AND NUCLEAR REPULSION',
     *          ' ENERGY WILL BE ADJUSTED BELOW'/
     *       1X,'AFTER REMOVAL OF THE CORE CHARGES.')
 9290 FORMAT(//1X,'*** CHECK YOUR INPUT CHARGE AND MULTIPLICITY ***'/
     *       1X,'THERE ARE',I6,' ELECTRONS, WITH CHARGE ICHARG=',I3/
     *       1X,'BUT YOU SELECTED MULTIPLICITY MULT=',I3)
 9300 FORMAT(//1X,'*** SCFTYP=RHF MUST HAVE MULT=1 ***')
      END
C*MODULE INPUTA  *DECK READAT
      SUBROUTINE READAT(ATOMNM,ZNUC,X,Y,Z,C,NAT,ICOORD,IUNTRD)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      CHARACTER*10 ATOMNM,ENDWRD,BLANK
      CHARACTER*4 CDUMMY
C
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      EXTERNAL REREAD
C
C        THE FOLLOWING ARE HOLLERITH (1-4 CHARACTERS) VARIABLES
C
      REAL IMINUS,IPLUS,JCONX,JSIGN,NCONX
C
      PARAMETER (MXATM=2000)
C
      DIMENSION C(3,MXATM),CC(3,MXATM+4),XYZ(3),XYZ0(3),T(3,3),
     *          NCONX(7)
C
      COMMON /INTNAL/ BOND(MXATM),ALPHA(MXATM),BETA(MXATM),SGN(MXATM),
     *                ICONX(MXATM),IATCON(3,MXATM),INATOM(MXATM),
     *                NATIN,IUNT
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00, TWO=2.0D+00)
      PARAMETER (DEGREE=360.0D+00, UNIT=0.52917724924D+00)
C
      DATA NCONX /4HLC  ,4HPCC ,4HNPCC,4HCCPA,4HPTC ,4HTCT ,4H    /
      DATA ENDWRD,BLANK/'$END      ','          '/
      DATA IPLUS,IMINUS /1H+,1H-/
C
C     ----- READ ATOM, IN CARTESIAN OR HILDERBRANDT COORDINATES -----
C     ICOORD=0 MEANS COORD=HINT, -1 OR 1 MEANS COORD=UNIQUE,CART
C
      CDUMMY='    '
      PI2 = TWO * ACOS(-ONE)
      DFACT = ONE
      IF(IUNTRD.EQ.-1) DFACT = UNIT
      IF(ICOORD.EQ.0) GO TO 100
C
C     ----- CARTESIAN SECTION -----
C     READ(IR,*) ATOMNM,ZNUC,X,Y,Z
C
      IEOF = 0
      IERR = 0
      CALL RDCARD('$DATA 5U',IEOF)
         IF(IEOF.EQ.1) CALL ABRT
C
      KSIZE = -10
      CALL GSTRNG(ATOMNM,KSIZE)
      IF (ATOMNM.EQ.ENDWRD) RETURN
C
      NATIN = NATIN+1
      IF (ATOMNM.EQ.BLANK) THEN
         IF (MASWRK) WRITE(IW,9070) NATIN
         CALL ABRT
      END IF
C
      ZNUC = RFIND('ZNUC    ',IERR)
             IF(IERR.NE.0) CALL ABRT
      X = DFACT*RFIND('X       ',IERR)
             IF(IERR.NE.0) CALL ABRT
      Y = DFACT*RFIND('Y       ',IERR)
             IF(IERR.NE.0) CALL ABRT
      Z = DFACT*RFIND('Z       ',IERR)
             IF(IERR.NE.0) CALL ABRT
      RETURN
C
C     ----- READ IN INTERNAL COORDINATES -----
C     CONVERT TO CARTESIAN COORDINATES.
C
C     ANGLES MUST BE GIVEN IN DEGREES.
C
C     DEFAULT VALUES
C     BOND LENGTH = 0.0 ANGSTROM
C     ALPHA = 0.0 DEGREE
C     BETA  = 0.0 DEGREE
C     SIGN  = +
C     CONNECTION TYPE = LC = LINEAR CONNECTION
C     CONNECTION POINTS = 1. ORIGIN OF MASTER FRAME
C                         2. UNIT POINT ON X-AXIS OF MASTER FRAME
C                         3. UNIT POINT ON Y-AXIS OF MASTER FRAME
C
C     POSSIBLE CONNECTIONS ARE
C          1. LINEAR CONNNECTION                     -  LC-
C          2. PLANAR CENTRAL CONNECTION              - PCC-
C          3. NON-PLANAR CENTRAL CONNECTION          -NPCC-
C          4. CENTRAL CONNECTION WITH POLAR ANGLE    -CCPA-
C          5. PLANAR TERMINAL CONNECTION             - PTC-
C          6. TERMINAL CONNECTION WITH TORSION       - TCT-
C
  100 CONTINUE
      JCONX = 0
      R = ZERO
      ALPH = ZERO
      BET = ZERO
      JSIGN = 0
C        READ (IR,*) ATOMNM,ZNUC,JCONX,R,ALPH,BET,JSIGN,(IPT(I),I=1,3)
      IERR=0
      IEOF=0
      CALL RDCARD('$DATA 5U',IEOF)
          IF(IEOF.NE.0) CALL ABRT
      KSIZE = -10
      CALL GSTRNG(ATOMNM,KSIZE)
      IF(ATOMNM.EQ.ENDWRD) RETURN
C
      NATIN = NATIN+1
      IF(ATOMNM.EQ.BLANK) THEN
         IF (MASWRK) WRITE(IW,9070) NATIN
         CALL ABRT
      END IF
C
      ZNUC = RFIND('ZNUC    ',IERR)
              IF(IERR.NE.0) CALL ABRT
      KSIZE = -4
      CALL GSTRNG(CDUMMY,KSIZE)
      READ(UNIT=CDUMMY,FMT='(A4)') JCONX
      R    = RFIND('R       ',IERR) * DFACT
      ALPH = RFIND('ALPHA   ',IERR)
      BET  = RFIND('BETA    ',IERR)
      KSIZE = -1
      CALL GSTRNG(CDUMMY,KSIZE)
      READ(UNIT=CDUMMY,FMT='(A1)') JSIGN
C
      IPT=0
      DO 160 I=1,3
         IERR=30
         IF(I.EQ.1) IPT = IFIND('POINT1  ',IERR)
         IF(I.EQ.2) IPT = IFIND('POINT2  ',IERR)
         IF(I.EQ.3) IPT = IFIND('POINT3  ',IERR)
         IF(IERR.NE.0) THEN
            CALL REREAD
            KSIZE = -4
            CALL GSTRNG(CDUMMY,KSIZE)
            IPT=0
            IF(CDUMMY.EQ.'O   ') IPT=MXATM+1
            IF(CDUMMY.EQ.'I   ') IPT=MXATM+2
            IF(CDUMMY.EQ.'J   ') IPT=MXATM+3
            IF(CDUMMY.EQ.'K   ') IPT=MXATM+4
            IF(IPT.EQ.0) THEN
               IF(MASWRK) WRITE(IW,*) 'ILLEGAL HINT ATOM CONNECTIVITY'
               CALL ABRT
            END IF
         ELSE
            IF(IPT.EQ.0) THEN
               IF(I.EQ.1) IPT=MXATM+1
               IF(I.EQ.2) IPT=MXATM+2
               IF(I.EQ.3) IPT=MXATM+3
            END IF
         END IF
         JAT = IPT
         IF(IPT.LE.MXATM) JAT = INATOM(IPT)
         IATCON(I,NATIN) = JAT
  160 CONTINUE
C
      BOND(NATIN) = R
      ALPHA(NATIN) = ALPH*PI2/DEGREE
      BETA(NATIN) = BET*PI2/DEGREE
C
C        CC SHOULD BE IN ANGSTROMS, BUT C IS ALWAYS IN BOHR.
C        THE FOUR SPECIAL POINTS AT THE END OF CC ARE THE
C        ORIGIN, THEN I,J,K UNIT VECTORS, IN THAT ORDER.
C
      CALL VCLR(CC,1,3*(MXATM+4))
      CC(1,MXATM+2) = ONE
      CC(2,MXATM+3) = ONE
      CC(3,MXATM+4) = ONE
C
      DO 200 J = 1,NAT
      DO 200 I = 1,3
  200 CC(I,J) = C(I,J)*UNIT
C
      IF (JSIGN .NE. IMINUS) JSIGN = IPLUS
      SGN(NATIN) = ONE
      IF(JSIGN.EQ.IMINUS) SGN(NATIN) = -ONE
      KCONX = 8
      DO 240 K = 1,7
  240 IF (JCONX .EQ. NCONX(K)) KCONX = K
      IF (KCONX .LE. 7) GO TO 260
      IF (MASWRK) WRITE (IW,9068) NATIN
      CALL ABRT
C
  260 IF (KCONX .EQ. 7) KCONX = 1
      ICONX(NATIN) = KCONX
C
C     ----- CALCULATE CARTESIAN COORDINATES -----
C
      IAT1 = IATCON(1,NATIN)
      IAT2 = IATCON(2,NATIN)
      RAB = RIJ(CC,IAT1,IAT2)
      DO 280 I = 1,3
  280 T(I,1) = (CC(I,IAT2)-CC(I,IAT1))/RAB
      IF (KCONX .GT. 1) GO TO 320
C
C     ----- LINEAR CONNECTION -----
C
      DUM = -SGN(NATIN)*BOND(NATIN)
      DO 300 I = 1,3
  300 XYZ(I) = DUM*T(I,1)
      GO TO 540
C
C     ----- TRI-ATOMIC CONNECTION -----
C
  320 CONTINUE
      IAT3 = IATCON(3,NATIN)
      RAC = RIJ(CC,IAT1,IAT3)
      RBC = RIJ(CC,IAT2,IAT3)
C
C     ----- DEFINE LOCAL FRAME -----
C
      DO 340 I = 1,3
  340 T(I,2) = CC(I,IAT3)-CC(I,IAT1)
      DOT = T(1,1)*T(1,2)+T(2,1)*T(2,2)+T(3,1)*T(3,2)
      DO 360 I = 1,3
  360 T(I,2) = T(I,2)-DOT*T(I,1)
      DOT = T(1,2)*T(1,2)+T(2,2)*T(2,2)+T(3,2)*T(3,2)
      DOT = SQRT(DOT)
      DO 380 I = 1,3
  380 T(I,2) = T(I,2)/DOT
      T(1,3) = T(2,1)*T(3,2)-T(3,1)*T(2,2)
      T(2,3) = T(3,1)*T(1,2)-T(1,1)*T(3,2)
      T(3,3) = T(1,1)*T(2,2)-T(2,1)*T(1,2)
C
C     ----- DEFINE POLAR COODINATES -----
C
      ALPH = ALPHA(NATIN)
      PHI = ALPH
C
      GO TO (400,420,440,460,420,460),KCONX
C
  400 CALL ABRT
C
  420 THETA = ZERO
      GO TO 480
C
  440 BET = BETA(NATIN)
      GAM = ACOS((RAB*RAB+RAC*RAC-RBC*RBC)/(TWO*RAB*RAC))
      THETA = ACOS ((COS(BET)-COS(ALPH)*COS(GAM))/(SIN(ALPH)*
     +     SIN(GAM)))
      GO TO 500
C
  460 BET = BETA(NATIN)
      THETA = BET
      GO TO 500
C
  480 CONTINUE
      PHI = PHI*SGN(NATIN)
C
  500 CONTINUE
      THETA = THETA*SGN(NATIN)
      R = BOND(NATIN)
C
C     ----- GET CARTESIAN COORDINATES IN LOCAL FRAME -----
C
      XYZ0(1) = R*COS(PHI)
      XYZ0(2) = R*SIN(PHI)*COS(THETA)
      XYZ0(3) = R*SIN(PHI)*SIN(THETA)
C
C     ----- GET CARTESIAN COORDINATES IN MASTER FRAME -----
C
      DO 520 I = 1,3
      XYZ(I) = ZERO
      DO 520 J = 1,3
      XYZ(I) = XYZ(I)+T(I,J)*XYZ0(J)
  520 CONTINUE
  540 CONTINUE
      X = XYZ(1)+CC(1,IAT1)
      Y = XYZ(2)+CC(2,IAT1)
      Z = XYZ(3)+CC(3,IAT1)
      RETURN
C
 9068 FORMAT(1X,'ERROR IN HINT CONNECTION TYPE FOR ATOM',I5)
 9070 FORMAT(//1X,'*** ERROR!'/
     *    1X,'BLANK CARD FOUND WHILE TRYING TO READ INPUT ATOM',I5/
     *    1X,'POSSIBLE ERRORS INCLUDE:'/
     *    1X,'1. C1 GROUP SHOULD NOT HAVE A BLANK CARD AFTER IT.'/
     *    1X,'2. BOTH $BASIS GROUP AND BASIS SET IN $DATA GIVEN?'/
     *    1X,'3. EXTRANEOUS BLANK CARDS IN $DATA?')
      END
C*MODULE INPUTA  *DECK START
      SUBROUTINE START
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL PACK2E,LINEAR,OK,GOPARR,DSKWRK,MASWRK,AIMPAC,PLTORB,
     *        MOLPLT,RPAC,COREFL,MPTEST,HSSEND,OUT,
     *        GOTEG,STPT,PROJCT,MMONLY,QMMM,ABEL,ISEPS,USEPS,
     *        CARTSN,NUMGRD,GRDTST,ISGDDI,PAROUT,
     *        CANONC,FCORE,FORS,NOCI,EKT,LINSER
      INTEGER DDI_WORLD,DDI_GROUP
C
      PARAMETER(DDI_WORLD=0,DDI_GROUP=1)
      PARAMETER (MXAO=8192, MXATM=2000, MXSH=5000, MXGTOT=20000,
     *           MXFRG=1050, MXDFG=5, MXDPPT=MXFRG*MXDFG*12,
     *           MXNORO=250)
      PARAMETER (MXPRO=64)
C
      CHARACTER*4 ATM
      CHARACTER*6 BALTYP
      CHARACTER*10 UATOM
      DOUBLE PRECISION MOROKM,MAKEFP,MD,LCCD,NMR,MDTYP,METHMC
      INTEGER DDI_NP,DDI_ME,FLO,CEIL,DIFF
C
      DIMENSION COM(3,MXATM),VMOI(3)
C
      COMMON /BASSPH/ QMATOL,NSPHER
      COMMON /CIFILS/ NFT11,NFT12,NFT13,NFT14,NFT15,NFT16,IDAF20,NEMEMX
      COMMON /COORDN/ UZNUC(MXATM),CUNIQ(MXATM,3),NATREL,UATOM(MXATM)
      COMMON /EFPAR / LOCNFG,NLOW,NUP
      COMMON /EFPAR2/ NFRGAL(MXPRO),NLOWAL(MXPRO),NUPAL(MXPRO),
     *                NPPTAL(MXPRO)
      COMMON /ELPROP/ ELDLOC,ELMLOC,ELPLOC,ELFLOC,
     *                IEDEN,IEMOM,IEPOT,IEFLD,MODENS,
     *                IEDOUT,IEMOUT,IEPOUT,IEFOUT,
     *                IEDINT,IEMINT,IEPINT,IEFINT
      COMMON /FMCOM / XX(1)
      COMMON /FMOINF/ NFG,NLAYER,NATFMO,NBDFG,NAOTYP,NBODY
      COMMON /FRGINF/ NMPTS(MXFRG),NMTTPT,IEFC,IEFD,IEFQ,IEFO,
     *                NPPTS(MXFRG),NPTTPT,IEFP,
     *                NRPTS(MXFRG),NRTTPT,IREP,ICHGP,NFRG,
     *                NDPPTS(MXDPPT),NDPTTPT,IEFDP
      COMMON /GDDI/   ISCOPE,NGROUPS,MYGROUP,MEGLOB,NPGLOB,NNGLOB,JBTYP,
     *                ISGDDI,PAROUT
      COMMON /GEOMOP/ GEOM
      COMMON /HSSCTL/ IHESSM,IHREP,HSSEND
      COMMON /IJPAIR/ IA(MXAO)
      COMMON /INFO  / CDUM(MXATM,3),IZAN(MXATM),NATOMS,IUNTRD,ATM(MXATM)
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /INTFIL/ NINTMX,NHEX,NTUPL,PACK2E,INTTYP,IGRDTYP
      COMMON /INTOPT/ ISCHWZ,IECP,NECP,IEXTFLD
      COMMON /INTRFC/ FRIEND,AIMPAC,RPAC,PLTORB,MOLPLT
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /ISEPS / ISEPS,USEPS
      COMMON /MACHIN/ NWDVAR,MAXFM,MAXSM,LIMFM,LIMSM
      COMMON /MACHSW/ KDIAG,ICORFL,IXDR
      COMMON /MASSES/ ZMASS(MXATM)
      COMMON /MCINP / METHMC,CISTEP,ACURCY,ENGTOL,DAMP,MICIT,NWORD,NORB,
     *                NOROT(2,MXNORO),MOFRZ(15),NPFLG(10),
     *                NOFO,MCFMO,CANONC,FCORE,FORS,NOCI,EKT,LINSER
      COMMON /MDSIM / DT,BOXL,BOXLI,BATHT,EKINT,EKINR,MDTYP
      COMMON /MEXOPT/ MEXSKPGES,MEXSTATE
      COMMON /MP2PAR/ OSPT,TOLMP,METHMP,NWDMP2,MPPROP,NACRMP,NBCRMP,
     *                NOAMP,NOBMP,NORBMP,NBFMP,NOMTMP,MOCPHF,MAXITC
      COMMON /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /PCMPAR/ IPCM,NFT26,NFT27,IRPPCM,IEFPCM,IP_F,NFMOPCM
      COMMON /PRPOPT/ ILOCAL
      COMMON /RELWFN/ RMETHOD,QRQMT,CLIG,CLIG2,QRTOL,IQRORD,MODQR,NESOC,
     *                NRATOM,NUMU,NQMTR,NQRDAF,MORDA,NDARELB
      COMMON /RESTAR/ TIMLIM,IREST,NREC,INTLOC,IST,JST,KST,LST
      COMMON /RUNLAB/ TITLE(10),A(MXATM),B(MXATM),BFLAB(MXAO)
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      COMMON /SCFOPT/ CONVHF,MAXIT,MCONV,NPUNCH,NPREO(4)
      COMMON /SIMDAT/ NACC,NREJ,IGOMIN,NRPA,IBWM,NACCT,NREJT,NRPAT,
     *                NPRTGO,IDPUNC,IGOFLG
      COMMON /SOOPT / NOSO
      COMMON /SVPOPT/ ISVP,NSVP
      COMMON /SYMMOL/ GROUP,COMPLEX,IGROUP,NAXIS,ILABMO,ABEL
      COMMON /SYMTRY/ MAPSHL(MXSH,48),MAPCTR(MXATM,48),
     *                T(432),INVT(48),NT
      COMMON /TINOPT/ MMONLY, QMMM
      COMMON /WFNOPT/ SCFTYP,CITYP,DFTYPE,CCTYP,MPLEVL,MPCTYP
      COMMON /VBINTF/ VBTYP,VBENGY
      COMMON /ZMAT  / NZMAT,NZVAR,NVAR,NSYMC,LINEAR
      COMMON /ZMTALT/ NZMAT2,NZVAR2,NVAR2,NZMTRD,ICOORD
      COMMON /ZRFPAR/ GZRF,FIND(3),GNUCF,EBORN,DIELEC,IZRF,ICALC
C
C      ----- SET UP NAMELIST $CONTRL TABLES -----
C
      PARAMETER (NNAM=36)
      DIMENSION QNAM(NNAM),KQNAM(NNAM)
      DATA CONTRL /8HCONTRL  /
      DATA QNAM/8HSCFTYP  ,8HRUNTYP  ,8HEXETYP  ,8HICHARG  ,
     *          8HMULT    ,8HUNITS   ,8HINTTYP  ,8HLOCAL   ,
     *          8HMAXIT   ,8HNPRINT  ,8HIREST   ,8HNORMF   ,
     *          8HNORMP   ,8HITOL    ,8HICUT    ,8HNZVAR   ,
     *          8HNOSYM   ,8HGEOM    ,8HMPLEVL  ,8HAIMPAC  ,
     *          8HPP      ,8HECP     ,8HPLTORB  ,8HMOLPLT  ,
     *          8HCOORD   ,8HFRIEND  ,8HNOSO    ,8HCITYP   ,
     *          8HCCTYP   ,8HISPHER  ,8HQMTTOL  ,8HRELWFN  ,
     *          8HNUMGRD  ,8HGRDTST  ,8HGRDTYP  ,8HVBTYP   /
      DATA KQNAM /5,5,5,1,  1,5,5,5,  1,1,1,1,  1,1,1,1,
     *            1,5,1,0,  5,5,0,0,  5,5,1,5,  5,1,3,5,
     *            0,0,5,5/
C
      DATA C1/8HC1      /
      DATA BLANK/8H        /, RUN/8HRUN      /
C
      DATA NONE,RNONE/4HNONE,8HNONE    /
      DATA RHF,UHF,ROHF,GVB/8HRHF     ,8HUHF     ,8HROHF    ,8HGVB     /
      DATA RMC,ZAPT/8HMCSCF   ,8HZAPT    /
      DATA GUGA,ALDET,CIS,GENCI,FSOCI,ORMAS
     *          /8HGUGA    ,8HALDET   ,8HCIS     ,8HGENCI   ,8HFSOCI   ,
     *           8HORMAS   /
      DATA DETWRD,GENWRD,DRTWRD/8HDET     ,8HGENCI   ,8HDRT     /
      DATA LCCD,CCD,CCSD,CCSDT,CCSDTQ,RCC,CRCC,CRCCQ,EOMSD,EOMSDT,CRCCL
     *     /8HLCCD    ,8HCCD     ,8HCCSD    ,8HCCSD(T) ,8HCCSD(TQ),
     *      8HR-CC    ,8HCR-CC   ,8HCR-CC(Q),8HEOM-CCSD,8HCR-EOM  ,
     *      8HCR-CCL  /
      DATA VB2000/8HVB2000  /
C
      DATA ENERGY,GRAD,HSSIAN/8HENERGY  ,8HGRADIENT,8HHESSIAN /
      DATA PROP,OPTIM,SADPT  /8HPROP    ,8HOPTIMIZE,8HSADPOINT/
      DATA AIRC,DRC,TRUDGE   /8HIRC     ,8HDRC     ,8HTRUDGE  /
      DATA SURF,GRDXTR,VSCF  /8HSURFACE ,8HGRADEXTR,8HVSCF    /
      DATA TRAN,MOROKM,MAKEFP/8HTRANSITN,8HMOROKUMA,8HMAKEFP  /
      DATA FFIELD,TDHF,RAMAN /8HFFIELD  ,8HTDHF    ,8HRAMAN   /
      DATA GLOBOP,MD,PIMC    /8HGLOBOP  ,8HMD      ,8HPIMC    /
      DATA NMR,XTDHF,AMEX    /8HNMR     ,8HTDHFX   ,8HMEX     /
      DATA FMO0,OPTFMO/8HFMO0    ,8HOPTFMO  /
C
      DATA HMMP,HMMPNF/8HMCP     ,8HMCPINFO /
      DATA HONDO,POPLE/8HHONDO   ,8HPOPLE   /
      DATA BEST,ROTAX,RYS,ERIC
     *      /8HBEST    ,8HROTAXIS ,8HRYSQUAD ,8HERIC    /
      DATA SCHLEGEL/8HSCHLEGEL/
      DATA BOYS,RUED,POPL /8HBOYS    ,8HRUEDNBRG,8HPOP     /
      DATA ANGST,ANGS,BOHR/8HANGSTROM,8HANGS    ,8HBOHR    /
      DATA RDECP,SBKECP,SB2ECP,HWECP
     *      /8HREAD    ,8HSBKJC   ,8HSBK     ,8HHW      /
      DATA RESC,ANESC,DK/8HRESC    ,8HNESC    ,8HDK      /
C
      DATA ZMT,HINT,ZMTMPC/8HZMT     ,8HHINT    ,8HZMTMPC  /
      DATA FRAGONLY/8HFRAGONLY/
      DATA     CART,UNIQUE/8HCART    ,8HUNIQUE  /
      DATA          TINKER/8HTINKER  /
      DATA      RINPUT,DAF/8HINPUT   ,8HDAF     /
      DATA CHECK/8HCHECK   /
C
C     ----- BEGINNING OF RUN -----
C     1. READ IN BASIS SET + OPTIONS
C     2. GENERATE INITIAL MO'S
C
C     IREST = 0     NORMAL START + NORMAL RUNNING CONDITION.
C     IREST = 1     2E-INTEGRAL RESTART ( 1E +MO'S SAVED)
C     IREST = 2     SCF RESTART ( 1E + MO'S SAVED; 2E SAVED)
C     IREST = 3     1E-GRADIENT RESTART ( MO'S SAVED; NO GRADIENT SAVED)
C     IREST = 4     2E-GRAD RESTART ( MO'S, 1-E GRAD, ORDERED DM2 SAVED)
C
      NEVALS = 0
      IGOFLG = 2
      MDTYP  = RNONE
C
C     ----- INITIALIZE VARIABLES FOR NAMELIST $CONTRL -----
C
      SCFTYP = BLANK
      RUNTYP = BLANK
      EXETYP = RUN
      ICHARG = 0
      MULT   = 1
      UNITS  = BLANK
      TYPINT = BEST
      GRDTYP = SCHLEGEL
      TLOCAL = BLANK
      MAXIT  = 30
      NPRINT = 7
      IREST = 0
      NORMF = 0
      NORMP = 0
      ITOL  = 20
      ICUT  = 9
      NZVAR = 0
      NOSYM = 0
      GEOM  = BLANK
      MPLEVL= 0
      PP    = BLANK
      ECP   = BLANK
      AIMPAC=.FALSE.
      PLTORB=.FALSE.
      MOLPLT=.FALSE.
      COORD = BLANK
      FRIEND= BLANK
      ISPHER= -1
      QMTTOL= 1.0D-06
      RMETHOD= RNONE
      RPAC  =.FALSE.  !   DEFUNCT OPTION
      NUMGRD=.FALSE.
      GRDTST=.FALSE.
C
C     FMO HAS ITS OWN COORDINATE AND BASIS SET INPUT TO BE READ LATER.
C     NOW WE ONLY CHECK IF FMO IS ACTIVE AND SET NFG TEMPORARILY TO 1/0.
C
      CALL SEQREW(IR)
      CALL FNDGRP(IR,' $FMO   ',IEOF)
      NFG=0
      IF(IEOF.EQ.0) NFG=1
      IF(NFG.NE.0) THEN
        ITOL=24
        ICUT=12
      END IF
C
C        THE NEXT IS AN UNDOCUMENTED OPTION TO TURN OFF USE
C        OF SYMMETRY ORBITAL CODE.  IN SOME CASES INVOLVING
C        GROUPS WITH COMPLEX CHARACTERS, THE SYMMETRY ORBITAL
C        CODE DOES NOT GENERATE LINEARLY INDEPENDENT SO-S.
C
      NOSO=0
C
C     INITIALIZE SOME WAVEFUNCTION INFORMATION
C
      CITYP  = BLANK
      CCTYP  = RNONE
      MPCTYP = NONE
      VBTYP  = RNONE
C
C        ----- READ NAMELIST $CONTRL -----
C
      JRET = 0
      CALL NAMEIO(IR,JRET,CONTRL,NNAM,QNAM,KQNAM,
     *            SCFTYP,RUNTYP,EXETYP,ICHARG,MULT,UNITS,TYPINT,TLOCAL,
     *            MAXIT,NPRINT,IREST,NORMF,NORMP,ITOL,ICUT,NZVAR,
     *            NOSYM,GEOM,MPLEVL,AIMPAC,PP,ECP,PLTORB,MOLPLT,
     *            COORD,FRIEND,NOSO,CITYP,CCTYP,ISPHER,QMTTOL,RMETHOD,
     *            NUMGRD,GRDTST,GRDTYP,VBTYP,
     *       0,0,0,    0,0,0,0,0,
     *   0,0,0,0,0,    0,0,0,0,0,   0,0,0,0,0,   0,0,0,0,0)
      IF(JRET .EQ. 2) THEN
         IF (MASWRK) WRITE (IW,9005)
         CALL ABRT
      END IF
      NERR = 0
C
C     TURN OFF USE OF SYMMETRY ORBITAL CODE FOR MOROKUMA ANALYSIS
C
      IF(RUNTYP.EQ.MOROKM) NOSO=1
C
      ICH = ICHARG
      MUL = MULT
      NSPHER = ISPHER
      QMATOL = QMTTOL
      IF(NORMF.NE.1) NORMF = 0
      IF(NORMP.NE.1) NORMP = 0
C
C         CHECK SPELLING ON VARIOUS OPTIONS
C
      OK = .FALSE.
      IF(SCFTYP.EQ.BLANK) SCFTYP = RHF
      IF(SCFTYP.EQ.RHF)   OK=.TRUE.
      IF(SCFTYP.EQ.UHF)   OK=.TRUE.
      IF(SCFTYP.EQ.ROHF)  OK=.TRUE.
      IF(SCFTYP.EQ.GVB)   OK=.TRUE.
      IF(SCFTYP.EQ.RMC)   OK=.TRUE.
      IF(SCFTYP.EQ.RNONE) OK=.TRUE.
      IF(.NOT.OK) THEN
         IF (MASWRK) WRITE(IW,9010) 'SCFTYP',SCFTYP
         NERR = NERR+1
      END IF
C
      OK = .FALSE.
      IF(RUNTYP.EQ.BLANK) RUNTYP = ENERGY
      IF(RUNTYP.EQ.ENERGY) OK=.TRUE.
      IF(RUNTYP.EQ.GRAD)   OK=.TRUE.
      IF(RUNTYP.EQ.HSSIAN) OK=.TRUE.
      IF(RUNTYP.EQ.PROP)   OK=.TRUE.
      IF(RUNTYP.EQ.OPTIM)  OK=.TRUE.
      IF(RUNTYP.EQ.SADPT)  OK=.TRUE.
      IF(RUNTYP.EQ.AMEX)   OK=.TRUE.
      IF(RUNTYP.EQ.GLOBOP) OK=.TRUE.
      IF(RUNTYP.EQ.PIMC)   OK=.TRUE.
      IF(RUNTYP.EQ.AIRC)   OK=.TRUE.
      IF(RUNTYP.EQ.DRC)    OK=.TRUE.
      IF(RUNTYP.EQ.TRUDGE) OK=.TRUE.
      IF(RUNTYP.EQ.SURF)   OK=.TRUE.
      IF(RUNTYP.EQ.GRDXTR) OK=.TRUE.
      IF(RUNTYP.EQ.VSCF)   OK=.TRUE.
      IF(RUNTYP.EQ.TRAN)   OK=.TRUE.
      IF(RUNTYP.EQ.MOROKM) OK=.TRUE.
      IF(RUNTYP.EQ.MAKEFP) OK=.TRUE.
      IF(RUNTYP.EQ.FFIELD) OK=.TRUE.
      IF(RUNTYP.EQ.TDHF)   OK=.TRUE.
      IF(RUNTYP.EQ.XTDHF)  OK=.TRUE.
      IF(RUNTYP.EQ.RAMAN)  OK=.TRUE.
      IF(RUNTYP.EQ.NMR)    OK=.TRUE.
      IF(RUNTYP.EQ.MD)     OK=.TRUE.
      IF(RUNTYP.EQ.OPTFMO) OK=.TRUE.
      IF(RUNTYP.EQ.FMO0)   OK=.TRUE.
      IF(.NOT.OK) THEN
         IF (MASWRK) WRITE(IW,9010) 'RUNTYP',RUNTYP
         NERR = NERR+1
      END IF
C
C          CHECK SPELLINGS, BUT ALSO SET THE OPTION FLAGS
C
C        PRE-2004 INPUT FILES ASKING FOR POPLE/HONDO INTEGRAL
C        PACKAGES ARE JUST PEOPLE WHO DON'T KNOW ANY BETTER.
C        WHY NOT GIVE THEM THE VERY BEST?
C
      INTTYP = 8
      IF(TYPINT.EQ.POPLE) TYPINT=BEST
      IF(TYPINT.EQ.HONDO) TYPINT=BEST
      IF(TYPINT.EQ.BEST)  INTTYP = 0
      IF(TYPINT.EQ.ROTAX) INTTYP = 1
      IF(TYPINT.EQ.ERIC)  INTTYP = 2
      IF(TYPINT.EQ.RYS)   INTTYP = 3
      IF(INTTYP.EQ.8) THEN
         IF (MASWRK) WRITE(IW,9010) 'INTTYP',TYPINT
         NERR = NERR+1
      END IF
C
C        BEST GRADIENT TYPE MEANS FASTEST, ALMOST AS ACCURATE, NAMELY
C        USE BERNY SCHLEGEL'S S,P,L SPECIAL ROTATED AXIS GRADIENT CODES,
C        BUT USE RYS QUADRATURE FOR EVERYTHING ELSE.
C        TRADITIONAL NAMES OF POPLE/HONDO ARE MAPPED TO BEST/RYSQUAD.
C        NEW NAME SCHLEGEL (FAR MORE CORRECT THAN POPLE!) MEANS BEST.
C
      IGRDTYP = 8
      IF(GRDTYP.EQ.POPLE)    GRDTYP = BEST
      IF(GRDTYP.EQ.SCHLEGEL) GRDTYP = BEST
      IF(GRDTYP.EQ.HONDO)    GRDTYP = RYS
      IF(GRDTYP.EQ.BEST) IGRDTYP = 0
      IF(GRDTYP.EQ.RYS)  IGRDTYP = 2
      IF(IGRDTYP.EQ.8) THEN
         IF (MASWRK) WRITE(IW,9010) 'GRDTYP',GRDTYP
         NERR = NERR+1
      END IF
C                         (NO LOCALIZATION ON IRC RUNS)
      ILOCAL = 8
      IF(TLOCAL.EQ.BLANK) TLOCAL = RNONE
      IF(TLOCAL.EQ.RNONE) ILOCAL = 0
      IF(TLOCAL.EQ.BOYS)  ILOCAL = 1
      IF(TLOCAL.EQ.RUED)  ILOCAL = 2
      IF(TLOCAL.EQ.POPL)  ILOCAL = 3
      IF(RUNTYP.EQ.AIRC)  ILOCAL = 0
C MAKEFP RUN DEFAULTS TO RUEDENBERG LMOS
      IF(RUNTYP.EQ.MAKEFP .AND. TLOCAL.EQ.RNONE) ILOCAL=2
      IF(ILOCAL.EQ.8) THEN
         IF (MASWRK) WRITE(IW,9010) 'LOCAL ',TLOCAL
         NERR = NERR+1
      END IF
C
      IUNTRD = 8
      IF(UNITS.EQ.BLANK) UNITS=ANGS
      IF(UNITS.EQ.ANGS  .OR.  UNITS.EQ.ANGST) IUNTRD = 1
      IF(UNITS.EQ.BOHR)  IUNTRD = -1
      IF(IUNTRD.EQ.8) THEN
         IF (MASWRK) WRITE(IW,9010) 'UNITS ',UNITS
         NERR = NERR+1
      END IF
C
      IF(IREST.EQ.0) GEOM=RINPUT
      IF(IREST.GT.0) GEOM=DAF
      IF(GEOM.EQ.BLANK) GEOM = DAF
C
C        FOR PEDAGOGIC REASONS, KEYWORD PP= IS INPUT FOR ECP OR MCP
C        FOR HISTORICAL REASONS, NAMELY THAT ECP CAME FIRST, THE
C        VARIABLES USED STORE MCP TYPES INTO ECP-SOUNDING NAMES,
C        AND BOTH PP= AND ECP= ARE ACCEPTABLE INPUT KEYWORDS.
C
      IECP=8
      IF(PP.NE.BLANK)   ECP = PP
      IF(ECP.EQ.BLANK)  ECP = RNONE
      IF(ECP.EQ.SB2ECP) ECP = SBKECP
      IF(ECP.EQ.RNONE)  IECP=0
      IF(ECP.EQ.RDECP)  IECP=1
      IF(ECP.EQ.SBKECP) IECP=2
      IF(ECP.EQ.HWECP)  IECP=3
      IF(ECP.EQ.HMMP)   IECP=5
      IF(ECP.EQ.HMMPNF) IECP=6
      IF(IECP.EQ.8) THEN
         IF (MASWRK) WRITE(IW,9010) 'PP/ECP',ECP
         NERR = NERR+1
      END IF
C
      OK = .FALSE.
      IF(RMETHOD.EQ.RNONE) OK=.TRUE.
      IF(RMETHOD.EQ.RESC)  OK=.TRUE.
      IF(RMETHOD.EQ.ANESC) OK=.TRUE.
      IF(RMETHOD.EQ.DK)    OK=.TRUE.
      IF(.NOT.OK) THEN
         IF(MASWRK) WRITE(IW,9010) 'RELWFN',RMETHOD
         NERR = NERR+1
      END IF
C
      ICOORD = 8
      IF(COORD.EQ.BLANK)    COORD=UNIQUE
      IF(COORD.EQ.UNIQUE)   ICOORD = -1
      IF(COORD.EQ.HINT)     ICOORD =  0
      IF(COORD.EQ.CART)     ICOORD =  1
      IF(COORD.EQ.ZMT)      ICOORD =  2
      IF(COORD.EQ.ZMTMPC)   ICOORD =  3
      IF(COORD.EQ.FRAGONLY) ICOORD =  4
      IF(COORD.EQ.TINKER)   ICOORD =  5
      IF(ICOORD.EQ.8) THEN
         IF (MASWRK) WRITE(IW,9010) 'COORD ',COORD
         NERR = NERR + 1
      END IF
C
C     CHECK THE VBTYP SPELLING
C
      OK = .FALSE.
      IF(VBTYP.EQ.RNONE)  OK=.TRUE.
      IF(VBTYP.EQ.VB2000) OK=.TRUE.
      IF(.NOT.OK) THEN
         IF (MASWRK) WRITE(IW,9010) 'VBTYP',VBTYP
         NERR = NERR+1
      END IF
      IF(VBTYP.NE.RNONE) THEN
         OK = .FALSE.
         IF(SCFTYP.EQ.RHF)  OK = .TRUE.
         IF(SCFTYP.EQ.UHF)  OK = .TRUE.
         IF(SCFTYP.EQ.ROHF) OK = .TRUE.
         IF(.NOT.OK) THEN
            IF(MASWRK) WRITE(IW,9031)
            NERR=NERR+1
         END IF
         IF(NPROC.GT.1) THEN
            IF(MASWRK) WRITE(IW,9032)
            NERR=NERR+1
         END IF
      END IF
C
C     CHECK THE CITYP SPELLING
C
      OK = .FALSE.
      IF(CITYP.EQ.BLANK) CITYP = RNONE
      IF(CITYP.EQ.RNONE) OK=.TRUE.
      IF(CITYP.EQ.GUGA)  OK=.TRUE.
      IF(CITYP.EQ.CIS)   OK=.TRUE.
      IF(CITYP.EQ.ALDET) OK=.TRUE.
      IF(CITYP.EQ.GENCI) OK=.TRUE.
      IF(CITYP.EQ.FSOCI) OK=.TRUE.
      IF(CITYP.EQ.ORMAS) OK=.TRUE.
      IF(.NOT.OK) THEN
         IF (MASWRK) WRITE(IW,9010) 'CITYP',CITYP
         NERR = NERR+1
      END IF
C
C     CHECK THE COUPLED CLUSTERS JOB
C
      IF (MASWRK) WRITE(IW,9540)
      OK = .FALSE.
      IF(CCTYP.EQ.RNONE)  OK=.TRUE.
      IF(CCTYP.EQ.LCCD)   OK=.TRUE.
      IF(CCTYP.EQ.CCD)    OK=.TRUE.
      IF(CCTYP.EQ.CCSD)   OK=.TRUE.
      IF(CCTYP.EQ.CCSDT)  OK=.TRUE.
      IF(CCTYP.EQ.CCSDTQ) OK=.TRUE.
      IF(CCTYP.EQ.RCC)    OK=.TRUE.
      IF(CCTYP.EQ.CRCC)   OK=.TRUE.
      IF(CCTYP.EQ.CRCCQ)  OK=.TRUE.
      IF(CCTYP.EQ.EOMSD)  OK=.TRUE.
      IF(CCTYP.EQ.EOMSDT) OK=.TRUE.
      IF(CCTYP.EQ.CRCCL)  OK=.TRUE.
      IF(.NOT.OK) THEN
         IF(MASWRK) WRITE(IW,9010) 'CCTYP',CCTYP
         NERR=NERR+1
      END IF
      IF(CCTYP.NE.RNONE) THEN
         IF(SCFTYP.NE.RHF) THEN
            IF(MASWRK) WRITE(IW,9033)
            NERR=NERR+1
         END IF
         IF(NPROC.GT.1) THEN
            IF(MASWRK) WRITE(IW,9034)
            NERR=NERR+1
         END IF
      END IF
C
C     ----- CHECK FOR COMPATIBILITY OF SCFTYP=NONE -----
C
      IF(SCFTYP.EQ.RNONE) THEN
C              ANY TYPE CI FROM GUESS=MOREAD SHOULD BE LEGAL
         IF(RUNTYP.EQ.ENERGY  .AND.  CITYP.NE.RNONE) THEN
            CONTINUE
C              TRANSITION MOMENTS (SPIN-ORBIT) ALLOW GUGA OR MCQDPT
         ELSE IF ((RUNTYP.EQ.TRAN.OR.RUNTYP.EQ.SURF)  .AND.
     *            (CITYP.EQ.GUGA.OR.MPLEVL.EQ.2)   ) THEN
            CONTINUE
         ELSE
            IF(MASWRK) WRITE(IW,9050) SCFTYP,CITYP,RUNTYP,MPLEVL
            NERR = NERR+1
         END IF
      END IF
C
      IF(CITYP.NE.RNONE  .AND.  SCFTYP.EQ.UHF) THEN
         IF (MASWRK) WRITE(IW,9070)
         NERR=NERR+1
      END IF
C
      IF(MPLEVL.NE.2  .AND.  MPLEVL.NE.0) THEN
         IF(MASWRK) WRITE(IW,9080)
         NERR=NERR+1
      END IF
C
C         WELL, ANYTHING OVER 75 IS PROBABLY INSANE, BUT AT LEAST
C         WE MUST FILTER OUT THE LUNATIC FRINGE WHO WANT MAXIT=1000.
C
      IF(MAXIT.LE.0  .OR.  MAXIT.GT.200) THEN
         IF(MASWRK) WRITE(IW,9090) MAXIT
         NERR = NERR+1
      END IF
C
C     ----- ONE OR MORE ERRORS DETECTED, BLOW THE JOB AWAY -----
C
      IF(NERR.GT.0) THEN
         IF (MASWRK) WRITE(IW,9200)
         CALL ABRT
      END IF
C
C     THIS IS THE END OF THE CHECKING WITHIN $CONTRL ITSELF
C     NOW WE MUST READ OTHER INPUT GROUPS, AND CHECK AS MUCH AS WE CAN.
C
C     ---- QMMM OPTIONS ----
C
      CALL LINKIN(0)
      IF (QMMM .AND. (RUNTYP .EQ. OPTIM) ) THEN
        IF (.NOT. ((ICOORD .EQ. 5) .OR. (ICOORD .EQ. -1))) THEN
          IF (MASWRK) WRITE(IW,9210) COORD
          IF(NFG.EQ.0) CALL ABRT
        END IF
      END IF
C
C    ----- READ IN TINKER MM INPUT -----
C
      IF(QMMM .OR. MMONLY) THEN
        IF (NZVAR.EQ.0) THEN
          IF (MASWRK) WRITE(IW,9220)
          IF(NFG.EQ.0) CALL ABRT
        END IF
        IF(NFG.EQ.0) THEN
           CALL TINKIN(IR,IW)
           CALL LINKIN(1)
           CALL TOPTIN
        END IF
      END IF
C
C     GDDI WITH FEWER GROUPS THAN CPUS HAVE TO ADJUST MEMORY IN SYSINP.
C     FOR NOW ASSUME THAT GDDI STARTS OFF WITH THE SAME NUMBER OF GROUPS
C     AND CPUS WHICH SEEMS TO WORK AS IT CAN ALWAYS BE ADJUSTED LATER
C     AS NEEDED.
C
      CALL GDDINP
C
C     ----- READ $SYSTEM IF ANY -----
C
      CALL SYSINP(MEMORY,MEMDDI)
      MWDDI = MEMDDI
C
C     ----- OPEN THE DISTRIBUTED DYNAMIC MEMORY POOL -----
C     THIS MUST OCCUR BEFORE THE REPLICATED POOL
C     CHECK RUNS SHOULD NOT FORMALLY ALLOCATE MEMORY.
C     NOTE THAT IF THE MEMORY REQUEST IS 0, A VERY SMALL AMOUNT OF
C     DISTRIBUTED MEMORY WILL BE ALLOCATED (BUT MORE THAN NOTHING).
C
C     FOR GDDI DISTRIBUTED MEMORY (MEMDDI) IS ALLOCATED IN THE WORLD
C     SCOPE.  THAT NUMBER SHOULD BE SPECIFIED FOR ALL CPUS. GROUPS
C     WILL HAVE DIFFERENT AMOUNTS OF MEMORY IF THEY HAVE DIFFERENT
C     NUMBERS OF PROCESSORS.
C
      MEMDDIX = MEMDDI
      IF(EXETYP.EQ.CHECK) MEMDDIX = 0
      IF(ISGDDI) CALL GDDI_SCOPE(DDI_WORLD)
      CALL DDI_MEMORY(MEMORY,MEMDDIX,EXETYP)
      NPROCTOT = NPROC
      IF(ISGDDI) CALL GDDI_SCOPE(DDI_GROUP)
C
C     ----- OPEN THE DYNAMIC MEMORY POOL -----
C
      CALL SETFM(MEMORY)
C
C     ----- OPEN THE DIRECT ACCESS FILE -----
C
      IREDO = IABS(IREST)
      CALL OPENDA(IREDO)
C
C     ----- MAKE PREPARATIONS FOR NON-BLANK FRIEND
C     ----- POSTPONING THEM UNTIL THE FINAL PRINTOUT IS TOO LATE
C
      IF(FRIEND.NE.BLANK) THEN
        WRITE (IW,9500) FRIEND,CHECK
        EXETYP=CHECK
        CALL SEQOPN(NFT16,'WORK16','UNKNOWN',.FALSE.,'FORMATTED')
      END IF
C
C     ----- READ $BASIS IF ANY ----
C
      CALL BASISS
C
C     ----- READ $DFT IF ANY -----
C
      CALL DFTINP(RNONE)
C
C     ----- READ PATH INTEGRAL MONTE CARLO $PIMC IF ANY ---
C
      CALL PIMCINP
C
C     ----- READ NUCLEAR ELECTRONIC ORBITAL $NEO IF ANY ---
C           (PARAMETERS MUST BE READ BEFORE CALL ATOMS)
C
      NEOOPT=1
      CALL NEOINP(NEOOPT)
C
C     ----- READ MOLECULE AND BASIS SET - $DATA GROUP -----
C
      IF (ICOORD .EQ. 4) THEN
         NAT = 0
         NUM = 0
         NQMT= 0
         NE  = 0
         NA  = 0
         NB  = 0
         TITLE(1)=FRAGONLY
         DO I=2,10
            TITLE(I)=BLANK
         ENDDO
      ELSE
         IF(RMETHOD.EQ.ANESC) THEN
C
C           THE ORDER OF CALLS TO RELSAVE IS IMPORTANT. SEE RELSAVE
C
C           SMALL AND LARGE BASIS SETS SHOULD NOT BE NORMALISED!
C           READ THE SMALL COMPONENT BASIS SET
            CALL MOLE(' $DATAS ',IUNTRD,ICOORD,.FALSE.)
            CALL RELSAVE(4)
C           READ THE LARGE COMPONENT BASIS SET
            CALL MOLE(' $DATAL ',IUNTRD,ICOORD,.FALSE.)
            CALL RELSAVE(0)
         END IF
C
C        READ THE MOLECULE AND ITS NORMAL BASIS SET, OR POSSIBLY,
C        READ THE FOLDY-WOUTHUYSEN TRANSFORMED BASIS FOR 2E INTEGRALS
C        THIS BASIS SET IS "NORMAL" AND IS TO BE NORMALISED
C
         CALL MOLE(' $DATA  ',IUNTRD,ICOORD,.TRUE.)
C
         IF(RMETHOD.EQ.ANESC) CALL RELSAVE(3)
C        NOTA BENE: THE LAST DATA GROUP DEFINES GEOMETRY ETC
         IF(RMETHOD.NE.RNONE.AND.MOD(MODQR,2).EQ.1) THEN
            MAXGTOT = MXGTOT
            MAXSH   = MXSH
            CALL VALFM(LOADFM)
            LEXU     = LOADFM   + 1
            LCSU     = LEXU     + MAXGTOT
            LCPU     = LCSU     + MAXGTOT
            LCDU     = LCPU     + MAXGTOT
            LCFU     = LCDU     + MAXGTOT
            LCGU     = LCFU     + MAXGTOT
            LKSTARTU = LCGU     + MAXGTOT
            LKATOMU  = LKSTARTU + MAXSH/NWDVAR + 1
            LKTYPEU  = LKATOMU  + MAXSH/NWDVAR + 1
            LKNGU    = LKTYPEU  + MAXSH/NWDVAR + 1
            LKLOCU   = LKNGU    + MAXSH/NWDVAR + 1
            LKMINU   = LKLOCU   + MAXSH/NWDVAR + 1
            LKMAXU   = LKMINU   + MAXSH/NWDVAR + 1
            LMAPLE   = LKMAXU   + MAXSH/NWDVAR + 1
            LLARCH   = LMAPLE   + MAXGTOT/NWDVAR + 1
            LELM     = LLARCH   + MAXGTOT/NWDVAR + 1
            LAST     = LELM     + MAXGTOT/NWDVAR + 1
            NEED = LAST - LOADFM - 1
            CALL GETFM(NEED)
            CALL BUNCON(MAXGTOT,MAXSH,XX(LEXU),XX(LCSU),XX(LCPU),
     *                  XX(LCDU),XX(LCFU),XX(LCGU),XX(LKSTARTU),
     *                  XX(LKATOMU),XX(LKTYPEU),XX(LKNGU),XX(LKLOCU),
     *                  XX(LKMINU),XX(LKMAXU),XX(LMAPLE),XX(LLARCH),
     *                  XX(LELM))
            CALL RETFM(NEED)
         END IF
      END IF
C
C     ----- SAVE TRUE NUCLEAR CHARGES ------
C     ECP, MCP, AND FMO MAY MANIPULATE THE -ZAN- ARRAY LATER
C
      DO IAT=1,NAT
         IAN(IAT) = INT(ZAN(IAT)+0.001D+00)
      ENDDO
C
C     ----- FILL ATOMIC MASS TABLE (REQUIRES MOLECULE READ IN) -----
C
      CALL RAMS(ZMASS,0)
C
C     ----- CHECK FOR LINEAR MOLECULE (REQUIRES -ZMASS- SET) -----
C
      CALL VCLR(VMOI,1,3)
      IF(NAT.GT.0) CALL INRTIA(C,COM,ZMASS,VMOI,NAT)
      LINEAR=.FALSE.
      IF(VMOI(1).LT.1.0D-04) LINEAR=.TRUE.
      IF ((ICOORD .EQ. 4) .OR.
     *   (NAT .EQ. 1 .AND. NFRG .GT. 0)) LINEAR = .FALSE.
      IF(LINEAR.AND.MASWRK.AND.NFG.EQ.0) WRITE(IW,9510)
C
C     --- ONCE AGAIN READ NUCLEAR ELECTRONIC ORBITAL $NEO IF ANY ---
C         (THIS TIME PROCEED WITH NEO SET UP)
C
      NEOOPT=0
      CALL NEOINP(NEOOPT)
C
C     ----- CHECK FOR $EFIELD GROUP -----
C
      CALL INPEF(NOSYM,NZVAR,RUNTYP)
C
C     TRUDGE RUNS WITH ANY USE OF SYMMETRY IN HINT INTERNALS
C     ARE NOT ALLOWED TO ASK TO HAVE SYMMETRY FORCED OFF.
C
      IF(RUNTYP.EQ.TRUDGE  .AND.  ICOORD.EQ.0
     *   .AND.  IGROUP.GT.1   .AND.  NOSYM.NE.0) THEN
         IF(MASWRK) WRITE(IW,9515)
         CALL ABRT
      END IF
C
C     ----- FORCE NO SYMMETRY IF REQUESTED -----
C
      IF(NOSYM.EQ.1 .OR. ICOORD.EQ.4) THEN
         GROUP=C1
         IGROUP=1
         NAXIS=1
         NT=1
      END IF
C
C        PRINT $CONTRL AND $SYSTEM INPUT
C
      IF (MASWRK) THEN
         WRITE (IW,9520) SCFTYP, RUNTYP, EXETYP,
     *                   MPLEVL, CITYP,  CCTYP,  VBTYP,
     *                   MULT,   ICHARG, NZVAR,  COORD,
     *                   ECP,    RMETHOD, TLOCAL, NUMGRD,
     *                   ISPHER, NOSYM,  MAXIT,  UNITS,
     *                   PLTORB, MOLPLT, AIMPAC, FRIEND,
     *                   NPRINT, IREST,  GEOM,
     *                   NORMF,  NORMP,  ITOL,   ICUT,
     *                   TYPINT, GRDTYP, QMTTOL
         IF(NOSO.EQ.1) WRITE(IW,*) 'UNDOCUMENTED OPTION -NOSO- SELECTED'
         COREFL= ICORFL.EQ.1
         XNP = NPROCTOT
         XMW = MEMDDI
         MLOCX = INT((1.0D+06*XMW)/XNP)
         BALTYP='LOOP  '
         IF(IBTYP.EQ.1) BALTYP='NXTVAL'
         WRITE (IW,9530) MEMORY,MWDDI,NPROC,MLOCX,
     *                   MEMORY+MLOCX,TIMLIM/60.0D+00,
     *                   TIMLIM/(60.0D+00*60.0D+00*24.0D+00),
     *                   GOPARR,BALTYP,KDIAG,COREFL
      END IF
C
C     ----- KILL IF OPEN SHELL, BUT RHF TYPE -----
C
      IF(NA.NE.NB  .AND.  SCFTYP.EQ.RHF) THEN
         WRITE (IW,9230) NA,NB
         CALL ABRT
      END IF
C
C        AT THIS POINT, ASSUME NO HESSIAN IS BEING COMPUTED
C        -IHESSM- SHOULD BE SET TO 1/2 FOR NUMERIC/ANALYTIC LATER.
C        GEOMETRY SEARCHES MIGHT BE REQUESTING HESS=CALC OR HSSEND,
C        READ INPUT EARLY SO THAT -ECPPAR- WILL KNOW WHAT IS COMING...
C
C     ---- CHECK IFREEZ(I) IN $STATPT FOR PARTIAL HESSIAN ANALYSIS ----
C
      IHESSM = 0
      IF(RUNTYP.EQ.OPTIM   .OR.  RUNTYP.EQ.SADPT  .OR.
     *   RUNTYP.EQ.HSSIAN  .OR.  RUNTYP.EQ.VSCF) THEN
         MODE=-27
         CALL SIGINI(MODE,RUNTYP,1,1,RMETHD,OUT,GOTEG,
     *               NPRT,NPUN,ITBMAT,STPT,STSTEP,PROJCT,
     *               DUMMY,DUMMY,1,NPRTHS)
      END IF
C
C       LEVEL OF NUMERICAL DIFFERENTIATION FOR NUCLEAR GRADIENT/HESSIAN
C
      NGLEVL=0
      NHLEVL=0
      IF(NUMGRD) NGLEVL=1
C
C        THE DEFAULT IS NO APPLIED EXTERNAL ELECTRIC FIELD
C
      IEXTFLD=0
C
C     INITIALIZE SOME ECP PARAMETERS (FOR ALL RUNS, NOT JUST ECP).
C     POSSIBLE READ MODEL CORE POTENTIAL PARAMETERS
C
      CALL ECPPAR
      IF (IECP.EQ.5)  CALL MMPCOR
C
C     ----- READ INPUT FOR POSSIBLE SOLVATION TREATMENTS -----
C     NOTE THAT EFFECTIVE FRAGMENT INPUT SHOULD BE READ BEFORE PCM MODEL
C     CHECK FOR SELF CONSISTENT REACTION FIELD ($SCRF)
C     CHECK FOR EFFECTIVE FRAGMENT POTENTIALS ($EFRAG)
C     CHECK FOR POLARIZABLE CONTINUUM MODEL ($PCM)
C     CHECK FOR DIELECTRIC SCREENING OPTION ($COSMO)
C     CHECK FOR SURFACE AND VOLUME POLARIZATION ($SVP)
C
      CALL ZRFINP
      CALL EFINP(IUNTRD,IEF)
      CALL PCMINP
      CALL COSMIN
      CALL SVPINP
C
C     MAKE SURE NO MORE THAN ONE SOLVENT MODEL IS REQUESTED,
C     EXCEPT FOR THE COMBINATION OF EFP+PCM
C
      NSOLV = 0
      IF(IZRF.EQ.1) NSOLV=NSOLV+1
      IF(IPCM.EQ.1) NSOLV=NSOLV+1
      IF(IEF.EQ.1)  NSOLV=NSOLV+1
      IF(ISEPS)     NSOLV=NSOLV+1
      IF(ISVP.EQ.1) NSOLV=NSOLV+1
C
      IF(IPCM.EQ.1  .AND.  IEF.EQ.1) THEN
         IP_F=1
         NSOLV=NSOLV-1
      ELSE
         IP_F=0
      END IF
C
      IF(NSOLV.GT.1) THEN
         IF(MASWRK) WRITE(IW,9240)
         CALL ABRT
      END IF
C
C        PARTITION EFP'S OVER PROCESSORS
C
      IF(NFRG.GT.0) THEN
        DDI_ME = ME
        DDI_NP = NPROC
        IF (MOD(NFRG,DDI_NP) .EQ. 0) THEN
          LOCNFG = NFRG / DDI_NP
          NLOW = DDI_ME * LOCNFG + 1
        ELSE
          CEIL = NFRG/DDI_NP + 1
          FLO = NFRG/DDI_NP
          DIFF = NFRG - DDI_NP*FLO
C
          IF (DDI_ME .GT. (DDI_NP-1-DIFF)) THEN
            LOCNFG = CEIL
            NLOW = DDI_ME * LOCNFG - (DDI_NP-1-DIFF)
          ELSE
            LOCNFG = FLO
            NLOW = DDI_ME * LOCNFG + 1
          END IF
        END IF
        NUP =  NLOW + LOCNFG - 1
        IF(GOPARR) THEN
C    THERE IS AN UNFORTUNATE COMMON BLOCK DIMENSION USED HERE.
          IF(DDI_NP.GT.MXPRO) THEN
             IF(MASWRK) WRITE(IW,*)
     *          'ERROR IN PARALLEL EFP, MXPRO,NPROC=',MXPRO,DDI_NP
             CALL ABRT
          END IF
          CALL VICLR(NFRGAL,1,MXPRO)
          CALL VICLR(NLOWAL,1,MXPRO)
          CALL VICLR( NUPAL,1,MXPRO)
          NFRGAL(DDI_ME+1) = LOCNFG
          NLOWAL(DDI_ME+1) = NLOW
           NUPAL(DDI_ME+1) = NUP
          CALL DDI_GSUMI(660,NFRGAL,DDI_NP)
          CALL DDI_GSUMI(661,NLOWAL,DDI_NP)
          CALL DDI_GSUMI(662, NUPAL,DDI_NP)
        ELSE
          NFRGAL(1) = NFRG
          NLOWAL(1) = 1
           NUPAL(1) = NFRG
        END IF
      END IF
C
C        READ INFORMATION DEFINING THE PCM CAVITY SPHERES
C        READ INPUT FOR TESSERA DEFINITION
C        READ INPUT FOR PCM GRADIENT METHODS
C
      CALL DERCHK(NDER)
      IF(IPCM.EQ.1.OR.IP_F.EQ.1) CALL INPPCM(NDER,MXATM,NAT)
C
C     ----- SET UP FOR EFP + PCM -----
C
      CALL EFFMO
C
C     ----- MINIMUM ENERGY CROSSING -----
C     READ THIS BEFORE $SCF AND $MP2 AND/OR $MCSCF INPUT
C
      IF(RUNTYP.EQ.AMEX) CALL MEXINP
      MEXSKPGES=0
      MEXSTATE=0
C
C     ----- PROPERTIES INPUT -----
C
      CALL PROPIN
C
C     ----- SCF INPUT -----
C
      IF(SCFTYP.NE.RMC) THEN
         CALL SCFIN
         CALL MIINP
      END IF
C
C     ----- INTEGRAL TRANSFORMATION INPUT -----
C     (MUST BE READ AFTER $SCF)
C
      CALL TRFIN
C
C       ----- GET OVERALL DETAILS ABOUT MCSCF COMPUTATION -----
C     ----- GET DETAILS ABOUT MCSCF MANY ELECTRON FUNCTIONS -----
C     THE CALL TO MCIN MUST BE READ AFTER $TRANS IS READ BY -TRFIN-
C     THIS SHOULD BE BEFORE LOCALIZATION CALL -LMOINP- SO OCCUPS KNOWN
C
      IF(SCFTYP.EQ.RMC) THEN
         CALL MCIN
         IF(CISTEP.EQ.ALDET) CALL DETINP(-23,DETWRD)
         IF(CISTEP.EQ.ORMAS) CALL DETINP(-23,DETWRD)
         IF(CISTEP.EQ.GENCI) CALL GCIINP(-23,GENWRD)
         IF(CISTEP.EQ.GUGA)  CALL DRTGEN(-23,DRTWRD)
      END IF
C
C     ---- LOCALIZATION INPUT ----
C     SHOULD BE READ AFTER $SCF OR $MCSCF/ASSOCIATED INPUT
C     SO THAT WE KNOW THE NUMBERS AND TYPES OF OCCUPIED ORBITALS
C
      CALL LMOINP
C
C     ----- INTGRL INPUT -----
C     (MUST BE READ AFTER $SCF, $TRANS, AND $LOCAL, BUT BEFORE $MP2)
C
      CALL INTIN
C
C     ----- MP2 INPUT -----
C     (MUST BE READ AFTER ALL THESE: $SCF/$MCSCF, $INTGRL, AND $SCRF)
C     -MPTEST- IS FOR SKIPPING INPUT SENSIBILITY TESTS WHILE CODING
C
      MPTEST=.FALSE.
      IF(MPLEVL.EQ.2) THEN
         IF(SCFTYP.EQ.RMC  .OR.  RUNTYP.EQ.TRAN) THEN
            CALL MRMPINP(MPTEST)
         ELSE
            CALL MP2INP(MPTEST)
         END IF
      END IF
C
C     --- CIS INPUT ---
C
      IF(CITYP.EQ.CIS) CALL CISINP
C
C     --- COUPLED CLUSTER/EQUATION OF MOTION INPUT ---
C
      IF(CCTYP.NE.RNONE) CALL CCINP
      IF(CCTYP.EQ.EOMSD  .OR.
     *   CCTYP.EQ.EOMSDT .OR.
     *   CCTYP.EQ.CRCCL) CALL EOMINP(CCTYP)
C
C     --- VALENCE BOND INPUT ---
C
      IF(VBTYP.NE.RNONE) THEN
         CALL VBGMS(0)
      ELSE
         VBENGY = 0.0D+00
      END IF
C
C     ----- ADDITIONAL TESTING ON THE SENSIBILITY OF THE RUN -----
C
C     ---TEST FOR EXISTENCE OF ANALYTIC NUCLEAR GRADIENT CODE ---
C     NOTA BENE: NUCLEAR HESSIAN TESTING IS DONE IN THE ROUTINE HESSX
C     THE FOLLOWING TYPES OF JOBS LACK ANALYTIC NUCLEAR GRADIENTS:
C        MODEL CORE POTENTIALS
C        ANY KIND OF COUPLED-CLUSTER
C        MP2 FOR ROHF/RMP2 OR MCSCF
C        CI EXCEPT FOR GUGA (SERIAL ONLY) OR CIS, BOTH IFF SCFTYP=RHF
C        VALENCE BOND
C        SVP SOLVENT MODEL
C
      NERR=0
      CALL DERCHK(NDER)
      IF(NDER.EQ.1  .AND.  .NOT.NUMGRD) THEN
         IF(IECP.EQ.5) THEN
            IF(MASWRK) WRITE(IW,9061)
            NERR=NERR+1
         END IF
         IF(CCTYP.NE.RNONE) THEN
            IF(MASWRK) WRITE(IW,9062)
            NERR=NERR+1
         END IF
         IF(MPLEVL.NE.0) THEN
            OK = SCFTYP.EQ.RHF  .OR.  SCFTYP.EQ.UHF
     *        .OR.  (SCFTYP.EQ.ROHF  .AND.  OSPT.EQ.ZAPT)
            IF(.NOT.OK) THEN
               IF (MASWRK) WRITE(IW,9063)
               NERR=NERR+1
            END IF
         END IF
         IF(CITYP.NE.RNONE) THEN
            OK = SCFTYP.EQ.RHF  .AND.  (CITYP.EQ.GUGA .OR. CITYP.EQ.CIS)
            IF(.NOT.OK) THEN
               IF (MASWRK) WRITE(IW,9064)
               NERR=NERR+1
            END IF
            IF(GOPARR  .AND.  CITYP.NE.CIS) THEN
               IF (MASWRK) WRITE(IW,9065)
               NERR=NERR+1
            END IF
         END IF
         IF(VBTYP.NE.RNONE) THEN
            IF (MASWRK) WRITE(IW,9066)
            NERR=NERR+1
         END IF
         IF(ISVP.EQ.1) THEN
            IF (MASWRK) WRITE(IW,9067)
            NERR=NERR+1
         END IF
      END IF
C             SOMEONE DEVELOPING NEW CODE NEEDS A WAY AROUND THE KILL,
C             BUT OF COURSE THERE'S NO REASON TO DOCUMENT THIS KEYWORD.
      IF(NERR.GT.0) THEN
         IF(GRDTST) THEN
            IF(MASWRK) WRITE(IW,*)
     *         'TEST RUN BEING ALLOWED TO PROCEED ANYWAY'
         ELSE
            IF(MASWRK) WRITE(IW,9069) RUNTYP
            CALL ABRT
         END IF
      END IF
C
C        AT MOST, ONE CORRELATION METHOD IS TO BE ALLOWED.
C
      MCORR=0
      IF(DFTYPE.NE.RNONE) MCORR=MCORR+1
      IF(VBTYP.NE.RNONE)  MCORR=MCORR+1
      IF(CITYP.NE.RNONE)  MCORR=MCORR+1
      IF(CCTYP.NE.RNONE)  MCORR=MCORR+1
      IF(MPLEVL.GT.0)     MCORR=MCORR+1
      IF(MCORR.GT.1) THEN
         IF (MASWRK) WRITE(IW,9250)
         CALL ABRT
      END IF
C
C        MOPAC RUNS SHOULD ONLY BE SINGLE REFERENCE TREATMENTS
C        MOPAC CAN'T DO LOCALIZED ORBITALS
C        MOPAC CAN'T DO GAUSSIAN BASIS PROPERTIES
C        MOPAC CAN'T RUN IN PARALLEL
C
      NERR=0
      IF(MPCTYP.NE.NONE) THEN
         IF(SCFTYP.EQ.RMC)   NERR=NERR+1
         IF(MCORR.GT.0)      NERR=NERR+1
         IF(TLOCAL.NE.RNONE) NERR=NERR+1
         IF(IEDEN.GT.0)      NERR=NERR+1
         IF(IEMOM.GT.1)      NERR=NERR+1
         IF(IEFLD.GT.0)      NERR=NERR+1
         IF(IEPOT.GT.0)      NERR=NERR+1
         IF(NPROC.GT.1)      NERR=NERR+1
         IF(NERR.GT.0) THEN
            IF(MASWRK) WRITE(IW,9260) MPCTYP
            CALL ABRT
         END IF
      END IF
C
C        PROPERTY RUN REQUIRES DENSITY MATRIX BE COMPUTABLE FROM
C        A SET OF MOREAD ORBITALS...NO WAVEFUNCTION EVALUATION
C        WILL BE DONE, SO REALLY ONLY SCF/DFT WORKS FOR THIS.
C
      IF(RUNTYP.EQ.PROP) THEN
         OK = .TRUE.
         IF(SCFTYP.EQ.RMC)  OK=.FALSE.
         IF(VBTYP.NE.RNONE) OK=.FALSE.
         IF(MPLEVL.GT.0)    OK=.FALSE.
         IF(CITYP.NE.RNONE) OK=.FALSE.
         IF(CCTYP.NE.RNONE) OK=.FALSE.
         IF(.NOT.OK) THEN
            IF(MASWRK) WRITE(IW,9280)
            CALL ABRT
         END IF
      END IF
C
C     --- CHECK SOLVENT MODEL VERSUS CORRELATION MODEL ---
C     NOTE THAT SOLVATION IS ALLOWED WITH MP2, HERE, UNLESS
C     THERE'S ANOTHER TRAP IN THE INDIVIDUAL SOLVENT MODEL INPUT
C     ROUTINES.
C     THE "PTE" MODEL DESCRIBED BY J.PHYS.CHEM.A 103, 9100(1999)
C     SUGGESTS THAT SOLVATED SCF ORBITALS CAN BE SENT INTO THE
C     PERTURBATION THEORY CODE TO GET THE ENERGY, BUT THAT OTHER
C     TERMS HAVE TO BE CONSIDERED TO GET THE GRADIENT.
C     NOTE THAT WE LET EFP+MP2 SLIDE AT THIS POINT, BUT PROBABLY
C     THIS SHOULD BE RECONSIDERED.
C     MCSCF PERTURBATION PERHAPS BANNED DUE TO NOT PUTTING SOLVENT
C     EFFECTS INTO THE FOCK MATRIX USED FOR CANONICALIZATION?
C
      IF(NSOLV.GT.0) THEN
         OK=.TRUE.
         IF(VBTYP.NE.RNONE) OK=.FALSE.
         IF(CITYP.NE.RNONE) OK=.FALSE.
         IF(CCTYP.NE.RNONE) OK=.FALSE.
         IF(MPCTYP.NE.NONE) OK=.FALSE.
         IF(MPLEVL.GT.0  .AND.  SCFTYP.EQ.RMC) OK=.FALSE.
         IF(MPLEVL.GT.0  .AND.  NDER.EQ.1  .AND.  .NOT.NUMGRD
     *        .AND.  (NFRG.EQ.0  .OR.  IP_F.EQ.1)) OK=.FALSE.
         IF(.NOT.OK) THEN
            IF(MASWRK) WRITE(IW,9290)
     *           SCFTYP,MPLEVL,CITYP,CCTYP,MPCTYP,VBTYP
            CALL ABRT
         END IF
      END IF
C
C     NOW, CRASH ANY H OR I BASIS FUNCTION RUN WHATSOEVER
C     THIS SHOULD BE TAKEN OUT, IN FAVOR OF A TEST SUCH AS FOLLOWS
C
      CALL BASCHK(LMAX)
      IF(LMAX.GE.6) THEN
         IF(MASWRK) WRITE(IW,*) 'NO H OR I FUNCTIONS ALLOWED'
         CALL ABRT
      END IF
C
C     ONCE SPDFGHI CODING IN ENERGY AND PROPERTIES IS DONE,
C     WE WILL STILL NEED TO KILL ANY OF THE FOLLOWING:
C        ANYTHING DOING 1ST OR 2ND DERIVATIVES ANALYTICALLY
C        NMR - RELIES ON ITS OWN DERIVATIVE INTEGRALS
C        SOLVENT MODELS - EVERY LAST ONE
C        MCP OR ECP PSEUDOPOTENTIALS
C        RELATIVITY - BOTH SPIN-ORBIT AND SCALAR EFFECTS
C        DFT?    FMO?   ANYTHING ELSE?
C     N.B. VECTOR.SRC WILL NEED FIXING, TOO
C
C     ----- Z MATRIX INPUT -----
C
      NVAR = 0
      NZMAT = 0
      NVAR2 = 0
      NZMAT2 = 0
      CARTSN = NZVAR.EQ.0
C
C         USE THE $ZMAT IN THE INPUT STREAM
C
      IF(NZVAR.GT.0 .AND. RUNTYP.NE.HSSIAN.AND.NFG.EQ.0) THEN
         CALL ZMATIN(CARTSN)
         CALL BANDBI
         CALL PZANDG(F,0)
      END IF
C
C         GENERATE $ZMAT FOR COORD=ZMT OR ZMTMPC
C
      IF(NZVAR.EQ.0  .AND. RUNTYP.NE.HSSIAN  .AND.
     *   ICOORD.GE.2 .AND. NATREL.GT.0) THEN
         NZVAR = NZVAR2
         CALL ZMATIN(CARTSN)
         CALL BANDBI
         NZVAR = 0
         NVAR = 0
         NZMAT = 0
      END IF
C
      IF(IREST.LT.0) IREST = 0
C
C     ----- SET UP TRIANGULAR INDEX MATRIX -----
C
      DO 900 I = 1,MXAO
        IA(I) = (I*I-I)/2
  900 CONTINUE
C
C        INITIALIZE COMMON /SIMDAT/ THAT CONTROLS THE MONTE CARLO,
C        SIMULATED ANNEALING GLOBAL OPTIMIZATION
C
      NACC  =0
      NACCT =0
      NPRTGO=1
      IDPUNC=0
C
C     ----- PREPARE FOR ORBITAL SYMMETRY ASSIGNMENTS -----
C     AND RESTORE /SYMSPD/ CARTESIAN SPACE TRANSFORMATIONS, IF NEEDED.
C     THIS IS KEPT HERE, AS SOME RUNS, LIKE PCM, TURN SYMMETRY OFF
C
      IF (ICOORD.NE.4) THEN
         CALL SYMORB
         IF(ISPHER.GT.0) CALL SPDTR
      END IF
C
      IF (MASWRK) WRITE(IW,9540)
      IF(ISGDDI) CALL GDDI_SCOPE(DDI_WORLD)
      CALL TIMIT(1)
      RETURN
C
 9005 FORMAT(1X,'TYPING ERROR IN $CONTRL INPUT - CHECK NEAR $ MARKER')
 9010 FORMAT(/1X,'ERROR: $CONTRL KEYWORD ',A6,
     *          ' WAS GIVEN AN ILLEGAL VALUE ',A8,'.'/)
 9031 FORMAT(/1X,'ERROR: VBTYP IS PROGRAMMED ONLY FOR',
     *           ' SCFTYP=RHF OR ROHF'/)
 9032 FORMAT(/1X,'ERROR: VBTYP JOBS CANNOT RUN IN PARALLEL.'/)
 9033 FORMAT(/1X,'ERROR: CCTYP IS PROGRAMMED ONLY FOR SCFTYP=RHF'/)
 9034 FORMAT(/1X,'ERROR: CCTYP JOBS CANNOT RUN IN PARALLEL.'/)
 9050 FORMAT(/1X,'ERROR: SCFTYP,CITYP,RUNTYP,MPLEVL=',3A8,I3/
     *          ' IS AN ILLEGAL COMBINATION'/)
 9061 FORMAT(/1X,'MODEL CORE POTENTIALS HAVE NO ANALYTIC NUCLEAR',
     *           ' GRADIENT PROGRAMMED.')
 9062 FORMAT(/1X,'CCTYP HAS NO ANALYTIC NUCLEAR GRADIENT PROGRAMMED.')
 9063 FORMAT(/1X,'MPLEVL=2 HAS ANALYTIC NUCLEAR GRADIENTS ONLY FOR',
     *           ' THE FOLLOWING CASES:'/
     *        1X,'SCFTYP=RHF, SCFTYP=UHF, OR SCFTYP=ROHF OSPT=ZAPT.')
 9064 FORMAT(/1X,'CITYP HAS NO ANALYTIC NUCLEAR GRADIENT PROGRAMMED,'/
     *        1X,'EXCEPT FOR SCFTYP=RHF WITH CITYP=GUGA OR CITYP=CIS.')
 9065 FORMAT(/1X,'ONLY THE GRADIENTS FOR CITYP=CIS RUN IN PARALLEL.')
 9066 FORMAT(/1X,'VALENCE BOND COMPUTATION HAS NO ANALYTIC GRADIENT.')
 9067 FORMAT(/1X,'SVP SOLVATION MODEL HAS NO ANALYTIC GRADIENT.')
 9069 FORMAT(/12X,'* * * ERROR * * *'/
     *        1X,'YOUR RUNTYP=',A8,' REQUIRES NUCLEAR GRADIENTS,'/
     *        1X,'WHICH ARE NOT AVAILABLE ANALYTICALLY (SEE ABOVE).'/
     *        1X,'IF THE NUMBER OF SYMMETRY UNIQUE ATOMS IS RATHER',
     *           ' SMALL,'/
     *        1X,'YOU MIGHT CONSIDER NUMERICAL DERIVATIVES:'/
     *        1X,' $CONTRL NUMGRD=.T. $END'/
     *        1X,'YOU MUST EXPLICITLY ASK FOR THIS OPTION BECAUSE IT',
     *           ' IS SO TIME CONSUMING.'/)
 9070 FORMAT(/1X,'ERROR: CI IS NOT AVAILABLE FOR UHF WAVEFUNCTIONS.'/)
 9080 FORMAT(/1X,'ERROR: ONLY MPLEVL=2 IS POSSIBLE AT PRESENT.'/)
 9090 FORMAT(/1X,'ERROR: MAXIT MUST BE BETWEEN 0 AND 200, NOT',I8)
 9200 FORMAT(/1X,'             *** ERROR(S) DETECTED ***'/
     *        1X,'YOUR $CONTRL INPUT HAS AT LEAST ONE SPELLING OR',
     *           ' LOGIC MISTAKE.'/
     *        1X,'PLEASE REVIEW THE REASON(S) JUST LISTED, AND TRY',
     *           ' YOUR RUN AGAIN.'/)
C
 9210 FORMAT(/1X,'ERROR: COORD=',A8,' WAS CHOSEN'/
     *        1X,'USE ONLY COORD=TINKER OR COORD=UNIQUE FOR QMMM',
     *           ' OPTIMIZATIONS'/)
 9220 FORMAT(/1X,'ERROR: CURRENT QMMM IMPLEMENTATION REQUIRES DLC',
     *            ' COORDINATES (SEE $ZMAT)'/)
 9230 FORMAT(/1X,'ERROR: AN ODD NUMBER OF ELECTRONS IS IMPOSSIBLE',
     *           ' WITH RHF.'/
     *        1X,'THIS RUN HAS',I4,' ALPHA AND',I4,' BETA ELECTRONS.'/
     *        1X,'PLEASE REVIEW YOUR SCFTYP,MULT,ICHARG INPUT VALUES,'/
     *        1X,'AND CHECK THE NUMBER OF ATOMS GENERATED IN $DATA'/)
 9240 FORMAT(/1X,'ERROR: MULTIPLE SOLVENT MODELS SELECTED.'/
     *        1X,'NO MORE THAN ONE OF THE SCRF/PCM/EFP/COSMO/SVP'/
     *        1X,'SOLVENT MODELS SHOULD BE CHOSEN.'/
     *        1X,'THE EXCEPTION IS EFP+PCM MAY BE SELECTED'/)
 9250 FORMAT(/1X,'ERROR: YOU MAY CHOOSE AT MOST ONE CORRELATION',
     *           ' METHOD FROM'/
     *      1X,'CITYP, MPLEVL, OR CCTYP IN $CONTRL, OR DFTTYP IN $DFT'/)
 9260 FORMAT(/1X,'ERROR: THE MOPAC PARAMETERIZATION REQUESTED IS ',A4/
     *       5X,'SEMI-EMPIRICAL COMPUTATIONS MAY NOT BE PERFORMED WITH'/
     *      10X,'ANY TYPE OF CI, MP, CC, DFT, OR WITH SCFTYP=MCSCF.'/
     *       5X,'SEMI-EMPIRICAL JOBS CANNOT LOCALIZE ORBITALS.'/
     *       5X,'SEMI-EMPIRICAL RUNS USE MINIMAL STO BASIS SETS, SO'/
     *      10X,'YOU CANNOT REQUEST EXOTIC GAUSSIAN BASIS PROPERTIES.'/
     *       5X,'SEMI-EMPIRICAL JOBS MAY NOT BE RUN IN PARALLEL.'/
     *       1X,'YOUR INPUT REQUESTED AT LEAST ONE OF THESE IMPOSSIBLE',
     *          ' THINGS.'/)
 9280 FORMAT(/1X,'ERROR: NOT ENOUGH INFORMATION FOR RUNTYP=PROP.'/
     *       1X,'THE 1ST ORDER DENSITY MATRIX CANNOT BE GENERATED FROM'/
     *       1X,'KNOWLEDGE OF ONLY THE ORBITALS FOR'/
     *       1X,'    MCSCF, VB, CI, MP2, OR CC'/
     *       1X,'CALCULATIONS.  PLEASE REQUEST RUNTYP=ENERGY SO THE'/
     *       1X,'WAVEFUNCTION AND HENCE ITS DENSITY IS REGENERATED.'/)
 9290 FORMAT(/1X,'ERROR: INAPPROPRIATE SOLVENT CALCULATION.'/
     *       1X,'SOLVENT MODELS (ALL TYPES) ARE INCOMPATIBLE WITH MANY'/
     *       1X,'TYPE OF CORRELATED OR SEMI-EMPIRICAL COMPUTATIONS:'/
     *       1X,'SCFTYP=',A8/
     *       1X,'MPLEVL=',I2,' USING GRADIENTS, CITYP=',A8,' CCTYP=',A8/
     *       1X,'VBTYP=',A8,' OR MPCTYP=',A4/)
C
 9500 FORMAT(/1X,'---- FRIEND=',A8,2X,' FORCES EXETYP=',A8/)
 9510 FORMAT(/1X,'THIS MOLECULE IS RECOGNIZED AS BEING LINEAR.')
 9515 FORMAT(/1X,'*** ERROR ***'/
     *       1X,'YOU ARE USING POINT GROUP SYMMETRY IN COORD=HINT',
     *          ' MOLECULAR BUILDING INPUT'/
     *       1X,'AT EVERY STEP IN A RUNTYP=TRUDGE JOB,',
     *          ' BUT ARE ASKING TO TURN SYMMETRY OFF'/
     *       1X,'WITH NOSYM=1.  PLEASE GIVE A C1 SYMMETRY COORD=HINT',
     *          ' $DATA INPUT GROUP IF'/
     *       1X,'YOU REALLY WISH TO DO A RUN WITHOUT SYMMETRY,',
     *          ' OR REMOVE THE NOSYM=1 VALUE.'/)
 9520 FORMAT(/5X,'$CONTRL OPTIONS'/5X,15(1H-)/
     * 1X,'SCFTYP=',A8,5X,'RUNTYP=',A8,5X,'EXETYP=',A8/
     * 1X,'MPLEVL=',I8,5X,'CITYP =',A8,5X,'CCTYP =',A8,5X,'VBTYP =',A8/
     * 1X,'MULT  =',I8,5X,'ICHARG=',I8,5X,'NZVAR =',I8,5X,'COORD =',A8/
     * 1X,'PP    =',A8,5X,'RELWFN=',A8,5X,'LOCAL =',A8,5X,'NUMGRD=',L8/
     * 1X,'ISPHER=',I8,5X,'NOSYM =',I8,5X,'MAXIT =',I8,5X,'UNITS =',A8/
     * 1X,'PLTORB=',L8,5X,'MOLPLT=',L8,5X,'AIMPAC=',L8,5X,'FRIEND=',A8/
     * 1X,'NPRINT=',I8,5X,'IREST =',I8,5X,'GEOM  =',A8/
     * 1X,'NORMF =',I8,5X,'NORMP =',I8,5X,'ITOL  =',I8,5X,'ICUT  =',I8/
     * 1X,'INTTYP=',A8,5X,'GRDTYP=',A8,5X,'QMTTOL=',1P,E8.1,0P)
 9530 FORMAT(/5X,'$SYSTEM OPTIONS'/5X,15(1H-)/
     *  1X,' REPLICATED MEMORY=',I12,' WORDS (ON EVERY NODE).'/
     *  1X,'DISTRIBUTED MEMDDI=',I12,' MILLION WORDS IN AGGREGATE,'/
     *  1X,'MEMDDI DISTRIBUTED OVER',I4,' PROCESSORS IS',I12,
     *     ' WORDS/PROCESSOR.'/
     *  1X,'TOTAL MEMORY REQUESTED ON EACH PROCESSOR=',I12,' WORDS.'/
     *  1X,'TIMLIM=',F15.2,' MINUTES, OR ',F8.2,' DAYS.'/
     *  1X,'PARALL=',L2,'  BALTYP=',A8,'  KDIAG=',I5,'  COREFL=',L2)
 9540 FORMAT(/1X,'..... DONE SETTING UP THE RUN .....')
      END
C*MODULE INPUTA  *DECK SYSINP
      SUBROUTINE SYSINP(MEMORY,MEMDDI)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL COREFL,PTIME,GOPARR,DSKWRK,MASWRK,XDR,PARALL
C
      PARAMETER (NNAM=11, MXUNIT=299)
C
      DIMENSION QNAM(NNAM),KQNAM(NNAM)
C
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /MACHSW/ KDIAG,ICORFL,IXDR
      COMMON /OPNNFT/ NFTOPN(MXUNIT),NODEXT(MXUNIT)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /RESTAR/ TIMLIM,IREST,NREC,INTLOC,IST,JST,KST,LST
C
      PARAMETER (ZERO=0.0D+00)
C
      DATA BLANK /8H        /
      DATA RNXTVL,RLOOP/8HNXTVAL  ,8HLOOP    /
C
C      ----- SET UP NAMELIST $SYSTEM TABLES -----
C
      DATA SYSTEM /8HSYSTEM  /
      DATA QNAM/8HMEMORY  ,8HTIMLIM  ,8HPTIME   ,8HCOREFL  ,
     *          8HKDIAG   ,8HBALTYP  ,8HXDR     ,8HPARALL  ,
     *          8HMEMDDI  ,8HMWORDS  ,8HNODEXT  /
      DATA KQNAM /1,3,0,0,1,5,0,0,1,1,1/
C
C     ----- INITIALIZE VARIABLES FOR NAMELIST $SYSTEM -----
C         THE DEFAULT FOR 'GOPARR' IS ALREADY SET BEFORE GETTING HERE,
C         BUT THE KEYWORD 'PARALL' ALLOWS US TO SET THIS VARIABLE TRUE,
C         EVEN WHEN RUNNING ON ONE NODE, TO EXERCISE THE PARALLEL CODES.
C         'MEMORY' AND 'MWORDS' ARE THE SAME INPUT VALUE IN DIFFERENT
C         UNITS, ON EXIT 'MEMORY' SHOULD BE IN WORDS, BUT 'MEMDDI'
C         WILL STILL BE IN MEGAWORDS TO AVOID 32 BIT OVERFLOWS.
C
C         PRINTING OF THESE INPUT VALUES IS POSTPONED TO -START-
C
      MEMORY = 0
      TIMLIM = ZERO
      PARALL = NPROC.GT.1
      PTIME  = .FALSE.
      COREFL = .FALSE.
      KDIAG  = 0
      BALTYP = BLANK
      XDR = .FALSE.
      MEMDDI = 0
      MWORDS = 0
      KQNAM(11)=MXUNIT*10+1
C
C         FINALLY, -SEQOPN- HAS ALREADY SET THE DEFAULT VALUES
C         FOR -NODEXT- WHEN OPENING UNIT 5.
C
C        ----- READ NAMELIST $SYSTEM -----
C
      JRET = 0
      CALL NAMEIO(IR,JRET,SYSTEM,NNAM,QNAM,KQNAM,
     *            MEMORY,TIMLIM,PTIME,COREFL,KDIAG,BALTYP,XDR,PARALL,
     *            MEMDDI,MWORDS,NODEXT,
     *            0,0,0,
     *     0,0,0,0,0,  0,0,0,0,0,
     *     0,0,0,0,0,  0,0,0,0,0,   0,0,0,0,0,  0,0,0,0,0,
     *     0,0,0,0,0,  0,0,0,0,0,   0,0,0,0,0,  0,0,0,0,0)
      IF(JRET .EQ. 2) THEN
         IF (MASWRK) WRITE (IW,9008)
         CALL ABRT
      END IF
C
      IF(TIMLIM.EQ.ZERO) TIMLIM=525600.0D+00
      TIMLIM=TIMLIM*60.0D+00
C
C          CHECK SPELLINGS, AND ALSO SET THE OPTION FLAGS
C
      NERR = 0
      IF (PTIME) THEN
         IPTIM=1
      ELSE
         IPTIM=0
      END IF
C
      IF(XDR) THEN
         IXDR=1
      ELSE
         IXDR=0
      END IF
C
      IF (COREFL) THEN
         ICORFL=1
      ELSE
         ICORFL=0
      END IF
C
      IBTYP = 8
      IF(BALTYP.EQ.BLANK)  BALTYP = RNXTVL
      IF(BALTYP.EQ.RLOOP)  IBTYP  = 0
      IF(BALTYP.EQ.RNXTVL) IBTYP  = 1
      IF(IBTYP.EQ.8) THEN
         IF (MASWRK) WRITE(IW,9010) 'BALTYP',BALTYP
         NERR = NERR+1
      END IF
C
      IF(MEMORY.NE.0  .AND.  MWORDS.NE.0
     *       .AND.  1000000*MWORDS.NE.MEMORY) THEN
         IF(MASWRK) WRITE(IW,9020) MEMORY,MWORDS
         NERR = NERR+1
      END IF
      IF(MWORDS.NE.0) MEMORY = 1000000*MWORDS
      IF(MEMORY.LT.0  .OR.  MEMDDI.LT.0) THEN
         IF(MASWRK) WRITE(IW,*)
     *     '*** YOU REQUESTED A NEGATIVE VALUE FOR MEMORY OR MEMDDI.'
         NERR = NERR+1
      END IF
C
      IF(NERR.GT.0) THEN
         IF (MASWRK) THEN
         WRITE(IW,*) 'YOUR $SYSTEM HAS AT LEAST ONE SPELLING MISTAKE.'
         WRITE(IW,*) 'THE JOB IS HALTING SO YOU CAN FIX IT.'
         END IF
         CALL ABRT
      END IF
C
C     ----- MAKE IBTYP = 0 FOR ANY MACHINES WITH EQUAL NODES -----
C
      IF(NPROC.GT.1) PARALL=.TRUE.
      GOPARR = PARALL
      CALL PARSET
      RETURN
C
 9008 FORMAT(1X,'ERROR IN $SYSTEM INPUT')
 9010 FORMAT(1X,'*** ERROR! KEYWORD ',A6,
     *     ' WAS GIVEN AN ILLEGAL VALUE ',A8,'.')
 9020 FORMAT(1X,'INCONSISTENT MEMORY REQUEST'/
     *       1X,'BOTH MEMORY=',I12,' AND MWORDS=',I12,' WERE INPUT.')
      END
C*MODULE INPUTA  *DECK GDDINP
      SUBROUTINE GDDINP
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      LOGICAL ISGDDI,PAROUT
      LOGICAL GOPARR,MASWRK,DSKWRK
      PARAMETER(MXUNIT=299,MAXGR=1024)
      PARAMETER (NNAM=4)
      DIMENSION QNAM(NNAM),KQNAM(NNAM),MANNOD(0:MAXGR-1),BALT(0:1)
C
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /GDDI/   ISCOPE,NGROUPS,MYGROUP,MEGLOB,NPGLOB,NNGLOB,JBTYP,
     *                ISGDDI,PAROUT
      COMMON /OPNNFT/ NFTOPN(MXUNIT),NODEXT(MXUNIT)
      DATA RNXTVL,RLOOP/8HNXTVAL  ,8HLOOP    /
C
C      ----- SET UP NAMELIST $GDDI TABLES -----
C
      DATA GDDI /8HGDDI    /
      DATA QNAM /8HNGROUP  ,8HPAROUT  ,8HBALTYP  ,8HMANNOD  /
      DATA KQNAM /1,0,5,1/
C
C     ----- INITIALIZE VARIABLES FOR NAMELIST $GDDI -----
C
      ISGDDI  = .FALSE.
      NGROUPS = 0
      MYGROUP = 0
      MEGLOB = ME
      PAROUT  = .TRUE.
      BALTYP  = RNXTVL
      KQNAM(4)=NPROC*10+1
C     MANNOD CONTAINS MANUAL DIVISION OF NODES INTO GROUPS
C     E.G. MANNOD(2) CONTAINS THE NUMBER OF NODES FOR GROUP 2.
C     MANNOD(0)=-1 ENFORCES AUTOMATIC GROUP DIVISION (DEFAULT).
C     WE CANNOT ALLOCATE NPROC MEMORY FOR MANNOD HERE: MEMORY POOL HAS
C     NOT BEEN INITIALISED YET! (AND WE WANT TO INITIALISE IT AFTER
C     SWITCHING ON GROUP DIVISION.)
      CALL VICLR(MANNOD,1,NPROC)
      MANNOD(0)=-1
      BALT(0)=RLOOP
      BALT(1)=RNXTVL
C
C        ----- READ NAMELIST $GDDI -----
C
      JRET = 0
      CALL NAMEIO(IR,JRET,GDDI,NNAM,QNAM,KQNAM,
     *            NGROUPS,PAROUT,   BALTYP,MANNOD,
     *     0,0,0,0,0,  0,0,0,0,0,   0,0,0,0,0,  0,0,0,0,0,
     *     0,0,0,0,0,  0,0,0,0,0,   0,0,0,0,0,  0,0,0,0,0,
     *     0,0,0,0,0,  0,0,0,0,0,   0,0,0,0,0,  0,0,0,0,0)
C
      IF(JRET .EQ. 2) THEN
C        IF (MASWRK) WRITE (IW,*) "PROBLEM IN $GDDI"
         CALL ABRT
      END IF
C
      JBTYP   = 0
      IF(BALTYP.EQ.RLOOP) THEN
        JBTYP  = 0
      ELSE IF(BALTYP.EQ.RNXTVL) THEN
        JBTYP  = 1
      ELSE
        IF (MASWRK) WRITE(IW,9010) 'BALTYP',BALTYP
        CALL ABRT
      END IF
      IF(NGROUPS.GT.MAXGR) CALL ABRT
C
C     CHECK GDDI INPUT
C     ----------------
C
      CALL DDI_NPROC(NPGLOB,MEGLOB)
      CALL DDI_NNODE(NNGLOB,MYNODE)
      IF(NGROUPS.GT.0) ISGDDI = .TRUE.
      IF(NGROUPS.GT.NNGLOB) THEN
         WRITE(IW,*) 'GDDI ERROR: MORE GROUPS THAN NODES'
         CALL FLSHBF(IW)
         CALL ABRT
      END IF
      IF(NGROUPS.GT.MAXGR) CALL ABRT
      IF(NGROUPS.GT.0.AND.MANNOD(0).GE.0) THEN
        NNODE0=0
        DO I=0,NGROUPS-1
          NNODE0=NNODE0+MANNOD(I)
        ENDDO
        IF(NNODE0.NE.NNGLOB) THEN
          IF(MASWRK) WRITE(IW,*) 'CHECK MANNOD IN $GDDI',NNODE0,NNGLOB
          CALL ABRT
        END IF
      END IF
C     -----------------------------------------------------------------
C     IF USING GDDI, THEN HAVE EACH OF THE NODES OPEN THE CORRECT FILES
C     AND HAVE THE MASTER OF EACH GROUP PARSE THE INPUT FILE.  THAT WAY
C     ALL THE GROUPS MASTER HAVE THE SAME INFO AS THE GLOBAL MASTER.
C     -----------------------------------------------------------------
      IF(ISGDDI) THEN
C        CALL STORENV WHILE STILL IN THE WORLD SCOPE
         CALL STORENV
         CALL GDDI_INIT(NGROUPS,MANNOD)
         CALL DDI_NPROC(NPGRP,MEGRP)
C        IF(MYGROUP.NE.0 .AND. MASWRK) THEN
         IF(MEGLOB.NE.0.AND.(MASWRK.OR.PAROUT)) THEN
            NFTOPN(IR) = 0
            NFTOPN(IW) = 0
            NFTOPN(IP) = 0
C           CHANGE UNKNOWN --> NEW FOR RELEASE
            ME = MEGLOB
            CALL SEQOPN(IR,'INPUT', 'OLD',.TRUE., 'FORMATTED')
            CALL SEQOPN(IW,'OUTPUT','UNKNOWN',.FALSE., 'FORMATTED')
            CALL SEQOPN(IP,'PUNCH', 'NEW',.FALSE.,'FORMATTED')
            ME = MEGRP
         END IF
C        IF(MASWRK) WRITE(IW,1000) MYGROUP+1,NGROUPS,NPROC,
         WRITE(IW,1000) MYGROUP+1,NGROUPS,NPROC,
     *                             BALT(IAND(JBTYP,1))
      ELSE
        PAROUT  = .FALSE.
      END IF
      RETURN
 1000 FORMAT(//1X,72(1H-),
     *        /1X,'GENERALIZED DDI',7X,
     *            'PROGRAMMED BY: RYAN M. OLSON AND DMITRI G. FEDOROV',
     *        /12X,'FEDOROV ET AL., J. COMPUT. CHEM., 25 (2004) 872.'/
     *         1X,72(1H-)//
     * 1X,'-----------------------------------------------------'/
     * 1X,'GDDI: INITIALIZATION COMPLETED FOR GROUP',I4,' OF',I4/
     * 1X,'WORKING IN SCOPE DDI_GROUP (',I4,' NODES, BALTYP=',A6,').'/
     * 1X,'-----------------------------------------------------'/)
 9010 FORMAT(1X,'*** ERROR! KEYWORD ',A6,
     *     ' WAS GIVEN AN ILLEGAL VALUE ',A8,'.')
      END
