C 19 SEP 05 - MK,GDF - CHANGES FOR MCP BASIS AND FOR H+I INPUT
C  5 JUL 05 - MWS - SELECT NEW ATOM,BASIS,EFP,PCM,DAF DIMENSIONS
C 27 JUN 05 - MWS - BASISS: REMOVE PCN AND CCN SPINACH AUTOMATICALLY
C 13 FEB 05 - MWS - PAD COMMON BLOCK NSHEL
C 19 MAY 04 - DGF - CHANGES TO ADD THE FMO METHOD
C  7 APR 04 - BSD - SETLAB: CHANGE VECTOR LABEL'S FORMAT
C  9 DEC 03 - MWS - SYNCH COMMON BLOCK RUNOPT
C  4 NOV 03 - MWS - FLIPB2,RWFINP: MERGE IN DOUGLAS-KROLL CHANGES
C  3 SEP 03 - MWS - SYNCHRONIZE RELWFN COMMON
C 16 JUN 03 - CHC - TIN2GMS: REMOVE NEED FOR LINKGE INPUT
C 26 MAR 02 - KRG - USE ABRT CALL
C  6 SEP 01 - MWS - ADD DUMMY ARGUMENTS TO NAME IO CALL
C 13 JUN 01 - DGF,TN - IMPLEMENT INTERNALLY UNCONTRACTED RESC METHOD
C  9 MAY 01 - RP  - BASISS: TEST FOR ECP USED WITH NON-ECP BASIS SET
C 11 JUN 00 - GNM - BASISS: KEYWORD TO REQUEST EXTERNAL BASIS FILE
C 25 MAR 00 - DGF,TN - CODE RESC AND NESC GRADIENT
C 10 MAR 00 - CHC - FIX SIMMOM SNAGS
C 10 JAN 00 - DGF - FINISH ADDING NESC (RELATIVISTIC METHOD OF K. DYALL)
C 21 DEC 99 - HN,DGF - ADD RESC; SPDTR: WRITE F AND G TRF MATS TO DAF;
C                   ADD NEW ROUTINES FLIPBASIS, RWFINP, RELCOEFS
C  9 NOV 99 - MWS - BASISS: ADD F'S TO 6-31G TM ONLY, FIXES 13FEB99 BUG
C  2 NOV 99 - MWS - TIN2GMS: TRUNCATE MAXATM FOR NON-TINKER GAMESS
C 29 AUG 99 - CHC - USER FRIENDLY INPUT OF QMMM
C  9 APR 99 - MWS - BASISS: FIX SBKJC POLARIZATION DEFAULT
C 13 FEB 99 - MWS - PROVIDE POLARIZATION EXPONENTS FOR K-ZN FOR 6-31G
C 12 NOV 98 - GDF - MAKE SYMTRY COMMON CONSISTENT
C 16 JUL 97 - MWS - SETLAB: ADJUST FORMATTING A BIT
C 30 SEP 96 - MWS - BASISS: IMPLEMENT NFFUNC KEYWORD
C  5 MAR 96 - MWS - CHANGE SHELL SYMMETRY PACKING COMMONS
C 14 SEP 95 - MWS - CHANGE CALL TO ATOMS ROUTINE
C 10 NOV 94 - MWS - REMOVE FTNCHEK WARNINGS
C 10 AUG 94 - MWS - INCREASE NUMBER OF DAF RECORDS
C  3 NOV 93 - MH  - MOLE,PTGRP: CHARMM SKIPS READ OF TITLE, POINT GROUP
C  1 NOV 92 - MWS - BASISS: LET LIGHT ATOMS SET TO "HW" BASIS
C 12 MAR 92 - MWS - REDIMENSION TO 500 ATOMS
C 24 FEB 92 - MWS - PTGRP: CHANGE TO USE OF SYMMOL COMMON
C 20 FEB 92 - TLW - MOLE: USE NEW CALL TO FNDGRP
C  6 FEB 92 - JHJ - BASISS: IF NO P,D POLAR=NONE.
C 30 JAN 92 - TLW - SETLAB: FIX INTERNAL READS AND WRITES
C 11 JAN 92 - TLW - MOLE,SETLAB: MAKE READS PARALLEL
C 10 JAN 92 - TLW - CHANGE REWIND TO CALL SEQREW
C  7 JAN 92 - TLW - MAKE WRITES PARALLEL;ADD COMMON PAR
C 16 AUG 91 - TLW - SPDTR: EXPANDED FOR F AND G FUNCTIONS
C 14 AUG 91 - TLW - SPDTR: ADD FTR AND GTR TO COMMON SYMSPD
C 12 JUN 91 - TJP,MWS - EXTEND POLARIZATION AND DIFFUSE FUNCTIONS TO RN
C 11 APR 91 - TJP - CHANGE GALLIUM DIFFUSE EXP. TO THE SEMICORE VALUE
C 22 MAR 91 - MWS - ADD TED PACKWOOD'S DIFFUSE EXPONENTS FOR GA-BR,IN-I
C 15 DEC 90 - MWS - 6-31G BASIS SETS USE BC BASIS FOR GA-KR NOW.
C  9 NOV 90 - JHJ - MOLE: CALL TO MBLDR ADDED, SETLAB: NEW CALL OPTION.
C 17 AUG 90 - TLW - SETLAB: ADD F AND G TYPES TO BFNAM.
C  7 AUG 90 - TLW - ADD CF AND CG TO COMMON NSHEL
C 25 JUL 90 - MWS - MOVE MOLPLT AND PLTORB INTERFACE TO PARLEY MODULE
C 13 JUN 90 - MWS - BASISS: MAKE POLARIZATION TABLES DOUBLE PRECISION
C 12 MAY 90 - MWS - SPLIT INPUT INTO INPUTA AND INPUTB
C
C*MODULE INPUTB  *DECK ATOMSS
      SUBROUTINE ATOMSS(NBFS,NAT,LOC,NS1
     *                 ,KMINO,KMAXO,KSTRTO,KTYPEO,KNGO,INTYPO,KATOM
     *                 ,KMINN,KMAXN,KSTRTN,KTYPEN,KNGN,INTYPN,KLOC)
C
C           COPY INFORMATION FOR ATOM RELATED BY SYMMETRY
C
      DIMENSION KMINN(NS1),KMAXN(NS1),KSTRTN(NS1),KATOM(NS1)
     *         ,KTYPEN(NS1),KNGN(NS1),INTYPN(NS1),KLOC(NS1)
     *         ,KMINO(NS1),KMAXO(NS1),KSTRTO(NS1)
     *         ,KTYPEO(NS1),KNGO(NS1),INTYPO(NS1),NBFS(*)
C
      DO 880 K = 1,NS1
         KMINN(K) = KMINO(K)
         KMAXN(K) = KMAXO(K)
         KSTRTN(K) = KSTRTO(K)
         KTYPEN(K) = KTYPEO(K)
         KNGN(K) = KNGO(K)
         INTYPN(K) = INTYPO(K)
         KATOM(K) = NAT
         KLOC(K) = LOC+1
         LOC = LOC+NBFS(INTYPO(K))
  880    CONTINUE
      RETURN
      END
C*MODULE INPUTB  *DECK BASISS
      SUBROUTINE BASISS
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 DIFFS,DIFFSP,EXTFIL,GOPARR,DSKWRK,MASWRK,ZAPSPINACH
C
C        MAXL IS THE MAXIMUM SHELL TYPES GENERATED BELOW.
C        7 = THE SP(D) ATOMIC BASIS + UP TO 1 DIFFUSE SHELL
C          + UP TO 3 1ST LEVEL POLARIZATION FUNCTIONS
C          + UP TO 1 2ND LEVEL POLARIZATION + 1 BLANK CARD
C
      PARAMETER (NNAM=11, MAXA=103, MAXL=7, MAXP=86)
C
      DIMENSION QNAM(NNAM), KQNAM(NNAM)
      DIMENSION SPLIT(3,3),SPLIT2(2),SPLIT3(3)
      DIMENSION POLF1(MAXP), POLF2(MAXP), POLF3(MAXP), POLF4(MAXP),
     *          POLF5(MAXP), POLF6(MAXP), ADIFF(MAXP), SPOL(MAXP)
C
      COMMON /BASISC/ GBASIS,AEX(MAXA,MAXL),ABASIS(MAXA,MAXL),
     *                IAGAUS(MAXA,MAXL),IRDBAS
      COMMON /INTOPT/ ISCHWZ,IECP,NECP,IEFLD
      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)
C
      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 SBK,BASSBK,BASHW /8HSBK     ,8HSBKJC   ,8HHW      /
      DATA BASMIN,BASMID/8HMINI    ,8HMIDI    /
      DATA BASS,BASP/8HS       ,8HP       /
      DATA BASD,BASF/8HD       ,8HF       /
      DATA BASL/8HL       /
      DATA BLANK/8H        /
      DATA ANONE/8HNONE    /
      DATA POPLE,POP311,DUNNNG/8HPOPLE   ,8HPOPN311 ,8HDUNNING /
      DATA HUZNGA,HONDO7,UNDOC/8HHUZINAGA,8HHONDO7  ,8HUNDOC   /
      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
C    ---- STANDARD DIFFUSE EXPONENTS ----
C
      DATA ADIFF /0.0360D+00,0.086D+00,
     *  0.0074D+00,0.0207D+00,
     * 0.0315D+00,0.0438D+00,0.0639D+00,0.0845D+00,0.1076D+00,0.130D+00,
     *  0.0076D+00,0.0146D+00,
     * 0.0318D+00,0.0331D+00,0.0348D+00,0.0405D+00,0.0483D+00,0.060D+00,
     *  2*0.0D+00, 10*0.0D+00,
     *  0.0205D+00,0.0222D+00,0.0287D+00,0.0318D+00,0.0376D+00,0.0D+00,
     *  2*0.0D+00, 10*0.0D+00,
     *  0.0223D+00,0.0231D+00,0.0259D+00,0.0306D+00,0.0368D+00,0.0D+00,
     *  2*0.0D+00, 14*0.0D+00, 10*0.0D+00,
     *  0.0170D+00,0.0171D+00,0.0215D+00,0.0230D+00,0.0294D+00,0.0D+00/
C
C    ---- SECOND LEVEL POLARIZATION (I.E. F FUNCTIONS ON SP ATOMS) ----
C
      DATA SPOL/0.0D+00, 0.0D+00,
     *  0.15D+00,0.26D+00,
     *  0.50D+00,0.80D+00,1.00D+00,1.40D+00,1.85D+00,2.50D+00,
     *  0.15D+00,0.20D+00,
     *  0.25D+00,0.32D+00,0.45D+00,0.55D+00,0.70D+00,0.00D+00,
     *  68*0.0D+00/
C
C    ---- "POPLE" POLARIZATION SET ----
C
      DATA POLF1    /1.100D+00,0.000D+00,
     *   0.200D+00,0.400D+00,
     *   0.600D+00,0.800D+00,0.800D+00,0.800D+00,0.800D+00,0.800D+00,
     *   0.175D+00,0.175D+00,
     *   0.325D+00,0.395D+00,0.550D+00,0.650D+00,0.750D+00,0.850D+00,
     *   0.200D+00,0.200D+00,    10*0.8D+00,
     *   0.207D+00,0.246D+00,0.293D+00,0.338D+00,0.389D+00,0.443D+00,
     *   0.110D+00,0.110D+00,    10*0.0D+00,
     *   0.160D+00,0.183D+00,0.211D+00,0.237D+00,0.266D+00,0.297D+00,
     *   2*0.0D+00, 10*0.0D+00, 14*0.0D+00,
     *   0.146D+00,0.164D+00,0.185D+00,0.204D+00,0.225D+00,0.247D+00/
C
C    ---- "POPN311" POLARIZATION SET ----
C
      DATA POLF2    /0.750D+00,0.750D+00,
     *   0.200D+00,0.255D+00,
     *   0.401D+00,0.626D+00,0.913D+00,1.292D+00,1.750D+00,2.304D+00,
     *   0.175D+00,0.175D+00,
     *   0.325D+00,0.395D+00,0.550D+00,0.650D+00,0.750D+00,0.850D+00,
     *   0.200D+00,0.200D+00,  10*0.0D+00,
     *   0.207D+00,0.246D+00,0.293D+00,0.338D+00,0.389D+00,0.443D+00,
     *   0.110D+00,0.110D+00,  10*0.0D+00,
     *   0.160D+00,0.183D+00,0.211D+00,0.237D+00,0.266D+00,0.297D+00,
     *   2*0.0D+00, 10*0.0D+00, 14*0.0D+00,
     *   0.146D+00,0.164D+00,0.185D+00,0.204D+00,0.225D+00,0.247D+00/
C
C    ---- "DUNNING" POLARIZATION SET ----
C
      DATA POLF3    /1.000D+00,1.000D+00,
     *   0.200D+00,0.400D+00,
     *   0.700D+00,0.750D+00,0.800D+00,0.850D+00,0.900D+00,0.950D+00,
     *   0.175D+00,0.175D+00,
     *   0.325D+00,0.395D+00,0.550D+00,0.650D+00,0.750D+00,0.850D+00,
     *   0.260D+00,0.229D+00,  10*0.0D+00,
     *   0.141D+00,0.202D+00,0.273D+00,0.315D+00,0.338D+00,0.318D+00,
     *   0.110D+00,0.110D+00,  10*0.0D+00,
     *   0.160D+00,0.183D+00,0.211D+00,0.237D+00,0.266D+00,0.297D+00,
     *   2*0.0D+00, 10*0.0D+00, 14*0.0D+00,
     *   0.146D+00,0.164D+00,0.185D+00,0.204D+00,0.225D+00,0.247D+00/
C
C    ---- "HUZINAGA" POLARIZATION SET ----
C
      DATA POLF4    /1.000D+00,1.000D+00,    0.076D+00,0.164D+00,
     *   0.388D+00,0.600D+00,0.864D+00,1.154D+00,1.496D+00,1.888D+00,
     *   0.061D+00,0.101D+00,
     *   0.198D+00,0.262D+00,0.340D+00,0.421D+00,0.514D+00,0.617D+00,
     *   0.039D+00,0.059D+00,
     *   0.059D+00,0.065D+00,0.071D+00,0.077D+00,0.080D+00,0.082D+00,
     *   0.085D+00,0.088D+00,0.090D+00,0.095D+00,
     *   0.207D+00,0.246D+00,0.293D+00,0.338D+00,0.389D+00,0.443D+00,
     *   0.034D+00,0.048D+00,
     *   0.053D+00,0.059D+00,0.065D+00,0.070D+00,0.072D+00,0.074D+00,
     *   0.075D+00,0.077D+00,0.078D+00,0.800D+00,
     *   0.160D+00,0.183D+00,0.211D+00,0.237D+00,0.266D+00,0.297D+00,
     *   0.026D+00,0.037D+00,
     *   0.038D+00,0.039D+00,0.040D+00,0.041D+00,0.042D+00,0.043D+00,
     *   0.042D+00,0.043D+00,0.044D+00,0.045D+00,0.046D+00,0.047D+00,
     *   0.048D+00,0.049D+00,
     *   0.054D+00,0.059D+00,0.065D+00,0.069D+00,0.073D+00,
     *   0.077D+00,0.081D+00,0.086D+00,0.089D+00,0.093D+00,
     *   0.146D+00,0.164D+00,0.185D+00,0.204D+00,0.225D+00,0.247D+00/
C
C    ---- "HONDO7" POLARIZATION SET ----
C
      DATA POLF5    /1.000D+00,1.000D+00,
     *   0.200D+00,0.320D+00,
     *   0.500D+00,0.720D+00,0.980D+00,1.280D+00,1.620D+00,2.050D+00,
     *   0.157D+00,0.234D+00,
     *   0.311D+00,0.388D+00,0.465D+00,0.542D+00,0.619D+00,0.696D+00,
     *   0.200D+00,0.200D+00,  10*0.0D+00,
     *   0.207D+00,0.246D+00,0.293D+00,0.338D+00,0.389D+00,0.443D+00,
     *   0.110D+00,0.110D+00,  10*0.0D+00,
     *   0.160D+00,0.183D+00,0.211D+00,0.237D+00,0.266D+00,0.297D+00,
     *   2*0.0D+00, 10*0.0D+00, 14*0.0D+00,
     *   0.146D+00,0.164D+00,0.185D+00,0.204D+00,0.225D+00,0.247D+00/
C
C    ---- "UNDOC" POLARIZATION SET ----
C
      DATA POLF6    /1.100D+00,0.000D+00,
     *   0.200D+00,0.400D+00,
     *   0.600D+00,0.800D+00,0.800D+00,0.800D+00,0.800D+00,0.800D+00,
     *   0.175D+00,0.175D+00,
     *   0.325D+00,0.395D+00,0.550D+00,0.650D+00,0.750D+00,0.850D+00,
     *   0.200D+00,0.200D+00,    10*0.0D+00,
     *   0.141D+00,0.202D+00,0.273D+00,0.315D+00,0.338D+00,0.318D+00,
     *   0.110D+00,0.110D+00,    10*0.0D+00,
     *   0.160D+00,0.183D+00,0.211D+00,0.237D+00,0.266D+00,0.297D+00,
     *   2*0.0D+00, 10*0.0D+00, 14*0.0D+00,
     *   0.146D+00,0.164D+00,0.185D+00,0.204D+00,0.225D+00,0.247D+00/
C
C     ---- SET UP NAMELIST $BASIS TABLES ----
C
      DATA BASIS/8HBASIS   /
      DATA QNAM/8HGBASIS  ,8HNGAUSS  ,8HNPFUNC  ,8HNDFUNC  ,
     *          8HNFFUNC  ,8HDIFFSP  ,8HDIFFS   ,8HPOLAR   ,
     *          8HSPLIT2  ,8HSPLIT3  ,8HEXTFIL  /
      DATA KQNAM/5,1,1,1, 1,0,0,5, 23,33,0/
C
C     ---- READ THE MOLECULAR BASIS FROM A $BASIS GROUP -----
C
      ZETA = ZERO
      DO 110 J=1,MAXL
         DO 100 I=1,MAXA
            ABASIS(I,J) = BLANK
            IAGAUS(I,J) = 0
            AEX(I,J) = ZERO
  100    CONTINUE
  110 CONTINUE
C
C     ---- INITIALIZE VARIABLES FOR NAMELIST $BASIS ----
C
      GBASIS = BLANK
      IGAUSS = 0
      NPFUNC = 0
      NDFUNC = 0
      NFFUNC = 0
      DIFFSP = .FALSE.
      DIFFS  = .FALSE.
      POLAR  = BLANK
      EXTFIL = .FALSE.
      SPLIT2(1) = 2.00D+00
      SPLIT2(2) = 0.50D+00
      SPLIT3(1) = 4.00D+00
      SPLIT3(2) = 1.00D+00
      SPLIT3(3) = 0.25D+00
C
C     ---- READ NAMELIST $BASIS ----
C
      JRET = 0
      CALL NAMEIO(IR,JRET,BASIS,NNAM,QNAM,KQNAM,
     *            GBASIS,IGAUSS,NPFUNC,NDFUNC,NFFUNC,DIFFSP,DIFFS,
     *            POLAR,SPLIT2,SPLIT3,EXTFIL,
     *            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,9000)
         CALL ABRT
      END IF
C
C     ---- IF $BASIS NOT FOUND, WE MUST READ BASIS IN $DATA ----
C     IRDBAS=0,1,2 MEANS $BASIS, $DATA, OR EXTERNAL FILE RESPECTIVELY
C
      IF(JRET.EQ.1) THEN
         IRDBAS = 1
         RETURN
      END IF
C
C         SOME OF THE MCP BASIS SETS ARE AVAILABLE ONLY ON DISK FILES
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) EXTFIL=.TRUE.
C
      IF(EXTFIL) THEN
         IF(MASWRK) WRITE(IW,9040) GBASIS
         IRDBAS = 2
         RETURN
      END IF
      IRDBAS = 0
C
      IF(GBASIS.EQ.SBK) GBASIS=BASSBK
      IF(IECP.NE.0 .AND. (GBASIS.NE.BASSBK .AND. GBASIS.NE.BASHW)) THEN
         IF(MASWRK) WRITE(IW,9050) GBASIS
         CALL ABRT
      END IF
C
C        SEMI-EMPIRICAL RUNS (WHICH DON'T EVEN USE GAUSSIAN BASIS SETS)
C        DO NOT USE SUPPLEMENTARY FUNCTIONS, SO IGNORE ANY SUCH INPUT.
C        LIKEWISE, POLARIZATION-CONSISTENT AND CORRELATION-CONSISTENT
C        BASIS SETS SHOULD NOT HAVE ANY "SPINACH" ADDED TO -GBASIS-,
C        AS THEY CAREFULLY ADD THEIR OWN RECIPE FOR THIS.
C
      ZAPSPINACH=.FALSE.
      IF(GBASIS.EQ.BASMD3  .OR.  GBASIS.EQ.BASMND  .OR.
     *   GBASIS.EQ.BASAM1  .OR.  GBASIS.EQ.BASPM3) ZAPSPINACH=.TRUE.
      IF(GBASIS.EQ.BASPC0  .OR.  GBASIS.EQ.BASPC1  .OR.
     *   GBASIS.EQ.BASPC2  .OR.  GBASIS.EQ.BASPC3  .OR.
     *   GBASIS.EQ.BASPC4) ZAPSPINACH=.TRUE.
      IF(GBASIS.EQ.BAAPC0  .OR.  GBASIS.EQ.BAAPC1  .OR.
     *   GBASIS.EQ.BAAPC2  .OR.  GBASIS.EQ.BAAPC3  .OR.
     *   GBASIS.EQ.BAAPC4) ZAPSPINACH=.TRUE.
      IF(GBASIS.EQ.BASCCD  .OR.  GBASIS.EQ.BASCCT  .OR.
     *   GBASIS.EQ.BASCCQ  .OR.  GBASIS.EQ.BASCC5  .OR.
     *   GBASIS.EQ.BASCC6) ZAPSPINACH=.TRUE.
      IF(GBASIS.EQ.BASACD  .OR.  GBASIS.EQ.BASACT  .OR.
     *   GBASIS.EQ.BASACQ  .OR.  GBASIS.EQ.BASAC5  .OR.
     *   GBASIS.EQ.BASAC6) ZAPSPINACH=.TRUE.
      IF(GBASIS.EQ.BACCCD  .OR.  GBASIS.EQ.BACCCT  .OR.
     *   GBASIS.EQ.BACCCQ  .OR.  GBASIS.EQ.BACCC5  .OR.
     *   GBASIS.EQ.BACCC6) ZAPSPINACH=.TRUE.
      IF(GBASIS.EQ.BACACD  .OR.  GBASIS.EQ.BACACT  .OR.
     *   GBASIS.EQ.BACACQ  .OR.  GBASIS.EQ.BACAC5  .OR.
     *   GBASIS.EQ.BACAC6) ZAPSPINACH=.TRUE.
      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) ZAPSPINACH=.TRUE.
C
      IF(ZAPSPINACH) THEN
         IGAUSS=0
         NDFUNC=0
         NPFUNC=0
         NFFUNC=0
         DIFFSP=.FALSE.
         DIFFS=.FALSE.
         POLAR=ANONE
      END IF
C
      SPLIT(1,1) = 1.0D+00
      SPLIT(2,1) = SPLIT2(1)
      SPLIT(2,2) = SPLIT2(2)
      SPLIT(3,1) = SPLIT3(1)
      SPLIT(3,2) = SPLIT3(2)
      SPLIT(3,3) = SPLIT3(3)
C
      IF(POLAR.EQ.BLANK) THEN
         IF(GBASIS.EQ.BASMIN) POLAR=HUZNGA
         IF(GBASIS.EQ.BASMID) POLAR=HUZNGA
         IF(GBASIS.EQ.BASSTO) POLAR=POPLE
         IF(GBASIS.EQ.BASN21) POLAR=POPLE
         IF(GBASIS.EQ.BASN31) POLAR=POPLE
         IF(GBASIS.EQ.BAS311) POLAR=POP311
         IF(GBASIS.EQ.BASMC ) POLAR=POP311
         IF(GBASIS.EQ.BASSBK) POLAR=POPLE
         IF(GBASIS.EQ.BASHW ) POLAR=POPLE
         IF(GBASIS.EQ.BASDH ) POLAR=DUNNNG
         IF(GBASIS.EQ.BASBC ) POLAR=DUNNNG
         IF(GBASIS.EQ.BASDZV) POLAR=DUNNNG
         IF(GBASIS.EQ.BASTZV) POLAR=HONDO7
      END IF
      IF(NPFUNC+NDFUNC.EQ.0) POLAR=ANONE
C
      IF(GBASIS.NE.BASSTO  .AND.  GBASIS.NE.BASN21  .AND.
     *   GBASIS.NE.BASN31  .AND.  GBASIS.NE.BAS311) IGAUSS=0
C
      IF (MASWRK) WRITE (IW,9010) GBASIS, IGAUSS, POLAR,
     *                NDFUNC, NFFUNC, DIFFSP,
     *                NPFUNC, DIFFS
      IF((NDFUNC.EQ.2 .OR. NPFUNC.EQ.2) .AND. MASWRK)
     *  WRITE(IW,9020) SPLIT2
      IF((NDFUNC.EQ.3 .OR. NPFUNC.EQ.3) .AND. MASWRK)
     *  WRITE(IW,9030) SPLIT3
C
C     ---- CHECK FOR BOOBOOS ---
C
      IERR=0
      IF(NPFUNC.GT.3  .OR.  NDFUNC.GT.3) THEN
         IF (MASWRK) WRITE(IW,*) 'NDFUNC AND NPFUNC CANNOT EXCEED 3'
         IERR=IERR+1
      END IF
      IF(NFFUNC.GT.1) THEN
         IF (MASWRK) WRITE(IW,*) 'NFFUNC CANNOT EXCEED 1'
         IERR=IERR+1
      END IF
      IF((GBASIS.NE.BASMIN.AND.GBASIS.NE.BASMID)
     *    .AND.  POLAR.EQ.HUZNGA) THEN
         IF (MASWRK) WRITE(IW,*)
     *      'USE HUZINAGA POLARIZATION WITH MINI/MIDI ONLY!'
         IERR=IERR+1
      END IF
      IF(POLAR.NE.POPLE   .AND.  POLAR.NE.POP311  .AND.
     *   POLAR.NE.DUNNNG  .AND.  POLAR.NE.HUZNGA  .AND.
     *   POLAR.NE.HONDO7  .AND.  POLAR.NE.UNDOC   .AND.
     *   POLAR.NE.ANONE) THEN
         IF (MASWRK) WRITE(IW,*)
     *      'UNRECOGNIZED POLARIZATION STRING:',POLAR
         IERR=IERR+1
      END IF
      IF(IERR.GT.0) CALL ABRT
C
C        FIRST, PUT IN THE SP OR SPD ATOMIC BASIS.
C
      DO 120 I = 1,MAXA
         ABASIS(I,1) = GBASIS
         IAGAUS(I,1) = IGAUSS
  120 CONTINUE
      ICOUNT = 2
      IHCNT = 2
C
C        -DH- AND -BC- ARE JUST SYNONYMS FOR -DZV-
C
      IF(GBASIS.EQ.BASBC  .OR.  GBASIS.EQ.BASDH) GBASIS=BASDZV
C
C        USE 6-311G IN CONJUCTION WITH -MC- BASIS SETS.
C
      IF(GBASIS.EQ.BAS311  .OR.  GBASIS.EQ.BASMC) THEN
         DO 200 I=1,10
            ABASIS(I,1) = BAS311
            IAGAUS(I,1) = 6
  200    CONTINUE
         DO 205 I=11,18
            ABASIS(I,1) = BASMC
  205    CONTINUE
      END IF
C
C        USE -BC- IN CONJUCTION WITH 6-31G BASIS SETS.
C
      IF(GBASIS.EQ.BASN31) THEN
         DO 220 I=31,36
            ABASIS(I,1) = BASBC
  220    CONTINUE
      END IF
C
C     ---- ADD POSSIBLE DIFFUSE S SHELL TO H,HE ----
C
      IF(DIFFS) THEN
         DO 300 I=1,2
            ABASIS(I,IHCNT) = BASS
            IAGAUS(I,IHCNT) = 1
               AEX(I,IHCNT) = ADIFF(I)
  300    CONTINUE
         IHCNT = IHCNT+1
      END IF
C
C     ---- ADD POSSIBLE DIFFUSE SP (L) SHELL ON LI-RN ----
C
      IF(DIFFSP) THEN
         DO 310 I=3,MAXP
             ABASIS(I,ICOUNT) = BASL
             IAGAUS(I,ICOUNT) = 1
                AEX(I,ICOUNT) = ADIFF(I)
  310    CONTINUE
         ICOUNT = ICOUNT + 1
      END IF
C
C     ---- ADD POSSIBLE P POLARIZATION FUNCTIONS TO H, HE ----
C
      IF(NPFUNC.GT.0) THEN
         DO 420 I=1,2
            IF(POLAR.EQ.POPLE ) ZETA = POLF1(I)
            IF(POLAR.EQ.POP311) ZETA = POLF2(I)
            IF(POLAR.EQ.DUNNNG) ZETA = POLF3(I)
            IF(POLAR.EQ.HUZNGA) ZETA = POLF4(I)
            IF(POLAR.EQ.HONDO7) ZETA = POLF5(I)
            IF(POLAR.EQ.UNDOC)  ZETA = POLF6(I)
            IHC = IHCNT
            DO 410 IG = 1,NPFUNC
               ABASIS(I,IHC) = BASP
               IAGAUS(I,IHC) = 1
                  AEX(I,IHC) = SPLIT(NPFUNC,IG) * ZETA
               IHC = IHC + 1
  410       CONTINUE
  420    CONTINUE
         IHCNT = IHCNT + NPFUNC
      END IF
C
C     ---- ADD POSSIBLE POLARIZATION FUNCTIONS TO HEAVY ATOMS ----
C
      IF(NDFUNC.GT.0) THEN
         MINZ=3
         IF(GBASIS.EQ.BASN21  .OR.  GBASIS.EQ.BASHW  .OR.
     *      GBASIS.EQ.BASSTO) MINZ=11
         DO 560 I = MINZ,MAXP
            IF(POLAR.EQ.POPLE ) ZETA = POLF1(I)
            IF(POLAR.EQ.POP311) ZETA = POLF2(I)
            IF(POLAR.EQ.DUNNNG) ZETA = POLF3(I)
            IF(POLAR.EQ.HUZNGA) ZETA = POLF4(I)
            IF(POLAR.EQ.HONDO7) ZETA = POLF5(I)
            IF(POLAR.EQ.UNDOC)  ZETA = POLF6(I)
            IC = ICOUNT
            DO 550 IG = 1,NDFUNC
               ABASIS(I,IC) = BASD
               IAGAUS(I,IC) = 1
                  AEX(I,IC) = SPLIT(NDFUNC,IG) * ZETA
C
C     HUZINAGA USES P POLARIZATION FOR ALKALI AND TRANSITION METALS.
C     OTHER BASIS SETS SKIP POLARIZATION ON TRANSITION METALS, EXCEPT
C     FOR 6-31G* FOR WHICH POPLE AND THERESA HAVE DEFINED F EXPONENTS.
C
               IF(POLAR.EQ.HUZNGA) THEN
                  IF(I.GE. 3 .AND. I.LE. 4) ABASIS(I,IC) = BASP
                  IF(I.GE.11 .AND. I.LE.12) ABASIS(I,IC) = BASP
                  IF(I.GE.19 .AND. I.LE.30) ABASIS(I,IC) = BASP
                  IF(I.GE.37 .AND. I.LE.48) ABASIS(I,IC) = BASP
                  IF(I.GE.55 .AND. I.LE.80) ABASIS(I,IC) = BASP
               ELSE
                  IF(I.GE.21 .AND. I.LE.30) THEN
                      ABASIS(I,IC) = BLANK
                      IF(GBASIS.EQ.BASN31) ABASIS(I,IC) = BASF
                  END IF
                  IF(I.GE.39 .AND. I.LE.48) ABASIS(I,IC) = BLANK
                  IF(I.GE.57 .AND. I.LE.80) ABASIS(I,IC) = BLANK
               END IF
               IC = IC + 1
  550       CONTINUE
  560    CONTINUE
         ICOUNT = ICOUNT + NDFUNC
      END IF
C
C           NOTE THAT ICOUNT IS NOW MESSED UP BETWEEN LIGHT ATOMS,
C           TRANSITION METALS, AND MAIN GROUP, BUT WE DON'T CARE.
C           THE VALUE IS CORRECT FOR MAIN GROUP ATOMS, WHICH ARE
C           THE ONLY TYPE OF ATOM FOR WHICH WE WILL ADD A F FUNCTION.
C
C     ---- ADD POSSIBLE F POLARIZATION FUNCTIONS TO LI-CL ----
C
      IF(NFFUNC.EQ.1) THEN
         IF(GBASIS.EQ.BASN21  .OR.  GBASIS.EQ.BASHW  .OR.
     *      GBASIS.EQ.BASSTO) THEN
            IF(MASWRK) WRITE(IW,*) 'DO NOT USE F WITH SMALL SP BASES'
            CALL ABRT
         END IF
         DO 620 I = 3,17
            ZETA = SPOL(I)
            ABASIS(I,ICOUNT) = BASF
            IAGAUS(I,ICOUNT) = 1
               AEX(I,ICOUNT) = ZETA
  620    CONTINUE
         ICOUNT = ICOUNT + 1
      END IF
C
      RETURN
C
 9000 FORMAT(1X,'SYNTAX ERROR FOUND IN YOUR $BASIS GROUP')
 9010 FORMAT(/5X,13HBASIS OPTIONS/5X,13(1H-)/
     *  5X,7HGBASIS=,A8,5X,7HIGAUSS=,I8,5X,7H POLAR=,A8/
     *  5X,7HNDFUNC=,I8,5X,7HNFFUNC=,I8,5X,7HDIFFSP=,L8/
     *  5X,7HNPFUNC=,I8,5X,7H DIFFS=,L8)
 9020 FORMAT(5X,'SPLIT2=',2F15.8)
 9030 FORMAT(5X,'SPLIT3=',3F15.8)
 9040 FORMAT(/5X,'$BASIS REQUESTS READING THE "',A8,
     *          '" BASIS SET FROM AN EXTERNAL FILE')
 9050 FORMAT(/1X,'*** ERROR ***'/
     *      1X,'THIS RUN REQUESTED THE USE OF AN ECP IN $CONTRL,'/
     *      1X,'BUT IT REQUESTS A NON-ECP BASIS SET=',A8,'IN $BASIS.'//)
      END
C*MODULE INPUTB  *DECK BERROR
      SUBROUTINE BERROR(K)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      DIMENSION BASIS(4)
C
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      DATA BASIS /8HMINIMAL ,8HEXTENDED,8HGENERAL ,8H        /
C
C        *****  ROUTINE TO KICK YOU  OFF FOR AN IMPROPER *****
C        *****  BASIS-FUNCTION SPECIFICATION             *****
C
      IF (MASWRK) THEN
         WRITE (IW,9008)
         WRITE (IW,9028) BASIS(K)
      END IF
      CALL ABRT
      RETURN
C
 9008 FORMAT(1X,'   LUCY: DO NOT WORRY, CHARLIE BROWN, WE LEARN MORE'/
     *       1X,'         FROM LOSING THAN WE DO FROM WINNING.'/
     *       1X,'CHARLIE: THEN THAT MAKES ME THE SMARTEST PERSON IN'/
     *       1X,'         THE WORLD!')
 9028 FORMAT(/10X,'ILLEGAL ',A8,' BASIS FUNCTION REQUESTED.')
      END
C*MODULE INPUTB *DECK GTDIST
      SUBROUTINE GTDIST(ATOMN1,ATOMN2,RDIST)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION RCOV(86)
C
C      COVALENT RADII FROM J.EMSLEY, "THE ELEMENTS", 2ND EDITION, 1991
C      EXCEPT VAN DER WAALS RADII FOR HE,NE,AR,KR (SAME SOURCE),
C      AND GUESSES FOR NA,V,CR,RB,TC,PM,EU,YB,AT,RN
C
      DATA (RCOV(NUCZ),NUCZ=1,2)/0.30D+00,1.22D+00/
      DATA (RCOV(NUCZ),NUCZ=3,10)
     *  /1.23D+00,0.89D+00,0.88D+00,0.77D+00,
     *   0.70D+00,0.66D+00,0.58D+00,1.60D+00/
      DATA (RCOV(NUCZ),NUCZ=11,18)
     *  /1.66D+00,1.36D+00,1.25D+00,1.17D+00,
     *   1.10D+00,1.04D+00,0.99D+00,1.91D+00/
      DATA (RCOV(NUCZ),NUCZ=19,36)
     *  /2.03D+00,1.74D+00,
     *   1.44D+00,1.32D+00,1.22D+00,1.19D+00,1.17D+00,
     *   1.165D+00,1.16D+00,1.15D+00,1.17D+00,1.25D+00,
     *   1.25D+00,1.22D+00,1.21D+00,1.17D+00,1.14D+00,1.98D+00/
      DATA (RCOV(NUCZ),NUCZ=37,54)
     *  /2.22D+00,1.92D+00,
     *   1.62D+00,1.45D+00,1.34D+00,1.29D+00,1.27D+00,
     *   1.24D+00,1.25D+00,1.28D+00,1.34D+00,1.41D+00,
     *   1.50D+00,1.40D+00,1.41D+00,1.37D+00,1.33D+00,2.09D+00/
      DATA (RCOV(NUCZ),NUCZ=55,86)
     *  /2.35D+00,1.98D+00,
     *   1.69D+00,1.65D+00,1.65D+00,1.64D+00,1.65D+00,1.66D+00,1.65D+00,
     *   1.61D+00,1.59D+00,1.59D+00,1.58D+00,1.57D+00,1.56D+00,1.56D+00,
     *   1.56D+00,1.44D+00,1.34D+00,1.30D+00,1.28D+00,
     *   1.26D+00,1.26D+00,1.29D+00,1.34D+00,1.44D+00,
     *   1.55D+00,1.54D+00,1.52D+00,1.53D+00,1.50D+00,2.20D+00/
C
      RDIST=RCOV(INT(ATOMN1))+RCOV(INT(ATOMN2))
      END
C*MODULE INPUTB  *DECK MOLE
      SUBROUTINE MOLE(DECKNAME,IUNTRD,ICOORD,RELNORM)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK,RELNORM
C
      CHARACTER*8 DECKNAME
      CHARACTER*4 CDUMMY
C
      PARAMETER (MXATM=2000, MXGSH=30, MXGTOT=20000, MXAO=8192)
      PARAMETER (MAXA=103, MAXL=7)
      PARAMETER (MXCHRM=1)
C
      COMMON /BASISC/ GBASIS,AEX(MAXA,MAXL),ABASIS(MAXA,MAXL),
     *                IAGAUS(MAXA,MAXL),IRDBAS
      COMMON /CHMGMS/ XCHM(MXCHRM),YCHM(MXCHRM),ZCHM(MXCHRM),
     *                DXELMM(MXCHRM),DYELMM(MXCHRM),DZELMM(MXCHRM),
     *                QCHM(MXCHRM),NCHMAT,KCHRMM
      COMMON /FMCOM / X(1)
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /RELWFN/ RMETHOD,QRQMT,CLIG,CLIG2,QRTOL,IQRORD,MODQR,NESOC,
     *                NRATOM,NUMU,NQMTR,NQRDAF,MORDA,NDARELB
      COMMON /RUNLAB/ TITLE(10),ANAM(MXATM),BNAM(MXATM),BFLAB(MXAO)
      COMMON /FMOINF/ NFG,NLAYER,NATFMO,NBDFG,NAOTYP,NBODY
C
      DATA ANONE/8HNONE    /
C
      IF (ICOORD.EQ.5) GO TO 200
C
      IF(DECKNAME.EQ.' $DATAL '  .AND.  MASWRK)
     *      WRITE(IW,9025) DECKNAME,'LARGE'
      IF(DECKNAME.EQ.' $DATAS '  .AND.  MASWRK)
     *      WRITE(IW,9025) DECKNAME,'SMALL'
C
C     ----- POSITION THE INPUT FILE TO $DATA -----
C
      CALL SEQREW(IR)
      CALL FNDGRP(IR,DECKNAME,IEOF)
      IF(IEOF.NE.0) THEN
         IF(MASWRK) WRITE (IW,9028) DECKNAME
         CALL ABRT
      END IF
C
C     OPEN THE FREE FORMAT INPUT SCANNER.
C     READ TITLE CARD.
C
      IF(KCHRMM.EQ.0) THEN
         CALL OPNCRD(IR,-IW)
         IF (MASWRK) THEN
            READ (IR,9088) TITLE
            WRITE(IW,9048) TITLE
            WRITE(IP,9008) DECKNAME
            WRITE(IP,9088) TITLE
         END IF
      END IF
 200  CONTINUE
C
C        READ SYMMETRY POINT GROUP OF THE MOLECULE,
C        AND GENERATE THE TRANSFORMATION MATRICES.
C
      CALL PTGRP
C
C        FOR COORD=CART,ZMT,ZMTMPC, WE MUST FIRST READ THE
C        FULL MOLECULE, AND DISCARD DOWN TO THE UNIQUE ATOMS.
C
      IF((IRDBAS.EQ.0  .OR. IRDBAS.EQ.2)  .AND.
     *   (ICOORD.GE.1 .AND. ICOORD.LE.3)) CALL MBLDR(IUNTRD)
C
C        FOR COORD=TINKER, WE MUST FIRST READ THE FULL SYSTEM
C        IN TINXYZ CARD, AND GENERATE QM PART OF COORDINATES
C        ACCORDING TO LINK CARD INFORMATION.
C
      IF((IRDBAS.EQ.0  .OR. IRDBAS.EQ.2) .AND.
     *   (ICOORD.EQ.5).AND.NFG.EQ.0) CALL TIN2GMS
C
C        READ THE COORDINATES OF THE UNIQUE CENTERS, IN ORDER TO
C        GENERATE THE FULL MOLECULE AND THE BASIS SET.
C
      CALL VALFM(LOADFM)
      LS   = LOADFM + 1
      LP   = LS + MXGTOT
      LD   = LP + MXGTOT
      LF   = LD + MXGTOT
      LG   = LF + MXGTOT
      LH   = LG + MXGTOT
      LI   = LH + MXGTOT
      LMELD= LI + MXGTOT
      LAST = LMELD + MXGSH*5*MXATM
      NEED = LAST - LOADFM - 1
      CALL GETFM(NEED)
      CALL ATOMS(IUNTRD,X(LS),X(LP),X(LD),X(LF),X(LG),X(LH),X(LI),
     *           X(LMELD),MXGSH,MXATM,MXGTOT,ICOORD,RELNORM)
      CALL RETFM(NEED)
C
      CALL SETLAB(1,CDUMMY)
C
C     ----- WRITE ATOMIC COOORDINATES IN THE FIRST RECORD OF DAF -----
C
      CALL DAWRIT(IDAF,IODA,C,3*NAT,1,0)
      NUMU=NUM
      IF(RMETHOD.NE.ANONE) CALL RWFINP
      RETURN
C
 9008 FORMAT(A8)
 9025 FORMAT(/1X,'READING',A8,'GROUP FOR ',A5,' COMPONENT BASIS SET...')
 9028 FORMAT(1X,'**** ERROR, NO ',A8,' GROUP WAS FOUND')
 9048 FORMAT(//5X,'RUN TITLE'/5X,9(1H-)/1X,10A8)
 9088 FORMAT(10A8)
      END
C*MODULE INPUTB  *DECK PRINT
      SUBROUTINE PRINT(N1,N2)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      PARAMETER (MXSH=5000, MXATM=2000)
C
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /SYMTRY/ MAPSHL(MXSH,48),MAPCTR(MXATM,48),
     *                T(9,48),INVT(48),NT
C
      IF (MASWRK) THEN
      DO 160 IMIN = N1,N2,4
         IMAX = MIN(IMIN+1, N2)
         DO 140 J = 1,9,3
            WRITE (IW,9008) (T(J,I),T(J+1,I),T(J+2,I), I = IMIN,IMAX)
  140    CONTINUE
         WRITE (IW,9028)
  160 CONTINUE
      END IF
      RETURN
C
 9008 FORMAT(4X,4(3F10.5,2H *))
 9028 FORMAT(/)
      END
C*MODULE INPUTB  *DECK PTGRP
      SUBROUTINE PTGRP
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK,ABEL
C
      DIMENSION GRP(19),DRC(2)
C
      CHARACTER*5 GROUPC,GRP2(19)
      CHARACTER*8 DRC2(2),DIRCT2
C
      PARAMETER (MXSH=5000, MXATM=2000)
      PARAMETER (MXCHRM=1)
C
      COMMON /CHMGMS/ XCHM(MXCHRM),YCHM(MXCHRM),ZCHM(MXCHRM),
     *                DXELMM(MXCHRM),DYELMM(MXCHRM),DZELMM(MXCHRM),
     *                QCHM(MXCHRM),NCHMAT,KCHRMM
      COMMON /FRAME / U1,U2,U3,V1,V2,V3,W1,W2,W3,X0,Y0,Z0
      COMMON /FRAMES/ X1,Y1,Z1,X2,Y2,Z2,X3,Y3,Z3,DIRECT
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /SYMMOL/ GROUP,COMPLEX,IGROUP,NAXIS,ILABMO,ABEL
      COMMON /SYMTRY/ MAPSHL(MXSH,48),MAPCTR(MXATM,48),
     *                T(9,48),INVT(48),NT
      COMMON /ZMTALT/ NZMAT2,NZVAR2,NVAR2,NZMTRD,ICOORD
      LOGICAL MMONLY, QMMM
      COMMON /TINOPT/ MMONLY,QMMM
C
      PARAMETER (ZERO=0.0D+00, HALF=0.5D+00, ONE=1.0D+00, TWO=2.0D+00)
      PARAMETER (TOL=1.0D-10)
C
      DATA GRP2/'C1   ','CS   ','CI   ','CN   ','S2N  ','CNH  ',
     +          'CNV  ','DN   ','DNH  ','DND  ','CINFV','DINFH','T    ',
     +          'TH   ','TD   ','O    ','OH   ','I    ','IH   '/
C
      DATA GRP /5HC1   ,5HCS   ,5HCI   ,5HCN   ,5HS2N  ,5HCNH  ,
     +          5HCNV  ,5HDN   ,5HDNH  ,5HDND  ,5HCINFV,5HDINFH,5HT    ,
     +          5HTH   ,5HTD   ,5HO    ,5HOH   ,5HI    ,5HIH   /
      DATA BLANK/8H        /
      DATA DRC /8HNORMAL  ,8HPARALLEL/
      DATA DRC2/'NORMAL  ','PARALLEL'/
C
      PI2 = TWO * ACOS(-ONE)
      ALPH = ZERO
      N2 = -2**20
C
C     ---- READ THE POINT GROUP -----
C
      IF (QMMM .AND. (ICOORD.EQ.5)) THEN
         GROUPC = 'C1   '
      ELSE
       IF(KCHRMM.EQ.0) THEN
         IERR=0
         IEOF=0
         CALL RDCARD('$DATA 2 ',IEOF)
         IF(IEOF.EQ.1) THEN
            IF(MASWRK) WRITE(IW,*) 'TROUBLE FINDING POINT GROUP CARD'
            CALL ABRT
         END IF
         GROUPC = '     '
         NAXIS = 0
         KSIZE = -5
         CALL GSTRNG(GROUPC,KSIZE)
         NAXIS = IFIND('NAXIS   ',IERR)
         IF(IERR.NE.0) THEN
            IF(MASWRK) WRITE(IW,*) 'TROUBLE READING ROTATION AXIS'
            CALL ABRT
         END IF
       ELSE
         GROUPC = 'C1   '
         NAXIS=1
       END IF
      END IF
C
      IGROUP = 0
      DO 90 I = 1,19
        IF(GROUPC.EQ.GRP2(I)) IGROUP = I
   90 CONTINUE
      IF(IGROUP.LE.0) THEN
         IF (MASWRK) WRITE(IW,9108) GROUPC
         CALL ABRT
      END IF
      GROUP = GRP(IGROUP)
C
C        GROUPS I AND IH DON'T EXIST, REALLY.
C
      IF (IGROUP .EQ. 18 .OR. IGROUP .EQ. 19) THEN
         IF (MASWRK) WRITE (IW,9008) GROUPC
         CALL ABRT
      END IF
C
      IF(MASWRK) THEN
         WRITE(IW,9128) GROUP,NAXIS
         WRITE(IP,9008) GROUP,NAXIS
      END IF
C
      IF (IGROUP .LE. 3) GO TO 580
      IF (IGROUP .EQ. 11 .OR. IGROUP .EQ. 12) GO TO 580
C
C     DEFINE LOCAL FRAME
C     READ IN PRINCIPAL AXIS   ( 1 CARD )
C     READ IN X-LOCAL AXIS   ( 1 CARD )
C     DEFAULT OPTION - LOCAL FRAME IDENTICAL TO MASTER FRAME
C           READ X0,Y0,Z0,X1,Y1,Z1
C
      IEOF = 0
      IERR = 0
      CALL RDCARD('$DATA 3 ',IEOF)
      X0 = RFIND('X0      ',IERR)
         IF(IERR.NE.0) CALL ABRT
      Y0 = RFIND('Y0      ',IERR)
         IF(IERR.NE.0) CALL ABRT
      Z0 = RFIND('Z0      ',IERR)
         IF(IERR.NE.0) CALL ABRT
      X1 = RFIND('X1      ',IERR)
         IF(IERR.NE.0) CALL ABRT
      Y1 = RFIND('Y1      ',IERR)
         IF(IERR.NE.0) CALL ABRT
      Z1 = RFIND('Z1      ',IERR)
         IF(IERR.NE.0) CALL ABRT
      RHO = SQRT((X1-X0)**2+(Y1-Y0)**2+(Z1-Z0)**2)
      IF (RHO .GT. TOL) THEN
         IF (MASWRK) WRITE (IP,9048) X0,Y0,Z0,X1,Y1,Z1
C                  READ (IR,*) X2,Y2,Z2,DIRECT
         IEOF = 0
         IERR = 0
         CALL RDCARD('$DATA 4 ',IEOF)
         X2 = RFIND('X2      ',IERR)
              IF(IERR.NE.0) CALL ABRT
         Y2 = RFIND('Y2      ',IERR)
              IF(IERR.NE.0) CALL ABRT
         Z2 = RFIND('Z2      ',IERR)
              IF(IERR.NE.0) CALL ABRT
         DIRCT2='        '
         KSIZE = -8
         CALL GSTRNG(DIRCT2,KSIZE)
         DIRECT = BLANK
         IF(DIRCT2.EQ.DRC2(1)) DIRECT = DRC(1)
         IF(DIRCT2.EQ.DRC2(2)) DIRECT = DRC(2)
         IF (MASWRK) WRITE (IP,9068) X2,Y2,Z2,DIRECT
      ELSE
         IF (MASWRK) WRITE (IP,9068)
         X0 = ZERO
         Y0 = ZERO
         Z0 = ZERO
         X1 = ZERO
         Y1 = ZERO
         Z1 = ONE
         X2 = ONE
         Y2 = ZERO
         Z2 = ZERO
         DIRECT = DRC(2)
         RHO = ONE
      END IF
C
      IF (DIRECT .NE. DRC(1)) DIRECT = DRC(2)
      W1 = (X1-X0)/RHO
      W2 = (Y1-Y0)/RHO
      W3 = (Z1-Z0)/RHO
      WW = W1*W1+W2*W2+W3*W3
      X02 = X2-X0
      Y02 = Y2-Y0
      Z02 = Z2-Z0
      RHO = (W1*X02+W2*Y02+W3*Z02)/WW
      DUM = RHO*W1
      X0 = X0+DUM
      X02 = X02-DUM
      DUM = RHO*W2
      Y0 = Y0+DUM
      Y02 = Y02-DUM
      DUM = RHO*W3
      Z0 = Z0+DUM
      Z02 = Z02-DUM
      UU = (X02*X02+Y02*Y02+Z02*Z02)
      U = SQRT(UU)
      U1 = X02/U
      U2 = Y02/U
      U3 = Z02/U
      V3 = W1*U2-W2*U1
      V2 = W3*U1-W1*U3
      V1 = W2*U3-W3*U2
      IF (DIRECT .EQ. DRC(2)) GO TO 200
         DUM = U1
         U1 = V1
         V1 = -DUM
         DUM = U2
         U2 = V2
         V2 = -DUM
         DUM = U3
         U3 = V3
         V3 = -DUM
  200 CONTINUE
      IF ((NPRINT .EQ. 1) .AND. MASWRK)
     *    WRITE (IW,9148) X0,Y0,Z0,U1,V1,W1,U2,V2,W2,U3,V3,W3
      IF (IGROUP .GE. 13) GO TO 580
C
C     ROTATION ABOUT PRINCIPAL AXIS
C
      N = NAXIS
      ALPHA = ZERO
      ALPH = PI2 / N
      DO 240 NN = 1,N
         COSA = COS(ALPHA)
         SINA = SIN(ALPHA)
         T(1,NN) = COSA
         T(5,NN) = COSA
         T(2,NN) = -SINA
         T(4,NN) = SINA
         T(3,NN) = ZERO
         T(6,NN) = ZERO
         T(7,NN) = ZERO
         T(8,NN) = ZERO
         T(9,NN) = ONE
         ALPHA = ALPHA+ALPH
  240 CONTINUE
C
C     END OF GROUP 4
C
      NT = N
      IF (NPRINT .NE. 1) GO TO 280
      IF (MASWRK) WRITE (IW,9168)
      N1 = 1
      N2 = NAXIS
      CALL PRINT(N1,N2)
  280 CONTINUE
      IF (IGROUP .EQ. 4) GO TO 980
      IF (IGROUP .EQ. 5) GO TO 720
      IF (IGROUP .EQ. 7) GO TO 520
      IF (IGROUP .NE. 6 .AND. IGROUP .NE. 9) GO TO 380
C
C     SIGMA-H PLANE  EQUATION (Z=0) IN LOCAL FRAME
C
C
C        GROUP 6 0R 9
C
      CALL DCOPY(9*NT,T,1,T(1,NT+1),1)
      DO 340 NN = NT+1,NT+NT
         T(9,NN) = -T(9,NN)
  340 CONTINUE
      NT = NT+NT
      IF (NPRINT .NE. 1) GO TO 360
         IF (MASWRK) WRITE (IW,9188)
         N1 = N2+1
         N2 = N2+NAXIS
         CALL PRINT(N1,N2)
  360 CONTINUE
C
C     END OF GROUP 6
C
      IF (IGROUP .EQ. 6) GO TO 980
C
C     ONE CP2 AXIS IS THE X-AXIS OF THE LOCAL FRAME
C     GROUP 8 , 9 ,10
C
  380 CONTINUE
      CALL DCOPY(9*NT,T,1,T(1,NT+1),1)
      DO 420 NN = NT+1,NT+NT
         T(2,NN) = -T(2,NN)
         T(3,NN) = -T(3,NN)
         T(5,NN) = -T(5,NN)
         T(6,NN) = -T(6,NN)
         T(8,NN) = -T(8,NN)
         T(9,NN) = -T(9,NN)
  420 CONTINUE
      NT = NT+NT
      IF (NPRINT .NE. 1) GO TO 440
         IF (MASWRK) WRITE (IW,9208)
         N1 = N2+1
         N2 = N2+NAXIS
         CALL PRINT(N1,N2)
         IF (IGROUP .NE. 9) GO TO 440
            IF (MASWRK) WRITE (IW,9328)
            N1 = N2+1
            N2 = N2+NAXIS
            CALL PRINT(N1,N2)
  440 CONTINUE
C
C     END OF GROUP 8 AND 9
C
      IF (IGROUP .EQ. 8 .OR. IGROUP .EQ. 9) GO TO 980
C
C     DND GROUP . EQUATION OF PLANE SIGMA-D IS _
C     SIN(ALPH/4)*X-COS(ALPH/4)*Y=0
C     THE X-AXIS IS THE CP2 AXIS.
C
C     GROUP 10
C
      BETA = HALF*ALPH
      COSB = COS(BETA)
      SINB = SIN(BETA)
      CALL DCOPY(9*NT,T,1,T(1,NT+1),1)
      DO 480 NN = 1,9,3
         CALL DROT(NT,T(NN,NT+1),9,T(NN+1,NT+1),9,COSB,SINB)
  480 CONTINUE
      DO 490 NN = NT+1,NT+NT
         T(2,NN) = -T(2,NN)
         T(5,NN) = -T(5,NN)
         T(8,NN) = -T(8,NN)
  490 CONTINUE
      NT = NT+NT
      IF (NPRINT .NE. 1) GO TO 500
         IF (MASWRK) WRITE (IW,9228)
         N1 = N2+1
         N2 = N2+NAXIS
         CALL PRINT(N1,N2)
         IF (MASWRK) WRITE (IW,9348)
         N1 = N2+1
         N2 = N2+NAXIS
         CALL PRINT(N1,N2)
  500 CONTINUE
C
C     END OF GROUP 10
C
      GO TO 980
C
C     GROUP 7
C     SIGMA-V IS THE (X-Z) PLANE OF LOCAL FRAME
C
  520 CONTINUE
      CALL DCOPY(9*NT,T,1,T(1,NT+1),1)
      DO 560 NN = NT+1,NT+NT
         T(2,NN) = -T(2,NN)
         T(5,NN) = -T(5,NN)
         T(8,NN) = -T(8,NN)
  560 CONTINUE
      NT = NT+NT
C
C     END OF GROUP 7
C
      IF (NPRINT .NE. 1) GO TO 980
         IF (MASWRK) WRITE (IW,9248)
         N1 = N2+1
         N2 = N2+NAXIS
         CALL PRINT(N1,N2)
         GO TO 980
C
  580 CONTINUE
      T(1,1) = ONE
      T(5,1) = ONE
      T(9,1) = ONE
      T(2,1) = ZERO
      T(3,1) = ZERO
      T(4,1) = ZERO
      T(6,1) = ZERO
      T(7,1) = ZERO
      T(8,1) = ZERO
C
      IF (IGROUP .EQ. 1) GO TO 600
      IF (IGROUP .EQ. 2) GO TO 620
      IF (IGROUP .EQ. 3) GO TO 680
      IF (IGROUP .EQ. 11 .OR. IGROUP .EQ. 12) GO TO 700
      GO TO 780
C
  600 NT = 1
      X0 = ZERO
      Y0 = ZERO
      Z0 = ZERO
      U1 = ONE
      V2 = ONE
      W3 = ONE
      U2 = ZERO
      U3 = ZERO
      V1 = ZERO
      V3 = ZERO
      W1 = ZERO
      W2 = ZERO
      GO TO 980
C
C     CS SYMMETRY GROUP
C     THE 3 POINTS 1,2,3 DEFINE SIGMA-H PLANE
C
C            READ (IR,*) X1,Y1,Z1,X2,Y2,Z2
  620 CONTINUE
      IEOF = 0
      IERR = 0
      CALL RDCARD('$DATA 3 ',IEOF)
      X1 = RFIND('X1      ',IERR)
         IF(IERR.NE.0) CALL ABRT
      Y1 = RFIND('Y1      ',IERR)
         IF(IERR.NE.0) CALL ABRT
      Z1 = RFIND('Z1      ',IERR)
         IF(IERR.NE.0) CALL ABRT
      X2 = RFIND('X2      ',IERR)
         IF(IERR.NE.0) CALL ABRT
      Y2 = RFIND('Y2      ',IERR)
         IF(IERR.NE.0) CALL ABRT
      Z2 = RFIND('Z2      ',IERR)
         IF(IERR.NE.0) CALL ABRT
      RHO = (X2-X1)**2+(Y2-Y1)**2+(Z2-Z1)**2
      IF (RHO .GT. TOL) THEN
         IF (MASWRK) WRITE (IP,9048) X1,Y1,Z1,X2,Y2,Z2
C                 READ (IR,*) X3,Y3,Z3
         IERR = 0
         IEOF = 0
         CALL RDCARD('$DATA 4 ',IEOF)
         X3 = RFIND('X3      ',IERR)
            IF(IERR.NE.0) CALL ABRT
         Y3 = RFIND('Y3      ',IERR)
            IF(IERR.NE.0) CALL ABRT
         Z3 = RFIND('Z3      ',IERR)
            IF(IERR.NE.0) CALL ABRT
         IF (MASWRK) WRITE (IP,9048) X3,Y3,Z3
      ELSE
C            DEFAULT OPTION - PLANE IS THE (X,Y) PLANE
         IF (MASWRK) WRITE(IP,9048)
         X1 = ZERO
         Y1 = ZERO
         Z1 = ZERO
         Y2 = ZERO
         Z2 = ZERO
         X3 = ZERO
         Z3 = ZERO
         X2 = ONE
         Y3 = ONE
      END IF
C
      NT = 2
      W1 = (Y2-Y1)*(Z3-Z1)-(Y3-Y1)*(Z2-Z1)
      W2 = (Z2-Z1)*(X3-X1)-(Z3-Z1)*(X2-X1)
      W3 = (X2-X1)*(Y3-Y1)-(X3-X1)*(Y2-Y1)
      RHO = SQRT(W1*W1+W2*W2+W3*W3)
      W1 = W1/RHO
      W2 = W2/RHO
      W3 = W3/RHO
      U1 = X2-X1
      U2 = Y2-Y1
      U3 = Z2-Z1
      RHO = SQRT(U1*U1+U2*U2+U3*U3)
      U1 = U1/RHO
      U2 = U2/RHO
      U3 = U3/RHO
      V1 = W2*U3-W3*U2
      V2 = W3*U1-W1*U3
      V3 = W1*U2-W2*U1
      X0 = X1
      Y0 = Y1
      Z0 = Z1
      T(1,2) =  ONE
      T(5,2) =  ONE
      T(9,2) = -ONE
      T(2,2) = ZERO
      T(3,2) = ZERO
      T(4,2) = ZERO
      T(6,2) = ZERO
      T(7,2) = ZERO
      T(8,2) = ZERO
C
      IF (NPRINT .NE. 1) GO TO 980
         IF (MASWRK) THEN
            WRITE (IW,9288) W1,W2,W3
            WRITE (IW,9308) U1,V1,W1,U2,V2,W2,U3,V3,W3
         END IF
         GO TO 980
C
C     CI SYMMETRY GROUP
C     CENTER OF INVERSION IS (X0,Y0,Z0)
C
C            READ (IR,*) X0,Y0,Z0
  680 CONTINUE
      IEOF = 0
      IERR = 0
      CALL RDCARD('$DATA 3 ',IEOF)
      X0 = RFIND('X0      ',IERR)
         IF(IERR.NE.0) CALL ABRT
      Y0 = RFIND('Y0      ',IERR)
         IF(IERR.NE.0) CALL ABRT
      Z0 = RFIND('Z0      ',IERR)
         IF(IERR.NE.0) CALL ABRT
      IF ((NPRINT .EQ. 3) .AND. MASWRK) WRITE (IW,9268) X0,Y0,Z0
      T(1,2) = -ONE
      T(5,2) = -ONE
      T(9,2) = -ONE
      T(2,2) = ZERO
      T(3,2) = ZERO
      T(4,2) = ZERO
      T(6,2) = ZERO
      T(7,2) = ZERO
      T(8,2) = ZERO
      NT = 2
      U1 = ONE
      V2 = ONE
      W3 = ONE
      U2 = ZERO
      U3 = ZERO
      V1 = ZERO
      V3 = ZERO
      W1 = ZERO
      W2 = ZERO
      GO TO 980
C
  700 IF (MASWRK) WRITE (IW,9088)
      CALL ABRT
C
  720 CONTINUE
      BETA = HALF*ALPH
      COSB = COS(BETA)
      SINB = SIN(BETA)
C
C     S2N GROUP
C     THE PLANE OF SYMMETRY FOR THE IMPROPER ROTATION
C     IS THE (X,Y) PLANE OF THE LOCAL FRAME
C
      CALL DCOPY(9*NT,T,1,T(1,NT+1),1)
      DO 750 NN = NT+1,NT+NT
         T(3,NN) = -T(3,NN)
         T(6,NN) = -T(6,NN)
         T(9,NN) = -T(9,NN)
  750 CONTINUE
      DO 760 NN = 1,9,3
         CALL DROT(NT,T(NN,NT+1),9,T(NN+1,NT+1),9,COSB,SINB)
  760 CONTINUE
      NT = NT+NT
      IF (NPRINT .NE. 1) GO TO 980
         IF (MASWRK) WRITE (IW,9368)
         N1 = N2+1
         N2 = N2+NAXIS
         CALL PRINT(N1,N2)
         GO TO 980
C
C     T GROUP AND OTHERS CONTAINING A SUBGROUP T _
C     LOCAL X,Y,Z ARE THE C2 AXES
C
  780 CONTINUE
      CALL VCLR(T(1,2),1,27)
      T(1,2) =  ONE
      T(5,3) =  ONE
      T(9,4) =  ONE
      T(5,2) = -ONE
      T(9,2) = -ONE
      T(1,3) = -ONE
      T(9,3) = -ONE
      T(1,4) = -ONE
      T(5,4) = -ONE
      DO 820 I = 5,12
      T(1,I) = T(7,I-4)
      T(2,I) = T(8,I-4)
      T(3,I) = T(9,I-4)
      T(4,I) = T(1,I-4)
      T(5,I) = T(2,I-4)
      T(6,I) = T(3,I-4)
      T(7,I) = T(4,I-4)
      T(8,I) = T(5,I-4)
      T(9,I) = T(6,I-4)
  820 CONTINUE
      NT = 12
      IF (IGROUP .EQ. 13) GO TO 980
      IF (IGROUP .EQ. 14) GO TO 840
      IF (IGROUP .EQ. 15) GO TO 900
      GO TO 880
C
C     TH GROUP
C     EXPAND GROUP BY TAKING DIRECT PRODUCT WITH CI
C
  840 CONTINUE
      CALL DCOPY(9*NT,T,1,T(1,NT+1),1)
      DO 860 J = NT+1,NT+NT
         DO 850 I = 1,9
            T(I,J) = -T(I,J)
  850    CONTINUE
  860 CONTINUE
      NT = NT+NT
      GO TO 980
C
C     OCTAHEDRAL GROUP IS DIRECT PRODUCT OF T AND A C4 ROTATION
C     ABOUT Z AXIS
C
  880 SIGN = -ONE
      GO TO 920
C
C     TD GROUP IS DIRECT PRODUCT OF T AND A REFLECTION IN A
C     PLANE ( EQUATION OF THE PLANE   X=Y  )
C
  900 SIGN = ONE
  920 CONTINUE
      DO 940 I = 13,24
         T(1,I) = T(4,I-12)*SIGN
         T(2,I) = T(5,I-12)*SIGN
         T(3,I) = T(6,I-12)*SIGN
         T(4,I) = T(1,I-12)
         T(5,I) = T(2,I-12)
         T(6,I) = T(3,I-12)
         T(7,I) = T(7,I-12)
         T(8,I) = T(8,I-12)
         T(9,I) = T(9,I-12)
  940 CONTINUE
      NT = 24
      IF (IGROUP .NE. 17) GO TO 980
C
C     OH GROUP IS DIRECT PRODUCT OF O AND CI
C
      CALL DCOPY(9*NT,T,1,T(1,NT+1),1)
      DO 960 J = NT+1,NT+NT
         DO 950 I = 1,9
            T(I,J) = -T(I,J)
  950    CONTINUE
  960 CONTINUE
      NT = 48
C
C     FIND THE INVERSE TRANSFORMATIONS
C
  980 CONTINUE
      DO 1020 ITR = 1,NT
      DO 1000 IT = 1,NT
      TEST =T(1,ITR)*T(1,IT)+T(2,ITR)*T(4,IT)+T(3,ITR)*T(7,IT)+T(4,ITR)*
     *     T(2,IT)+T(5,ITR)*T(5,IT)+T(6,ITR)*T(8,IT)+T(7,ITR)*T(3,IT)+
     *     T(8,ITR)*T(6,IT)+T(9,ITR)*T(9,IT) -3.0D+00
      IF (ABS(TEST) .GT. TOL) GO TO 1000
         INVT(ITR) = IT
         GO TO 1020
C
 1000 CONTINUE
 1020 CONTINUE
C
      CALL SPDTR
      RETURN
C
 9008 FORMAT(A5,I5)
 9048 FORMAT(9F10.5)
 9068 FORMAT(3F10.5,1X,A8)
 9088 FORMAT(49H LINEAR MOLECULE , POINT GROUP IS CINFV OR DINFH ,/,
     +     31H PLEASE USE GROUP CNV OR DNH...)
 9108 FORMAT(1X,'*** ERROR, ILLEGAL POINT GROUP=',A5,' CHOSEN.')
 9128 FORMAT(/1X,'THE POINT GROUP OF THE MOLECULE IS ',A8/
     *        1X,'THE ORDER OF THE PRINCIPAL AXIS IS ',I5)
 9148 FORMAT(/,42H THE ORIGIN OF THE LOCAL FRAME IS AT X =  ,F10.5,
     +     5H Y = ,F10.5,5H Z = ,F10.5,/,
     +     34H DIRECTOR COSINES OF THE NEW AXES ,/,34X,3(5X,F10.5),/,
     +     34X, 3(5X,F10.5),/,34X,3(5X,F10.5))
 9168 FORMAT(31H ROTATIONS ABOUT PRINCIPAL AXIS)
 9188 FORMAT(30H SIGMA-H FOLLOWED BY ROTATIONS)
 9208 FORMAT(26H C2 FOLLOWED BY ROTATIONS )
 9228 FORMAT(30H SIGMA-D FOLLOWED BY ROTATIONS)
 9248 FORMAT(30H SIGMA-V FOLLOWED BY ROTATIONS)
 9268 FORMAT(/,10X,27H CENTER OF SYMMETRY AT X = ,F10.5,5H Y = ,F10.5,
     +     5H Z = ,F10.5)
 9288 FORMAT(/,45H PLANE OF SYMMETRY DEFINED BY ITS NORMAL U = ,F10.5,
     +     5H V = ,F10.5,5H W = ,F10.5)
 9308 FORMAT(/,10X,3F15.9,/,10X,3F15.9,/,10X,3F15.9)
 9328 FORMAT(45H C2 FOLLOWED BY SIGMA-H FOLLOWED BY ROTATIONS)
 9348 FORMAT(45H SIGMA-D FOLLOWED BY C2 FOLLOWED BY ROTATIONS)
 9368 FORMAT(35H S2N ROTATION FOLLOWED BY ROTATIONS)
      END
C*MODULE INPUTB  *DECK RIJ
      DOUBLE PRECISION FUNCTION RIJ(C,I,J)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DIMENSION C(3,*)
C
      RIJSQ = (C(1,I)-C(1,J))**2+(C(2,I)-C(2,J))**2+(C(3,I)-C(3,J))**2
      RIJ = SQRT(RIJSQ)
      RETURN
      END
C*MODULE INPUTB  *DECK SETLAB
      SUBROUTINE SETLAB(IARG,ATMSYM)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      CHARACTER*4 ATMSYM(*)
      CHARACTER*4 BFNAM1(35)
      CHARACTER*6 BFNAM2(49)
      CHARACTER*4 ATMLAB(106),BONDF,LABEL
      CHARACTER*8 BFL
C
      PARAMETER (MXATM=2000, MXSH=5000, MXGTOT=20000, MXAO=8192)
C
      COMMON /ECP2  / CLP(400),ZLP(400),NLP(400),KFIRST(MXATM,6),
     *                KLAST(MXATM,6),LMAX(MXATM),LPSKIP(MXATM),
     *                IZCORE(MXATM)
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      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 /RUNLAB/ TITLE(10),ANAM(MXATM),BNAM(MXATM),BFLAB(MXAO)
C
      DATA BFNAM1/'  S ','  X ','  Y ','  Z ',
     *            ' XX ',' YY ',' ZZ ',' XY ',' XZ ',' YZ ',
     *            ' XXX',' YYY',' ZZZ',' XXY',' XXZ',
     *            ' YYX',' YYZ',' ZZX',' ZZY',' XYZ',
     *            'XXXX','YYYY','ZZZZ','XXXY','XXXZ',
     *            'YYYX','YYYZ','ZZZX','ZZZY','XXYY',
     *            'XXZZ','YYZZ','XXYZ','YYXZ','ZZXY'/
      DATA BFNAM2/' XXXXX',' YYYYY',' ZZZZZ',' XXXXY',' XXXXZ',
     *            ' YYYYX',' YYYYZ',' ZZZZX',' ZZZZY',' XXXYY',
     *            ' XXXZZ',' YYYXX',' YYYZZ',' ZZZXX',' ZZZYY',
     *            ' XXXYZ',' YYYXZ',' ZZZXY',' XXYYZ',' XXZZY',
     *            ' YYZZX',
     *            '    X6','    Y6','    Z6','   X5Y','   X5Z',
     *            '   Y5X','   Y5Z','   Z5X','   Z5Y','  X4Y2',
     *            '  X4Z2','  Y4X2','  Y4Z2','  Z4X2','  Z4Y2',
     *            '  X4YZ','  Y4XZ','  Z4XY','  X3Y3','  X3Z3',
     *            '  Y3Z3',' X3Y2Z',' X3Z2Y',' Y3X2Z',' Y3Z2X',
     *            ' Z3X2Y',' Z3Y2X','X2Y2Z2'/
      DATA BONDF/' BF '/
C
C                           104 TRUE ELEMENTS, AND 2 DUMMIES
C
      DATA ATMLAB/'H   ','HE  ','LI  ','BE  ','B   ','C   ',
     *            'N   ','O   ','F   ','NE  ','NA  ','MG  ',
     *            'AL  ','SI  ','P   ','S   ','CL  ','AR  ',
     *            'K   ','CA  ','SC  ','TI  ','V   ','CR  ',
     *            'MN  ','FE  ','CO  ','NI  ','CU  ','ZN  ',
     *            'GA  ','GE  ','AS  ','SE  ','BR  ','KR  ',
     *            'RB  ','SR  ','Y   ','ZR  ','NB  ','MO  ',
     *            'TC  ','RU  ','RH  ','PD  ','AG  ','CD  ',
     *            'IN  ','SN  ','SB  ','TE  ','I   ','XE  ',
     *            'CS  ','BA  ','LA  ','CE  ','PR  ','ND  ',
     *            'PM  ','SM  ','EU  ','GD  ','TB  ','DY  ',
     *            'HO  ','ER  ','TM  ','YB  ','LU  ','HF  ',
     *            'TA  ','W   ','RE  ','OS  ','IR  ','PT  ',
     *            'AU  ','HG  ','TL  ','PB  ','BI  ','PO  ',
     *            'AT  ','RN  ','FR  ','RA  ','AC  ','TH  ',
     *            'PA  ','U   ','NP  ','PU  ','AM  ','CM  ',
     *            'BK  ','CF  ','ES  ','FM  ','MD  ','NO  ',
     *            'LR  ','RF  ','X   ','BQ  '/
C
      IF(IARG.EQ.1) GO TO 100
      IF(IARG.EQ.2) GO TO 200
      IF(IARG.EQ.3) GO TO 300
      CALL ABRT
C
C         ----- FILL BASIS FUNCTION SYMBOL TABLE -----
C
  100 CONTINUE
      N = 0
      DO 120 II = 1,NSHELL
         IAT = KATOM(II)
         J = INT(ZAN(IAT))
         IF (J .GT. 106) J = 106
         IF (J .GT. 0) LABEL=ATMLAB(J)
         IF (J .LE. 0) LABEL=BONDF
         MINI = KMIN(II)
         MAXI = KMAX(II)
         DO 110 I = MINI,MAXI
            N = N+1
            IF(I.LE.35) THEN
               WRITE(UNIT=BFL,FMT='(A2,I2,A4)')
     *                      LABEL,MOD(IAT,100),BFNAM1(I)
            ELSE
               WRITE(UNIT=BFL,FMT='(A2,A6)')
     *                      LABEL,BFNAM2(I-35)
            END IF
            READ (UNIT=BFL,FMT='(A8)') BFLAB(N)
  110    CONTINUE
  120 CONTINUE
      RETURN
C
C        ----- FILL ATOM SYMBOL TABLE -----
C
  200 CONTINUE
      DO 210 IAT=1,NAT
         NUCZ = INT(ZAN(IAT)) + IZCORE(IAT)
         ATMSYM(IAT) = ATMLAB(105)
         IF(NUCZ.GE.1  .AND.  NUCZ.LE.104) ATMSYM(IAT) = ATMLAB(NUCZ)
  210 CONTINUE
      RETURN
C
C        ----- RETURN THE PERIODIC TABLE -----
C
  300 CONTINUE
      DO 310 IAT=1,106
         ATMSYM(IAT) = ATMLAB(IAT)
  310 CONTINUE
      RETURN
      END
C*MODULE INPUTB  *DECK SPDTR
      SUBROUTINE SPDTR
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      PARAMETER (MXSH=5000, MXATM=2000)
C
      COMMON /FRAME / U1,U2,U3,V1,V2,V3,W1,W2,W3,X0,Y0,Z0
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      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 /SYMSPD/ PTR(3,144),DTR(6,288),FTR(10,480),GTR(15,720)
      COMMON /SYMTRY/ MAPSHL(MXSH,48),MAPCTR(MXATM,48),
     *                T(9,48),INVT(48),NT
      COMMON /TRANSF/ XSMAL,YSMAL,ZSMAL,XNEW,YNEW,ZNEW,XP,YP,ZP
C
      DIMENSION PNAME(3),DNAME(6),FNAME(10),GNAME(15)
C
      PARAMETER (ONE=1.0D+00, SQRT3=1.73205080756888D+00,
     *           SQRT5=2.23606797749979D+00,
     *           SQRT7=2.64575131106459D+00)
C
      DATA PNAME /4HX   ,4HY   ,4HZ   /
      DATA DNAME /4HXX  ,4HYY  ,4HZZ  ,4HXY  ,4HXZ  ,4HYZ  /
      DATA FNAME /4HXXX ,4HYYY ,4HZZZ ,4HXXY ,4HXXZ ,4HYYX ,
     *            4HYYZ ,4HZZX ,4HZZY ,4HXYZ /
      DATA GNAME /4HXXXX,4HYYYY,4HZZZZ,4HXXXY,4HXXXZ,4HYYYX,
     *            4HYYYZ,4HZZZX,4HZZZY,4HXXYY,4HXXZZ,4HYYZZ,
     *            4HXXYZ,4HYYXZ,4HZZXY/
C
C     ----- CALCULATE TRANSFORMS OF P, D, F, AND FUNCTIONS
C           FOR ALL SYMMETRY OPERATIONS.
C
      X = X0+ONE
      Y = Y0
      Z = Z0
      XS = X
      YS = Y
      ZS = Z
      CALL LOCAL(X,Y,Z,XS,YS,ZS)
      XSMAL = XS
      YSMAL = YS
      ZSMAL = ZS
      DO 100 IT = 1,NT
      NN = 9*(IT-1)
      CALL TRANS(NN)
      CALL ROT
      N = 3*(IT-1)
      PTR(1,N+1) = XP-X0
      PTR(2,N+1) = YP-Y0
      PTR(3,N+1) = ZP-Z0
  100 CONTINUE
      X = X0
      Y = Y0+ONE
      Z = Z0
      CALL LOCAL(X,Y,Z,XS,YS,ZS)
      XSMAL = XS
      YSMAL = YS
      ZSMAL = ZS
      DO 120 IT = 1,NT
      NN = 9*(IT-1)
      CALL TRANS(NN)
      CALL ROT
      N = 3*(IT-1)
      PTR(1,N+2) = XP-X0
      PTR(2,N+2) = YP-Y0
      PTR(3,N+2) = ZP-Z0
  120 CONTINUE
      X = X0
      Y = Y0
      Z = Z0+ONE
      CALL LOCAL(X,Y,Z,XS,YS,ZS)
      XSMAL = XS
      YSMAL = YS
      ZSMAL = ZS
      DO 140 IT = 1,NT
      NN = 9*(IT-1)
      CALL TRANS(NN)
      CALL ROT
      N = 3*(IT-1)
      PTR(1,N+3) = XP-X0
      PTR(2,N+3) = YP-Y0
      PTR(3,N+3) = ZP-Z0
  140 CONTINUE
      DO 640 IT = 1,NT
      NP = 3*(IT-1)
      ND = 6*(IT-1)
      NF = 10*(IT-1)
      NG = 15*(IT-1)
      DO 300 I = 1,6
      GO TO (160,180,200,220,240,260) ,I
  160 J = 1
      K = 1
      GO TO 280
C
  180 J = 2
      K = 2
      GO TO 280
C
  200 J = 3
      K = 3
      GO TO 280
C
  220 J = 1
      K = 2
      GO TO 280
C
  240 J = 1
      K = 3
      GO TO 280
C
  260 J = 2
      K = 3
  280 DTR(1,ND+I) = PTR(1,NP+J)*PTR(1,NP+K)
      DTR(2,ND+I) = PTR(2,NP+J)*PTR(2,NP+K)
      DTR(3,ND+I) = PTR(3,NP+J)*PTR(3,NP+K)
      DTR(4,ND+I) = PTR(1,NP+J)*PTR(2,NP+K) +PTR(2,NP+J)*PTR(1,NP+K)
      DTR(5,ND+I) = PTR(1,NP+J)*PTR(3,NP+K) +PTR(3,NP+J)*PTR(1,NP+K)
      DTR(6,ND+I) = PTR(2,NP+J)*PTR(3,NP+K) +PTR(3,NP+J)*PTR(2,NP+K)
  300 CONTINUE
      DO 440 I=1,10
      GO TO (320,330,340,350,360,370,380,390,400,410),I
  320 J=1
      K=1
      GO TO 420
  330 J=2
      K=2
      GO TO 420
  340 J=3
      K=3
      GO TO 420
  350 J=1
      K=2
      GO TO 420
  360 J=1
      K=3
      GO TO 420
  370 J=2
      K=1
      GO TO 420
  380 J=2
      K=3
      GO TO 420
  390 J=3
      K=1
      GO TO 420
  400 J=3
      K=2
      GO TO 420
  410 J=4
      K=3
  420 FTR(1,NF+I)=DTR(1,ND+J)*PTR(1,NP+K)
      FTR(2,NF+I)=DTR(2,ND+J)*PTR(2,NP+K)
      FTR(3,NF+I)=DTR(3,ND+J)*PTR(3,NP+K)
      FTR(4,NF+I)=DTR(1,ND+J)*PTR(2,NP+K)
     1           +DTR(4,ND+J)*PTR(1,NP+K)
      FTR(5,NF+I)=DTR(1,ND+J)*PTR(3,NP+K)
     1           +DTR(5,ND+J)*PTR(1,NP+K)
      FTR(6,NF+I)=DTR(2,ND+J)*PTR(1,NP+K)
     1           +DTR(4,ND+J)*PTR(2,NP+K)
      FTR(7,NF+I)=DTR(2,ND+J)*PTR(3,NP+K)
     1           +DTR(6,ND+J)*PTR(2,NP+K)
      FTR(8,NF+I)=DTR(3,ND+J)*PTR(1,NP+K)
     1           +DTR(5,ND+J)*PTR(3,NP+K)
      FTR(9,NF+I)=DTR(3,ND+J)*PTR(2,NP+K)
     1           +DTR(6,ND+J)*PTR(3,NP+K)
      FTR(10,NF+I)=DTR(4,ND+J)*PTR(3,NP+K)
     1           + DTR(5,ND+J)*PTR(2,NP+K)
     2           + DTR(6,ND+J)*PTR(1,NP+K)
  440 CONTINUE
      DO 620 I=1,15
      GO TO (460,470,480,490,500,510,520,530,
     1       540,550,560,570,580,590,600),I
  460 J=1
      K=1
      GO TO 610
  470 J=2
      K=2
      GO TO 610
  480 J=3
      K=3
      GO TO 610
  490 J=1
      K=2
      GO TO 610
  500 J=1
      K=3
      GO TO 610
  510 J=2
      K=1
      GO TO 610
  520 J=2
      K=3
      GO TO 610
  530 J=3
      K=1
      GO TO 610
  540 J=3
      K=2
      GO TO 610
  550 J=4
      K=2
      GO TO 610
  560 J=5
      K=3
      GO TO 610
  570 J=7
      K=3
      GO TO 610
  580 J=4
      K=3
      GO TO 610
  590 J=6
      K=3
      GO TO 610
  600 J=8
      K=2
  610 GTR(1,NG+I)=FTR(1,NF+J)*PTR(1,NP+K)
      GTR(2,NG+I)=FTR(2,NF+J)*PTR(2,NP+K)
      GTR(3,NG+I)=FTR(3,NF+J)*PTR(3,NP+K)
      GTR(4,NG+I)=FTR(1,NF+J)*PTR(2,NP+K)
     1           +FTR(4,NF+J)*PTR(1,NP+K)
      GTR(5,NG+I)=FTR(1,NF+J)*PTR(3,NP+K)
     1           +FTR(5,NF+J)*PTR(1,NP+K)
      GTR(6,NG+I)=FTR(2,NF+J)*PTR(1,NP+K)
     1           +FTR(6,NF+J)*PTR(2,NP+K)
      GTR(7,NG+I)=FTR(2,NF+J)*PTR(3,NP+K)
     1           +FTR(7,NF+J)*PTR(2,NP+K)
      GTR(8,NG+I)=FTR(3,NF+J)*PTR(1,NP+K)
     1           +FTR(8,NF+J)*PTR(3,NP+K)
      GTR(9,NG+I)=FTR(3,NF+J)*PTR(2,NP+K)
     1           +FTR(9,NF+J)*PTR(3,NP+K)
      GTR(10,NG+I)=FTR(4,NF+J)*PTR(2,NP+K)
     1           + FTR(6,NF+J)*PTR(1,NP+K)
      GTR(11,NG+I)=FTR(5,NF+J)*PTR(3,NP+K)
     1           + FTR(8,NF+J)*PTR(1,NP+K)
      GTR(12,NG+I)=FTR(7,NF+J)*PTR(3,NP+K)
     1           + FTR(9,NF+J)*PTR(2,NP+K)
      GTR(13,NG+I)=FTR(4,NF+J)*PTR(3,NP+K)
     1           + FTR(5,NF+J)*PTR(2,NP+K)
     2           +FTR(10,NF+J)*PTR(1,NP+K)
      GTR(14,NG+I)=FTR(6,NF+J)*PTR(3,NP+K)
     1           + FTR(7,NF+J)*PTR(1,NP+K)
     2           +FTR(10,NF+J)*PTR(2,NP+K)
      GTR(15,NG+I)=FTR(8,NF+J)*PTR(2,NP+K)
     1           + FTR(9,NF+J)*PTR(1,NP+K)
     2           +FTR(10,NF+J)*PTR(3,NP+K)
  620 CONTINUE
  640 CONTINUE
      IF (NORMF .EQ. 1 .AND. NORMP .EQ. 1) GO TO 750
      DO 740 IT = 1,NT
      ND = 6*(IT-1)
      NF = 10*(IT-1)
      NG = 15*(IT-1)
      DO 660 I = 1,6
      IF (I .GT. 3) GO TO 650
      DTR(4,ND+I) = DTR(4,ND+I)/SQRT3
      DTR(5,ND+I) = DTR(5,ND+I)/SQRT3
      DTR(6,ND+I) = DTR(6,ND+I)/SQRT3
      GO TO 660
C
  650 DTR(1,ND+I) = DTR(1,ND+I)*SQRT3
      DTR(2,ND+I) = DTR(2,ND+I)*SQRT3
      DTR(3,ND+I) = DTR(3,ND+I)*SQRT3
  660 CONTINUE
      DO 690 I=1,10
      IF(I.GT.3) GO TO 670
      FTR(4,NF+I)=FTR(4,NF+I)/SQRT5
      FTR(5,NF+I)=FTR(5,NF+I)/SQRT5
      FTR(6,NF+I)=FTR(6,NF+I)/SQRT5
      FTR(7,NF+I)=FTR(7,NF+I)/SQRT5
      FTR(8,NF+I)=FTR(8,NF+I)/SQRT5
      FTR(9,NF+I)=FTR(9,NF+I)/SQRT5
      FTR(10,NF+I)=FTR(10,NF+I)/(SQRT5*SQRT3)
      GO TO 690
  670 IF(I.GT.9) GO TO 680
      FTR(1,NF+I)=FTR(1,NF+I)*SQRT5
      FTR(2,NF+I)=FTR(2,NF+I)*SQRT5
      FTR(3,NF+I)=FTR(3,NF+I)*SQRT5
      FTR(10,NF+I)=FTR(10,NF+I)/SQRT3
      GO TO 690
  680 FTR(1,NF+I)=FTR(1,NF+I)*SQRT5*SQRT3
      FTR(2,NF+I)=FTR(2,NF+I)*SQRT5*SQRT3
      FTR(3,NF+I)=FTR(3,NF+I)*SQRT5*SQRT3
      FTR(4,NF+I)=FTR(4,NF+I)*SQRT3
      FTR(5,NF+I)=FTR(5,NF+I)*SQRT3
      FTR(6,NF+I)=FTR(6,NF+I)*SQRT3
      FTR(7,NF+I)=FTR(7,NF+I)*SQRT3
      FTR(8,NF+I)=FTR(8,NF+I)*SQRT3
      FTR(9,NF+I)=FTR(9,NF+I)*SQRT3
  690 CONTINUE
      DO 730 I=1,15
      IF(I.GT.3) GO TO 700
      GTR(4,NG+I)=GTR(4,NG+I)/SQRT7
      GTR(5,NG+I)=GTR(5,NG+I)/SQRT7
      GTR(6,NG+I)=GTR(6,NG+I)/SQRT7
      GTR(7,NG+I)=GTR(7,NG+I)/SQRT7
      GTR(8,NG+I)=GTR(8,NG+I)/SQRT7
      GTR(9,NG+I)=GTR(9,NG+I)/SQRT7
      GTR(10,NG+I)=GTR(10,NG+I)*SQRT3/(SQRT5*SQRT7)
      GTR(11,NG+I)=GTR(11,NG+I)*SQRT3/(SQRT5*SQRT7)
      GTR(12,NG+I)=GTR(12,NG+I)*SQRT3/(SQRT5*SQRT7)
      GTR(13,NG+I)=GTR(13,NG+I)/(SQRT5*SQRT7)
      GTR(14,NG+I)=GTR(14,NG+I)/(SQRT5*SQRT7)
      GTR(15,NG+I)=GTR(15,NG+I)/(SQRT5*SQRT7)
      GO TO 730
  700 IF(I.GT.9) GO TO 710
      GTR(1,NG+I)=GTR(1,NG+I)*SQRT7
      GTR(2,NG+I)=GTR(2,NG+I)*SQRT7
      GTR(3,NG+I)=GTR(3,NG+I)*SQRT7
      GTR(10,NG+I)=GTR(10,NG+I)*SQRT3/SQRT5
      GTR(11,NG+I)=GTR(11,NG+I)*SQRT3/SQRT5
      GTR(12,NG+I)=GTR(12,NG+I)*SQRT3/SQRT5
      GTR(13,NG+I)=GTR(13,NG+I)/SQRT5
      GTR(14,NG+I)=GTR(14,NG+I)/SQRT5
      GTR(15,NG+I)=GTR(15,NG+I)/SQRT5
      GO TO 730
  710 IF(I.GT.12) GO TO 720
      GTR(1,NG+I)=GTR(1,NG+I)*SQRT7*SQRT5/SQRT3
      GTR(2,NG+I)=GTR(2,NG+I)*SQRT7*SQRT5/SQRT3
      GTR(3,NG+I)=GTR(3,NG+I)*SQRT7*SQRT5/SQRT3
      GTR(4,NG+I)=GTR(4,NG+I)*SQRT5/SQRT3
      GTR(5,NG+I)=GTR(5,NG+I)*SQRT5/SQRT3
      GTR(6,NG+I)=GTR(6,NG+I)*SQRT5/SQRT3
      GTR(7,NG+I)=GTR(7,NG+I)*SQRT5/SQRT3
      GTR(8,NG+I)=GTR(8,NG+I)*SQRT5/SQRT3
      GTR(9,NG+I)=GTR(9,NG+I)*SQRT5/SQRT3
      GTR(13,NG+I)=GTR(13,NG+I)/SQRT3
      GTR(14,NG+I)=GTR(14,NG+I)/SQRT3
      GTR(15,NG+I)=GTR(15,NG+I)/SQRT3
      GO TO 730
  720 GTR(1,NG+I)=GTR(1,NG+I)*SQRT7*SQRT5
      GTR(2,NG+I)=GTR(2,NG+I)*SQRT7*SQRT5
      GTR(3,NG+I)=GTR(3,NG+I)*SQRT7*SQRT5
      GTR(4,NG+I)=GTR(4,NG+I)*SQRT5
      GTR(5,NG+I)=GTR(5,NG+I)*SQRT5
      GTR(6,NG+I)=GTR(6,NG+I)*SQRT5
      GTR(7,NG+I)=GTR(7,NG+I)*SQRT5
      GTR(8,NG+I)=GTR(8,NG+I)*SQRT5
      GTR(9,NG+I)=GTR(9,NG+I)*SQRT5
      GTR(10,NG+I)=GTR(10,NG+I)*SQRT3
      GTR(11,NG+I)=GTR(11,NG+I)*SQRT3
      GTR(12,NG+I)=GTR(12,NG+I)*SQRT3
  730 CONTINUE
  740 CONTINUE
  750 CONTINUE
C
C     ----- PRINT MATRICES IF NPRINT.EQ.5 -----
C
      IF (NPRINT .NE. 5) GO TO 860
      IF (MASWRK) THEN
      WRITE (IW,9028)
      DO 840 IT = 1,NT
      WRITE (IW,9088)
      WRITE (IW,9108) IT
      NP = 3*(IT-1)
      WRITE (IW,9048) (PNAME(J),J = 1,3)
      WRITE (IW,9128)
      DO 760 I = 1,3
  760 WRITE (IW,9068) PNAME(I),(PTR(I,NP+J),J = 1,3)
      WRITE (IW,9008)
      ND = 6*(IT-1)
      WRITE (IW,9048) (DNAME(J),J = 1,6)
      WRITE (IW,9128)
      DO 780 I = 1,6
  780 WRITE (IW,9068) DNAME(I),(DTR(I,ND+J),J = 1,6)
      WRITE (IW,9008)
      NF = 10*(IT-1)
      WRITE (IW,9048) (FNAME(J),J = 1,10)
      WRITE (IW,9128)
      DO 800 I = 1,10
  800 WRITE (IW,9068) FNAME(I),(FTR(I,ND+J),J = 1,10)
      WRITE (IW,9008)
      NG = 15*(IT-1)
      WRITE (IW,9048) (GNAME(J),J = 1,15)
      WRITE (IW,9128)
      DO 820 I = 1,15
  820 WRITE (IW,9068) GNAME(I),(GTR(I,ND+J),J = 1,15)
      WRITE (IW,9008)
  840 CONTINUE
      END IF
  860 CONTINUE
C
C     -- WRITE PTR, DTR, FTR, AND GTR ON IDAF --
C
      IF(IREST.LT.1) CALL DAWRIT(IDAF,IODA,PTR,  432, 7,0)
      IF(IREST.LT.1) CALL DAWRIT(IDAF,IODA,DTR, 1728, 8,0)
      IF(IREST.LT.1) CALL DAWRIT(IDAF,IODA,FTR, 4800, 9,0)
      IF(IREST.LT.1) CALL DAWRIT(IDAF,IODA,GTR,10800,10,0)
      RETURN
C
 9008 FORMAT(//)
 9028 FORMAT(/,38H TRANSFORMATION OF THE BASIS FUNCTIONS,/)
 9048 FORMAT(7X,15(2X,A4,2X))
 9068 FORMAT(2X,A4,1X,15F8.4)
 9088 FORMAT(1H1)
 9108 FORMAT(/,21X,21HTRANSFORMATION NUMBER,I4,/)
 9128 FORMAT(/)
      END
C*MODULE INPUTB *DECK TIN2GMS
      SUBROUTINE TIN2GMS
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
C    GAMESS
      PARAMETER (MXATM=2000)
      PARAMETER (MAXLNK=50, MAXR1=100)
      PARAMETER (ONE=1.0D+00)
C
      INTEGER TYPE,TAG,CLASS,ATOMIC,VALENCE
      REAL*8 DY,DZ,X,Y,Z,MASS
      CHARACTER*10 NAME,UATOM
      CHARACTER*20 STORY
      LOGICAL IMOMM,SIMOMM
      DIMENSION ITMPLNK(MAXLNK)
C
      COMMON /COORDN/ UZNUC(MXATM),CUNIQ(MXATM,3),NATREL,UATOM(MXATM)
C
C          THIS IS AN INTERFACE TO TINKER.  MEMORY FOR MAXATM
C          IS DELIBERATELY SET LOW SO THERE'S NO PENALTY
C          TO GAMESS WHEN TINKER IS NOT BEING USED.  IF TINKER
C          IS BEING USED, YOU MUST MODIFY MAXATM TO MATCH THE
C          VALUE SPECIFIED IN THE "SIZES.I" INCLUDE FILE.
C
      PARAMETER (MAXATM=1000)
      COMMON /ATMTYP/ MASS(MAXATM),TAG(MAXATM),CLASS(MAXATM),
     *                ATOMIC(MAXATM),VALENCE(MAXATM),NAME(MAXATM),
     *                STORY(MAXATM)
      COMMON /ATOMST/ X(MAXATM),Y(MAXATM),Z(MAXATM),N,TYPE(MAXATM)
C
      COMMON /QMMM1/ IMOMM,SIMOMM,NPAIR,NSEQ
      COMMON /QMMM2/ IQMATM(MAXR1)
      COMMON /QMMM3/ LINKGE(3*MAXLNK),BLQM(MAXLNK),BLMM(MAXLNK)
C
C     TITLE CARD
C     TITLE(1)=TTITLE
C     TOTAL NUMBER OF QUANTUM ATOMS
C
      NATREL=NSEQ+NPAIR
C
C     ASSIGN CHARGE, CARTESIAN COORDINATES AND ATOM NAME OF QM ATOMS
C
      DO I=1,NSEQ
        UZNUC(I)=ATOMIC(IQMATM(I))
        CUNIQ(I,1)=X(IQMATM(I))
        CUNIQ(I,2)=Y(IQMATM(I))
        CUNIQ(I,3)=Z(IQMATM(I))
        UATOM(I)=NAME(IQMATM(I))
      ENDDO
C
C     DANGLING BONDS ARE REPLACED BY HYDROGENS
C
      DO I=1,NPAIR
         LR1=LINKGE(3*I-2)
         LR2=LINKGE(3*I  )
         DX=(X(LR2)-X(LR1))
         DY=(Y(LR2)-Y(LR1))
         DZ=(Z(LR2)-Z(LR1))
         TDIST=SQRT(DX**2+DY**2+DZ**2)
         DO J=1,NSEQ
            IF (LR1.EQ.IQMATM(J)) ITMPLNK(I)=J
         ENDDO
         ZAN1 = ATOMIC(LR1)
         CALL GTDIST(ZAN1,ONE,RDIST)
         UZNUC(I+NSEQ)=ONE
         UATOM(I+NSEQ)='H         '
         CUNIQ(I+NSEQ,1)=X(LR1)+DX*RDIST/TDIST
         CUNIQ(I+NSEQ,2)=Y(LR1)+DY*RDIST/TDIST
         CUNIQ(I+NSEQ,3)=Z(LR1)+DZ*RDIST/TDIST
      ENDDO
      UATOM(NSEQ+NPAIR+1)='$END      '
C
C     ASSIGN LINKGE VALUES
C
      DO I=1,NPAIR
         LINKGE(I*3-2)=ITMPLNK(I)
      ENDDO
C
      RETURN
      END
C*MODULE INPUTB  *DECK FLIPBASIS
      SUBROUTINE FLIPBASIS(NREC)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      COMMON /FMCOM / XX(1)
      COMMON /MACHIN/ NWDVAR,MAXFM,MAXSM,LIMFM,LIMSM
      PARAMETER (MXSH=5000, MXGTOT=20000)
C
C          ALLOCATE MEMORY TO RESTORE A BASIS SET FROM DAF
C
      CALL VALFM(LOADFM)
      LCC  = LOADFM + 1
      LKK  = LCC    + MXGTOT*6
      LAST = LKK    + (7*MXSH+1)/NWDVAR + 1
      NEED = LAST - LOADFM -1
      CALL GETFM(NEED)
      CALL FLIPB2(NREC,XX(LCC),XX(LKK),MXGTOT,MXSH)
      CALL RETFM(NEED)
      RETURN
      END
C*MODULE INPUTB  *DECK FLIPB2
      SUBROUTINE FLIPB2(NREC,CC,KK,MAXGTOT,MAXSH)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      PARAMETER (MXSH=5000, MXGTOT=20000)
C
      DIMENSION CC(MAXGTOT*6),KK(MAXSH*7+1)
C
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      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 /MACHIN/ NWDVAR,MAXFM,MAXSM,LIMFM,LIMSM
      COMMON /RELWFN/ RMETHOD,QRQMT,CLIG,CLIG2,QRTOL,IQRORD,MODQR,NESOC,
     *                NRATOM,NUMU,NQMTR,NQRDAF,MORDA,NDARELB
C
      DATA RNONE/8HNONE    /
C
C     READ IN THE BASIS SET
C
      NCOEF=MXGTOT
      NN=5
      IF(RMETHOD.NE.RNONE.AND.MOD(MODQR,2).EQ.1) NN=6
C
      CALL DAREAD(IDAF,IODA,CC,NCOEF*NN,NREC+NDARELB,0)
      CALL DCOPY(NCOEF,CC(        1),1,CS,1)
      CALL DCOPY(NCOEF,CC(  NCOEF+1),1,CP,1)
      CALL DCOPY(NCOEF,CC(2*NCOEF+1),1,CD,1)
      CALL DCOPY(NCOEF,CC(3*NCOEF+1),1,CF,1)
      CALL DCOPY(NCOEF,CC(4*NCOEF+1),1,CG,1)
C
      IF(RMETHOD.NE.RNONE.AND.MOD(MODQR,2).EQ.1) THEN
         CALL DCOPY(NCOEF,CC(5*NCOEF+1),1,EX,1)
         NK=MXSH
         CALL DAREAD(IDAF,IODA,KK,(NK*7+1)/NWDVAR+1,NDARELB+NREC+1,1)
         CALL ICOPY(NK,KK(1     ),1,KSTART,1)
         CALL ICOPY(NK,KK(1+  NK),1,KATOM,1)
         CALL ICOPY(NK,KK(1+2*NK),1,KTYPE,1)
         CALL ICOPY(NK,KK(1+3*NK),1,KNG,1)
         CALL ICOPY(NK,KK(1+4*NK),1,KLOC,1)
         CALL ICOPY(NK,KK(1+5*NK),1,KMIN,1)
         CALL ICOPY(NK,KK(1+6*NK),1,KMAX,1)
         NSHELL=       KK(1+7*NK)
      ENDIF
      RETURN
      END
C*MODULE INPUTB  *DECK RWFINP
      SUBROUTINE RWFINP
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      PARAMETER (MXATM=2000)
C
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      COMMON /BASSPH/ QMTTOL,ISPHER
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,ITYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /RELWFN/ RMETHOD,QRQMT,CLIG,CLIG2,QRTOL,IQRORD,MODQR,NESOC,
     *                NRATOM,NUMU,NQMTR,NQRDAF,MORDA,NDARELB
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
C
C              $RELWFN NAMELIST INFORMATION
C
      PARAMETER (NNAM=9)
      DIMENSION KQNAM(NNAM),QNAM(NNAM),CHARGE(MXATM)
      DATA RELWFN/8HRELWFN  /
      DATA KQNAM/1,-3,1,3,1,3,3,1,1/
      DATA QNAM/8HNRATOM  ,8HCHARGE  ,8HNESOC   ,8HQMTTOL  ,8HMODEQR  ,
     *          8HQRTOL   ,8HCLIGHT  ,8HNORDER  ,8HNVIB    /
C
      DATA RESC,ANESC,DK/8HRESC    ,8HNESC    ,8HDK      /
      DATA TRANST/8HTRANSITN/
C
C     ----- RELATIVISTIC WAVEFUNCTION INPUT -----
C     DATA FOR NAKAJIMA/HIRAO'S -RESC-
C                    OR DYALL'S -NESC-
C         OR DOUGLAS/KROLL/HESS -DK- METHODOLOGIES
C
C     DICTIONARY FILE WILL BE USED, FROM RECORD NDARELB AND FURTHER
C
      NDARELB=370
C
      CLIG=137.0359895D+00
C
      KQNAM(2) = 10*NAT + 3
      NRATOM=0
      NESOC=0
      MODQR=1
      IF(ISPHER.GT.0) MODQR=MODQR+2
      NVIB=2
C
C     ADDITIVE OPTIONS FOR RESC AND DK
C     1 - TURN ON INTERNAL UNCONTRACTED BASIS
C     2 - HONDO STYLE INTERNAL UNCONTRACTION RI (ISPHER=1 TYPE)
C         INTERNALLY UNCONTRACTED OPTION ELIMINATES SPHERICAL
C         CONTAMINANTS BUT DOES NOT USE SYMMETRY IN CONSTRUCTION OF
C         RIS (IN THE CONTRACTED CASE IT DOES).
C         RESC GRADIENT CANNOT RUN WITH THIS OPTION SET.
C         IT IS RECOMMENDED THAT ISPHER=1 BE ALWAYS USED WITH THIS BIT
C         OF MODQR SET TO 1.
C     4 - L-SHELL TO BE SPLIT INTO S AND P IN THE UNCONTRACTION
C     8 - USE QUADRUPLE PRECISION (128 BIT) FOR RIS IF AVAILABLE
C         (OTHERWISE USE DOUBLE PRECISION).
C
C     65536 - IS NOT AN INPUT OPTION, BUT A WAY TO PASS NVIB
C         (NVIB=1: 1; NVIB=2: 0).
C    131072 - IS NOT AN INPUT OPTION, BUT A WAY TO PASS CARTESIAN MODE
C
      IQRORD=2
C
C     ORDER OF THE RELATIVISTIC APPROXIMATION, CURRENTLY ONLY
C     USED FOR DK, POSSIBLE VALUES: 1,2,3.
C     NOTE THAT 1 CORRESPONDS TO THE FREE PARTICLE.
C     RESC HAS THIS VALUE EQUAL TO 2 FIXED IN THIS IMPLEMENTATION.
C     (SECRET CODE/RESULTS FOR HIGHER ORDERS MAY EXIST ELSEWHERE).
C
      IF(RUNTYP.EQ.TRANST) NESOC=-1
      QRQMT=QMTTOL
      QRTOL=0.0D+00
C
      JRET = 0
      CALL NAMEIO(IR,JRET,RELWFN,NNAM,QNAM,KQNAM,
     *            NRATOM,CHARGE,NESOC,QRQMT,MODQR,QRTOL,
     *            CLIG,IQRORD,NVIB,   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)
      IF(JRET.GT.1) THEN
         IF (MASWRK) WRITE(IW,9000) RELWFN
         CALL ABRT
      END IF
C
      CLIG2=CLIG*CLIG
      IF(RMETHOD.EQ.RESC.OR.RMETHOD.EQ.DK) THEN
         IF(MOD(MODQR,2).EQ.1.AND.NESOC.EQ.2) NESOC=1
         IF(NESOC.LT.0) NESOC=2
      ENDIF
      IF(RMETHOD.EQ.ANESC.AND.NESOC.LT.0) NESOC=1
      IF(RMETHOD.EQ.RESC.AND.QRTOL.EQ.0.0D+00) QRTOL=MIN(1.0D-08,QRQMT)
      IF(RMETHOD.EQ.DK.AND.QRTOL.EQ.0.0D+00) QRTOL=0.01D+00
C     NO INTERNAL UNCONTRACTION FOR NESC
      IF(RMETHOD.EQ.ANESC) MODQR=0
      IF(MOD(MODQR,3).EQ.3.AND.ISPHER.NE.1) THEN
         IF (MASWRK) WRITE(IW,9420)
         CALL ABRT
      END IF
      IF(MOD(MODQR/2,2).EQ.1.AND.ISPHER.NE.1) THEN
         IF (MASWRK) WRITE(IW,9425)
C        THE CODE WILL RUN, DON'T ABORT
C--      CALL ABRT
      END IF
      IF(NVIB.LT.0) THEN
         MODQR=IOR(MODQR,131072)
         NVIB=-NVIB
      ENDIF
      IF(NVIB.NE.1.AND.NVIB.NE.2) THEN
         IF (MASWRK) WRITE(IW,9430)
         CALL ABRT
      END IF
      IF(NVIB.EQ.1) MODQR=IOR(MODQR,65536)
C
      IF(MASWRK) WRITE(IW,9300) RMETHOD,IQRORD,NESOC,MODQR,NRATOM,
     *                          QRQMT,QRTOL,CLIG
C
C        NO GRADIENT FOR HONDO OPTION AT PRESENT, AND PROBABLY NEVER,
C        SO INSTEAD WE FORCE A DIFFERENT -MODQR-
C
      CALL DERCHK(NDER)
      IF(RMETHOD.EQ.RESC.AND.NDER.GT.0.AND.MOD(MODQR/2,2).EQ.1) THEN
         WRITE(IW,9410)
         MODQR=MODQR-2
      END IF
C
C         CHECK TO SEE IF MACHINE HAS TRUE QUADRUPLE PRECISION
C         THIS ROUTINE KILLS THE JOB IF Q.P. IS NOT AVAILABLE
C
      IF(MOD(MODQR/8,2).NE.0) CALL IQTEST(.TRUE.)
C
      IRAREC=NDARELB+21
      IF(RMETHOD.EQ.ANESC) THEN
         IRAREC=NDARELB+5
         IF(MASWRK) WRITE(IW,9500)
      ENDIF
      IF(NRATOM.GT.0) CALL DAWRIT(IDAF,IODA,CHARGE,NRATOM,IRAREC,0)
C
      RETURN
C
 9000 FORMAT(1X,'**** ERROR IN ',A8,' GROUP...PLEASE FIX IT.')
 9300 FORMAT(/5X,33(1H-)/5X,'RELATIVISTIC WAVEFUNCTION OPTIONS',
     *       /5X,33(1H-)/5X,'METHOD=',A8,' NORDER=',I2,6X,' NESOC= ',I2,
     *      6X,'MODEQR=',I7/5X,'NRATOM=',I3,6X,'QMTTOL=',1P,E10.3,0P,
     *      6X,'QRTOL=',1P,E10.3,0P/5X,'CLIGHT=',F12.8)
 9410 FORMAT(1X,'NO ANALYTICAL GRADIENT FOR HONDO STYLE RI FORCES',
     *          'THE LATTER OFF.',/)
 9420 FORMAT(1X,'ISPHER.NE.1 AND MOD(MODQR,3)=3 ARE INCOMPATIBLE.',/)
 9425 FORMAT(1X,'USING ISPHER.NE.1 AND THE HONDO OPTION IS DISCOURAGED')
 9430 FORMAT(1X,'NVIB CAN BE 1 OR 2'/)
 9500 FORMAT(1X,'AO NON-RELATIVISTIC NORMALISATION WILL BE OMITTED.')
      END
C*MODULE INPUTB  *DECK RELSAVE
      SUBROUTINE RELSAVE(NREC)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      PARAMETER (MXATM=2000, MXGTOT=20000)
      COMMON /FMCOM / XX(1)
C
C          ALLOCATE MEMORY TO SAVE A BASIS SET ON DAF
C
      CALL VALFM(LOADFM)
      LCC  = LOADFM + 1
      LCC0 = LCC    + MXGTOT*5
      LEX0 = LCC0   + MXGTOT*5
      LCHG = LEX0   + MXGTOT
      LZN0 = LCHG   + MXATM
      LC0  = LZN0   + MXATM
      LAST = LC0    + MXATM*3
      NEED = LAST - LOADFM -1
      CALL GETFM(NEED)
      CALL RELSV1(NREC,XX(LCC0),XX(LCC),XX(LEX0),XX(LCHG),
     *            XX(LZN0),XX(LC0),MXGTOT,MXATM)
      CALL RETFM(NEED)
      RETURN
      END
C*MODULE INPUTB  *DECK RELSV1
      SUBROUTINE RELSV1(NREC,CC0,CC,EX0,CHARGE,ZAN0,C0,MAXGTOT,MAXATM)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      PARAMETER (MXATM=2000, MXSH=5000, MXGTOT=20000)
      PARAMETER (ONE=1.0D+00)
C
      CHARACTER*1 SYMB
C
      DIMENSION CC0(MAXGTOT,5),CC(MAXGTOT,5),EX0(MAXGTOT),
     *          CHARGE(MAXATM),ZAN0(MAXATM),C0(3,MAXATM)
C
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      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 /RELWFN/ RMETHOD,QRQMT,CLIG,CLIG2,QRTOL,IQRORD,MODQR,NESOC,
     *                NRATOM,NUMU,NQMTR,NQRDAF,MORDA,NDARELB
C
      NCOEF=MAXGTOT
C
C    THE ORDER OF CALLS IS IMPORTANT. IT MUST BE NREC=4,0,3
C
C     THE ORDER OF THE RECORDS IS (RELATIVE TO NDARELB):
C
C     THESE ARE USED BY METHOD=NESC
C
C     0: A (LARGE COMPONENT)
C     1: B (SMALL COMPONENT) <- ZEROS FOR NON-RELATIVISTIC ATOMS
C     2: A-B1
C     3: N (RELATIVISTICALLY NORMALISED LARGE COMPONENT)
C     4: B1 (SMALL COMPONENT) <- LARGE COMPONENT FOR NON-RELVSTIC ATOMS
C
C     5: CHARGES OF ATOMS TO BE TREATED NON-RELATIVISTICALLY
C     6: ZAN, FROM INFOA FOR INTERNAL CHECK
C     7: C, FROM INFOA FOR INTERNAL CHECK
C     8: EX, FROM NSHEL FOR INTERNAL CHECK
C
C     THESE ARE USED BY METHOD=RESC
C
C     0: LEFT TRANSFORMATION MATRIX OQ
C     1: RIGHT TRANSFORMATION MATRIX Q(O**-1)
C     BOTH ARE USED TO TRANSFORM SOC INTEGRALS
C
C     PERFORM INTERNAL CHECK FOR CONSISTENCY OF THE THREE $DATA GROUPS
C
      IF(NREC.EQ.4) THEN
         CALL DAWRIT(IDAF,IODA,ZAN ,NAT   ,NDARELB+6,0)
         CALL DAWRIT(IDAF,IODA,C   ,3*NAT ,NDARELB+7,0)
         CALL DAWRIT(IDAF,IODA,EX  ,NSHELL,NDARELB+8,0)
      ELSE
         CALL DAREAD(IDAF,IODA,ZAN0,NAT   ,NDARELB+6,0)
         CALL DAREAD(IDAF,IODA,C0  ,3*NAT ,NDARELB+7,0)
         CALL DAREAD(IDAF,IODA,EX0 ,NSHELL,NDARELB+8,0)
         IZAN=KOMVEC(NAT   ,1.0D-06,ZAN,ZAN0,1)
         IC=  KOMVEC(NAT*3 ,1.0D-06,C  ,C0  ,1)
         IEX= KOMVEC(NSHELL,1.0D-06,EX ,EX0 ,1)
         SYMB='?'
         IF(NREC.EQ.3) SYMB=' '
         IF(NREC.EQ.0) SYMB='L'
         IF(IZAN.NE.0) THEN
            WRITE(IW,9000) SYMB,IZAN
            CALL ABRT
         ENDIF
         IF(IC.NE.0) THEN
            WRITE(IW,9100) SYMB,IC
            CALL ABRT
         ENDIF
         IF(IEX.NE.0) THEN
            WRITE(IW,9200) SYMB,IEX
            CALL ABRT
         ENDIF
      ENDIF
      CALL DCOPY(NCOEF,CS,1,CC(1,1),1)
      CALL DCOPY(NCOEF,CP,1,CC(1,2),1)
      CALL DCOPY(NCOEF,CD,1,CC(1,3),1)
      CALL DCOPY(NCOEF,CF,1,CC(1,4),1)
      CALL DCOPY(NCOEF,CG,1,CC(1,5),1)
      CALL DAWRIT(IDAF,IODA,CC,NCOEF*5,NDARELB+NREC,0)
      IF(NREC.EQ.0) THEN
C        SMALL COMPONENT IS TO BE SUBSTRACTED FROM LARGE AND SAVED
C        SMALL MUST HAVE ALREADY BEEN SAVED!
C        CALL RELSAVE(0) LAST.
C        WRITE(6,*) NRATOM,'LARGE',CC
         IF(NRATOM.GT.0)
     *      CALL DAREAD(IDAF,IODA,CHARGE,NRATOM,NDARELB+5,0)
         CALL DAREAD(IDAF,IODA,CC0,NCOEF*5,NDARELB+4,0)
         CALL DAXPY(NCOEF*5,-ONE,CC0,1,CC,1)
         CALL DAWRIT(IDAF,IODA,CC ,NCOEF*5,NDARELB+2,0)
C
C        ZERO OUT SMALL COMPONENT FOR NON-RELATIVISTIC ATOMS
C
         IND=1
         DO 900 II=1,NSHELL
            DO 800 I=1,KNG(II)
               DO 700 IAT=1,NRATOM
                  IF(ABS(ZAN(KATOM(II))-CHARGE(IAT)).LT.1.0D-02)
     *               CALL VCLR(CC0(IND,1),MXGTOT,5)
  700          CONTINUE
               IND=IND+1
  800       CONTINUE
  900    CONTINUE
         CALL DAWRIT(IDAF,IODA,CC0,NCOEF*5,NDARELB+1,0)
      ENDIF
      RETURN
 9000 FORMAT(1X,    'NUCLEAR CHARGES IN $DATA',A1,' AND $DATAS ',
     *         'MISMATCH, ELEMENT',I4,/)
 9100 FORMAT(1X, 'ATOMIC COORDINATES IN $DATA',A1,' AND $DATAS ',
     *         'MISMATCH, ELEMENT',I4,/)
 9200 FORMAT(1X,'PRIMITIVE EXPONENTS IN $DATA',A1,' AND $DATAS ',
     *         'MISMATCH, ELEMENT',I4,/)
      END
C*MODULE INPUTB  *DECK RELSAVEU
      SUBROUTINE RELSAVEU(NREC,EX,CS,CP,CD,CF,CG,KSTART,KATOM,KTYPE,KNG,
     *                    KLOC,KMIN,KMAX,NSHELL)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      PARAMETER (MXSH=5000, MXGTOT=20000)
      DIMENSION EX(*),CS(*),CP(*),CD(*),CF(*),CG(*),KSTART(*),KATOM(*),
     *          KTYPE(*),KNG(*),KLOC(*),KMIN(*),KMAX(*)
      COMMON /FMCOM / XX(1)
      COMMON /MACHIN/ NWDVAR,MAXFM,MAXSM,LIMFM,LIMSM
C
C          ALLOCATE MEMORY TO SAVE A BASIS SET ON DAF
C
      CALL VALFM(LOADFM)
      LCC  = LOADFM + 1
      LKK  = LCC    + MXGTOT*6
      LAST = LKK    + (7*MXSH+1)/NWDVAR + 1
      NEED = LAST - LOADFM -1
      CALL GETFM(NEED)
      CALL RELSV2(NREC,EX,CS,CP,CD,CF,CG,KSTART,KATOM,KTYPE,KNG,
     *            KLOC,KMIN,KMAX,NSHELL,XX(LCC),XX(LKK),MXGTOT,MXSH)
      CALL RETFM(NEED)
      RETURN
      END
C*MODULE INPUTB  *DECK RELSV2
      SUBROUTINE RELSV2(NREC,EX,CS,CP,CD,CF,CG,KSTART,KATOM,KTYPE,KNG,
     *                  KLOC,KMIN,KMAX,NSHELL,CC,KK,MAXGTOT,MAXSH)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION CC(MAXGTOT,6),KK(MAXSH*7+1),
     *          EX(*),CS(*),CP(*),CD(*),CF(*),CG(*),KSTART(*),KATOM(*),
     *          KTYPE(*),KNG(*),KLOC(*),KMIN(*),KMAX(*)
C
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /MACHIN/ NWDVAR,MAXFM,MAXSM,LIMFM,LIMSM
      COMMON /RELWFN/ RMETHOD,QRQMT,CLIG,CLIG2,QRTOL,IQRORD,MODQR,NESOC,
     *                NRATOM,NUMU,NQMTR,NQRDAF,MORDA,NDARELB
C
      NCOEF = MAXGTOT
C
      CALL DCOPY(NCOEF,CS,1,CC(1,1),1)
      CALL DCOPY(NCOEF,CP,1,CC(1,2),1)
      CALL DCOPY(NCOEF,CD,1,CC(1,3),1)
      CALL DCOPY(NCOEF,CF,1,CC(1,4),1)
      CALL DCOPY(NCOEF,CG,1,CC(1,5),1)
      CALL DCOPY(NCOEF,EX,1,CC(1,6),1)
      CALL DAWRIT(IDAF,IODA,CC,NCOEF*6,NDARELB+NREC,0)
C
      NK=MAXSH
C
      CALL ICOPY(NK,KSTART,1,KK(1     ),1)
      CALL ICOPY(NK,KATOM ,1,KK(1+  NK),1)
      CALL ICOPY(NK,KTYPE ,1,KK(1+2*NK),1)
      CALL ICOPY(NK,KNG   ,1,KK(1+3*NK),1)
      CALL ICOPY(NK,KLOC  ,1,KK(1+4*NK),1)
      CALL ICOPY(NK,KMIN  ,1,KK(1+5*NK),1)
      CALL ICOPY(NK,KMAX  ,1,KK(1+6*NK),1)
      KK(1+7*NK)=NSHELL
      CALL DAWRIT(IDAF,IODA,KK,(NK*7+1)/NWDVAR+1,NDARELB+NREC+1,1)
C
      RETURN
      END
C*MODULE INPUTB  *DECK BUNCON
      SUBROUTINE BUNCON(MAXGTOT,MAXSH,EXU,CSU,CPU,CDU,CFU,CGU,
     *                  KSTARTU,KATOMU,KTYPEU,KNGU,KLOCU,KMINU,KMAXU,
     *                  MAPLE,LARCH,ELM)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK,ADDPRIM,ADDSHELL,COPYSHELL,LSHELL
C
      DIMENSION EXU(MAXGTOT),CSU(MAXGTOT),CPU(MAXGTOT),CDU(MAXGTOT),
     *          CFU(MAXGTOT),CGU(MAXGTOT),
     *          KSTARTU(MAXSH),KATOMU(MAXSH),KTYPEU(MAXSH),
     *          KNGU(MAXSH),KLOCU(MAXSH),KMINU(MAXSH),KMAXU(MAXSH),
     *          MAPLE(MAXGTOT),LARCH(MAXGTOT)
      INTEGER ELM(MAXGTOT)
C
      PARAMETER (MXATM=2000, MXSH=5000, MXGTOT=20000)
C
      COMMON /FMCOM / X(1)
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      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 /RELWFN/ RMETHOD,QRQMT,CLIG,CLIG2,QRTOL,IQRORD,MODQR,NESOC,
     *                NRATOM,NUMU,NQMTR,NQRDAF,MORDA,NDARELB
      COMMON /SYMTRY/ MAPSHL(MXSH,48),MAPCTR(MXATM,48),
     *                T(432),INVT(48),NT
C
      PARAMETER (TINY=1.0D-10,ZERO=0.0D+00, ONE=1.0D+00, HALF=0.5D+00,
     *           PT75=0.75D+00, PT187=1.875D+00, PT6562=6.5625D+00)
C
      PI = ACOS(-ONE)
      PI32 = PI * SQRT(PI)
      L1=NUM
      LU1=0
      DO I=1,NSHELL
         LU1=LU1+(KMAX(I)-KMIN(I)+1)*KNG(I)
      ENDDO
      CALL VALFM(LOADFM)
      LUU     = LOADFM  + 1
      LUU1    = LUU     + L1*LU1
      LCHARGE = LUU1    + LU1*L1
      LAST    = LCHARGE + NRATOM
      NEED = LAST-LOADFM-1
      CALL GETFM(NEED)
C
      CALL VCLR(X(LUU),1,LU1*L1)
      CALL VICLR(MAPLE,1,MXGTOT)
      CALL VICLR(ELM,1,MXGTOT)
C
      LUNCON=MOD(MODQR/4,2)
      IRAREC=NDARELB+21
      IF(NRATOM.GT.0) CALL DAREAD(IDAF,IODA,X(LCHARGE),NRATOM,IRAREC,0)
      NREDUN=0
      NCOPIED=0
      NGHOST=0
      NUMU=0
      NSHELLU=0
      INDU=0
      KLOCU0=0
      KMM=1
C
      DO 200 I=1,NSHELL
        COPYSHELL=.FALSE.
        DO IAT=1,NRATOM
           IF(ABS(X(LCHARGE-1+IAT)-ZAN(KATOM(I))).LT.1.0D-08) THEN
              COPYSHELL=.TRUE.
              GOTO 90
           ENDIF
        ENDDO
   90   CONTINUE
        IF(COPYSHELL) THEN
C
C         ---- ADD NEW SHELL WITHOUT UNCONTRACTION
C
          NCOPIED=NCOPIED+1
          IND=KSTART(I)
          NEXP=INDU+1
          NSHELLU=NSHELLU+1
          DO J=1,KNG(I)
            MAPLE(IND+J-1)=NEXP+J-1
            LARCH(INDU+J-1)=NSHELLU
C           LARCH IS SEMI-BOGUS BUT IT SHOULN'T BE REQUESTED HENCE
          ENDDO
          KSTARTU(NSHELLU)=NEXP
          KATOMU(NSHELLU)=KATOM(I)
          KTYPEU(NSHELLU)=KTYPE(I)
          KNGU(NSHELLU)=KNG(I)
          KLOCU(NSHELLU)=KMM+KLOCU0
          KMINU(NSHELLU)=KMIN(I)
          KMAXU(NSHELLU)=KMAX(I)
          KLOCU0=KLOCU(NSHELLU)
          KMM=KMAXU(NSHELLU)-KMINU(NSHELLU)+1
          NUMU=NUMU+KMM
          CALL DCOPY(KNG(I),EX(IND),1,EXU(NEXP),1)
          CALL DCOPY(KNG(I),CS(IND),1,CSU(NEXP),1)
          CALL DCOPY(KNG(I),CP(IND),1,CPU(NEXP),1)
          CALL DCOPY(KNG(I),CD(IND),1,CDU(NEXP),1)
          CALL DCOPY(KNG(I),CF(IND),1,CFU(NEXP),1)
          CALL DCOPY(KNG(I),CG(IND),1,CGU(NEXP),1)
          INDU=INDU+KNG(I)
          DO K=0,KMAX(I)-KMIN(I)
            X(LUU-1+ (KLOCU(NSHELLU)+K -1)*L1 + KLOC(I)+K)=ONE
          ENDDO
          GOTO 200
        ENDIF
C       LLOOP SPLITS L-SHELLS IN THE INTERNALLY UNCONTRACTED BASI SET
        LSHELL=KTYPE(I).EQ.2.AND.KMIN(I).EQ.1
        LOOPS=LUNCON
        IF(.NOT.LSHELL) LOOPS=0
        DO J=1,KNG(I)
          IND=J-1+KSTART(I)
        DO 190 LLOOP=0,LOOPS
          NEXP=INDU+1
          IF(LUNCON.NE.0.AND.LSHELL) THEN
            IF(LLOOP.EQ.0) THEN
              CSSAVE=CS(IND)
              CPSAVE=CP(IND)
              KTYPE(I)=1
              KMIN(I)=1
              KMAX(I)=1
              CP(IND)=ZERO
              IF(ABS(CSSAVE).LT.TINY) THEN
C                DO NOT ADD PRIMITIVES WITH ZERO COEFFICIENTS
                 NGHOST=NGHOST+1
                 GOTO 190
              ENDIF
            ENDIF
            IF(LLOOP.EQ.1) THEN
              KTYPE(I)=2
              KMIN(I)=2
              KMAX(I)=4
              CS(IND)=ZERO
              CP(IND)=CPSAVE
              IF(ABS(CPSAVE).LT.TINY) THEN
                 NGHOST=NGHOST+1
                 GOTO 190
              ENDIF
            ENDIF
          ENDIF
          ADDPRIM=.TRUE.
          ADDSHELL=.TRUE.
          DO IT=1,NT
C         SEARCH IF THE SHELL IS A COPY OF A SYMMETRY UNIQUE ONE
            IF(MAPSHL(I,IT).LT.I) THEN
              NEXP=MAPLE(J-1+KSTART(MAPSHL(I,IT)))
              ADDPRIM=.FALSE.
              IF(NEXP.LT.0) THEN
                ADDSHELL=.FALSE.
                II=LARCH(NEXP)
                NEXP=-NEXP
              ENDIF
              NEXP=NEXP+LLOOP
C             MAPLE POINTED TO S SHELL, AND P COMES NEXT
              GOTO 100
            ENDIF
          ENDDO
  100     CONTINUE
          DO K=1,NSHELLU
C         SEARCH IF THE PRIMITIVE HAS ALREADY BEEN STORED
            IF(ABS(EX(IND)-EXU(KSTARTU(K))).LT.1.0D-08.AND.
     *         (KMIN(I).EQ.KMINU(K).OR.KMAX(I).EQ.KMAXU(K)).AND.
     *         KATOM(I).EQ.KATOMU(K)) THEN
              NEXP=KSTARTU(K)
              II=K
              ADDPRIM=.FALSE.
              ADDSHELL=.FALSE.
              GOTO 110
            ENDIF
          ENDDO
  110     CONTINUE
C
C         MAPLE MAPS THE CONTRACTED PRIMITIVES INTO UNCONTRACTED
C         POSITIVE INDICATES THAT THE PRIMITIVE NEEDS TO BE ADDED FOR
C         SYMMETRY RELATED ATOMS.
C
          IF(ADDSHELL) THEN
C
C           ---- ADD NEW UNCONTRACTED SHELL
C
            IF(LLOOP.EQ.0) MAPLE(IND)=NEXP
C           FOR L-SHELLS MAPLE POINTS TO S SHELL. P ALWAYS COMES NEXT.
            NSHELLU=NSHELLU+1
            KSTARTU(NSHELLU)=NEXP
            KATOMU(NSHELLU)=KATOM(I)
            KTYPEU(NSHELLU)=KTYPE(I)
            KNGU(NSHELLU)=1
            KLOCU(NSHELLU)=KMM+KLOCU0
            KMINU(NSHELLU)=KMIN(I)
            KMAXU(NSHELLU)=KMAX(I)
            KLOCU0=KLOCU(NSHELLU)
            KMM=KMAXU(NSHELLU)-KMINU(NSHELLU)+1
            NUMU=NUMU+KMM
            II=NSHELLU
            IF(ADDPRIM) THEN
C
C           --- ADD NEW UNCONTRACTED PRIMITIVE
C
              INDU=INDU+1
C             LARCH CONTAINS THE NUMBER OF THE SHELL FOR A PRIMITIVE
              LARCH(INDU)=NSHELLU
              EXU(INDU)=EX(IND)
C             PRIMITIVE COEFFICIENTS ARE NORMALISED ONES
              IF(NORMP .NE. 1) THEN
                EE = EX(IND)+EX(IND)
                FACS = PI32/(EE*SQRT(EE))
                FACP = HALF*FACS/EE
                FACD = PT75*FACS/(EE*EE)
                FACF = PT187*FACS/(EE**3)
                FACG = PT6562*FACS/(EE**4)
                CSU(INDU) = ONE/SQRT(FACS)
                CPU(INDU) = ONE/SQRT(FACP)
                CDU(INDU) = ONE/SQRT(FACD)
                CFU(INDU) = ONE/SQRT(FACF)
                CGU(INDU) = ONE/SQRT(FACG)
              ELSE
                CSU(INDU) = ONE
                CPU(INDU) = ONE
                CDU(INDU) = ONE
                CFU(INDU) = ONE
                CGU(INDU) = ONE
              ENDIF
              IF(CS(IND).EQ.ZERO) CSU(INDU)=ZERO
              IF(CP(IND).EQ.ZERO) CPU(INDU)=ZERO
              IF(CD(IND).EQ.ZERO) CDU(INDU)=ZERO
              IF(CF(IND).EQ.ZERO) CFU(INDU)=ZERO
              IF(CG(IND).EQ.ZERO) CGU(INDU)=ZERO
            ENDIF
          ELSE
            NREDUN=NREDUN+1
            MAPLE(IND)=-NEXP
C           II=LARCH(NEXP)
            IF(KMIN(I).NE.KMINU(II).OR.KMAX(I).NE.KMAXU(II)) THEN
              WRITE(IW,9000) I,NEXP
              CALL ABRT
C
C         THIS IS NOT A REAL DEAD END, BUT MORE CODE NEEDS TO BE WRITTEN
C         FOR THE CASE WHEN THE RADIAL PARTS OVERLAP, SUCH AS WHEN
C         AN L-SHELL OVERLAPS WITH AN S OR P-SHELL, IN WHICH CASE THE
C         L-SHELL NEEDS TO BE SPLIT INTO S AND P AND THEN THE REDUNDANT
C         RADIAL PART THROWN AWAY.
C
              ENDIF
          ENDIF
C
C         A) FOR REDUNDANT AOS (GIVEN AN ATOM), POINT TO THE FIRST ONE
C         B) FOR SYMMETRY RELATED ONES, POINT TO THE CORRECT AO
C            (WITHOUT IF(ADDSHELL) WE WOULD POINT TO UNIQUE PRIMITIVE)
C         SECOND LOOP (LABEL 110) GIVES HIGHER PRIORITY TO A).
C
          IF(NEXP.EQ.0) CALL ABRT
          DO K=0,KMAX(I)-KMIN(I)
           IF(KTYPE(I).EQ.1.OR.(LSHELL.AND.K.EQ.0.AND.LUNCON.EQ.0)) THEN
              DUM=CS(IND)/CSU(NEXP)
            ELSE IF (KTYPE(I).EQ.2) THEN
              DUM=CP(IND)/CPU(NEXP)
            ELSE IF (KTYPE(I).EQ.3) THEN
              DUM=CD(IND)/CDU(NEXP)
            ELSE IF (KTYPE(I).EQ.4) THEN
              DUM=CF(IND)/CFU(NEXP)
            ELSE IF (KTYPE(I).EQ.5) THEN
              DUM=CG(IND)/CGU(NEXP)
            ENDIF
C           WE SAVE TRASPOSE MATRIX BECAUSE THE ROW DIMENSION LU1 CAN
C           CHANGE. NEED U(LU1,L1), BUT SAVE U(L1,LU1)
C           IN PLAIN FORTRAN, U(KLOC(I)+K,KLOCU(II)+K0)=DUM
            K0=K
            IF(LSHELL.AND.LUNCON.NE.0.AND.LLOOP.EQ.1) K0=K0+1
            X(LUU-1+ (KLOCU(II)+K -1)*L1 + KLOC(I)+K0)=DUM
          ENDDO
          IF(LUNCON.NE.0.AND.LSHELL.AND.LLOOP.EQ.1) THEN
            CS(IND)=CSSAVE
            CP(IND)=CPSAVE
            KTYPE(I)=2
            KMIN(I)=1
            KMAX(I)=4
          ENDIF
  190 CONTINUE
        ENDDO
  200 CONTINUE
      IF(NUMU.LT.NUM) THEN
         WRITE(IW,*) 'FAILURE IN UNCONTRACTION?',NUM,NUMU
         CALL ABRT
C        NOTE: WE DO ASSUME IN STORAGE ALLOCATION THE OPPOSITE RELATION
      ENDIF
      IF(MASWRK) THEN
         WRITE(IW,9010) NSHELLU,NUMU,NSHELL,NUM
         IF(NREDUN.NE.0)  WRITE(IW,9020) NREDUN
         IF(NCOPIED.NE.0) WRITE(IW,9030) NCOPIED
         IF(NGHOST.NE.0) WRITE(IW,9040) NGHOST
      ENDIF
C     WRITE(6,*) 'DBG EX',(EXU(I),I=1,INDU),'CS',(CSU(I),I=1,INDU),'CP',
C    *           (CPU(I),I=1,INDU),'CD',(CDU(I),I=1,INDU),'CF',
C    *           (CFU(I),I=1,INDU),'CG',(CGU(I),I=1,INDU),'KSTART',
C    *           (KSTARTU(I),I=1,INDU),'KATOM',(KATOMU(I),I=1,INDU),
C    *           'KTYPE',(KTYPEU(I),I=1,INDU),'KNG',(KNGU(I),I=1,INDU),
C    *           'KLOC',(KLOCU(I),I=1,INDU),'KMIN',(KMINU(I),I=1,INDU),
C    *           'KMAX',(KMAXU(I),I=1,INDU)
C     CALL PRSQ(X(LUU),NUMU,L1,L1)
      CALL TRPOSE(X(LUU),X(LUU1),L1,NUMU,0)
      CALL RELSAVEU(15,EX,CS,CP,CD,CF,CG,KSTART,KATOM,KTYPE,
     *                    KNG,KLOC,KMIN,KMAX,NSHELL)
      CALL RELSAVEU(17,EXU,CSU,CPU,CDU,CFU,CGU,KSTARTU,KATOMU,KTYPEU,
     *                    KNGU,KLOCU,KMINU,KMAXU,NSHELLU)
      CALL DAWRIT(IDAF,IODA,X(LUU1),NUMU*L1,NDARELB+19,0)
      CALL RETFM(NEED)
      RETURN
 9000 FORMAT('ALAS, YOUR BASIS SET HAS SAME EXPONENTS WITH DIFFERENT',/,
     *     'RADIAL PARTS (CONTRACTED SHELL',I4,' AND PRIMITIVE',I4,').',
     *      /,'IF THE OFFENDING SHELL IS OF L TYPE, USE L-SHELL',
     *      /,'INTERNAL SPLITTING, ADD 4 TO OPRESC IN $RELWFN *AND* ',
     *      /,'PUT L-SHELLS BEFORE S AND P FOR EACH ATOM.',/)
 9010 FORMAT(/1X,'INTERNAL BASIS SET UNCONTRACTION FOR RESC/DK:',/,
     *       I6,' SHELLS AND ',I6,' AOS ARE CONSTRUCTED, COMPARED TO',/,
     *       I6,' SHELLS AND ',I6,' AOS IN THE CONTRACTED BASIS SET',/)
 9020 FORMAT(I6,' REDUNDANT PRIMITIVE(S) ELIMINATED.',/)
 9030 FORMAT(I6,' SHELL(S) COPIED FOR NON-RELATIVISTIC ATOMS.',/)
 9040 FORMAT(I6,' SHELL(S) REMOVED BECAUSE OF ZERO COEFFICIENTS.',/)
      END
