C  4 MAR 08 - DGF - RHFLAG: FIX SHAPE OF MATRIX MULTIPLY
C 20 AUG 07 - LBR - FIX SHELL TYPES SO L-SHELL TRUNCATION WORKS AGAIN
C  6 NOV 06 - MWS - ADJUST WAVEFUNCTION COMMON BLOCK
C 19 SEP 05 - MWS - ADD TRUE NUCLEAR CHARGE ARRAY TO INFOA COMMON
C  5 JUL 05 - MWS - SELECT NEW ATOM,BASIS,EFP,PCM,DAF DIMENSIONS
C 13 FEB 05 - MWS - PAD COMMON BLOCK NSHEL, EDCMP
C  9 DEC 03 - MWS - SYNCH COMMON BLOCK RUNOPT
C  6 SEP 01 - MWS - ADD DUMMY ARGUMENTS TO NAMEIO CALL
C 25 JUN 01 - MWS - ALTER COMMON BLOCK WFNOPT
C 13 JUN 01 - HL  - TRNCIN,MOIDBF: ASSIGN CORRECT CHARGES TO CAP ATOMS
C 19 NOV 00 - RMM - PAD OUT EDCMP COMMON, REMOVE PARALLEL BUGS
C 26 OCT 00 - MWS - INTRODUCE MXAO PARAMETER
C 11 JUN 00 - MWS - SYNCH UP BASISC COMMON
C 16 FEB 00 - VK  - NEW MODULE RELATED TO MO FREEZING AND QM/MM
C
C*MODULE EFPCOV  *DECK ARRCHK
      SUBROUTINE ARRCHK(IA,NUM)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      DIMENSION IA(*)
C
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
C     ---- CHECK FOR REPETITIVE IA  ELEMENTS ----
C            ALSO CHECK FOR ZERO ELEMENTS
C
      DO 100 I=1,NUM
        IF(IA(I) .EQ. 0) THEN
           IF (MASWRK) WRITE(IW,9300) I
           CALL ABRT
           STOP
        END IF
        DO 200 J=1,I-1
           IF(IA(J) .EQ. IA(I)) THEN
              IF (MASWRK) WRITE(IW,9400)
              CALL ABRT
              STOP
           END IF
 200    CONTINUE
 100  CONTINUE
      RETURN
 9300 FORMAT(/1X,'ERROR IN ARRCHK: ELEMENT NUMBER ',I4,' IS ZERO')
 9400 FORMAT(/1X,'ERROR IN ARRCHK: REPETITIVE ELEMENTS')
       END
C*MODULE EFPCOV  *DECK BAKORD
      SUBROUTINE BAKORD(EIG,V,IWRK,NDIM)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION EIG(NDIM),V(NDIM,NDIM),IWRK(NDIM)
C
C     REORDER EIGENVALUES AND EIGENVECS SO THAT THE HIGHEST ONES GO 1ST
C
      DO 100 I=1,NDIM
           IWRK(I)=NDIM+1-I
 100  CONTINUE
      CALL REORDR(V,IWRK,NDIM,NDIM)
      DO 200 I=1,NDIM
           IWRK(I)=NDIM+1-I
 200  CONTINUE
      CALL REORDR(EIG,IWRK,NDIM,1)
      RETURN
      END
C*MODULE EFPCOV  *DECK CNTNZ
      SUBROUTINE CNTNZ(IA,NONZ,NDIM)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION IA(*)
C
C     ---- COUNT ELEMENTS GREATER THAN ZERO IN IA  ----
C     THE NUMBER OF .GT. 0  ELEMENTS IS RETURND AS NONZ.
C     NDIM IS A DIMENSION OF 1-D ARRAY IA.
C     ALSO, IF AN ELEMENT OF AN ARRAY IS LT 0
C     IT IS EQUATED TO 0.
C
      NONZ=0
      DO 100 I=1,NDIM
      IF (IA(I) .GT. 0) NONZ=NONZ+1
      IF (IA(I) .LT. 0) IA(I) = 0
 100  CONTINUE
      RETURN
      END
C*MODULE EFPCOV  *DECK DENDBF
      SUBROUTINE DENDBF(DA,DB,DBF,VEC,OCC,NBUFFM,L1,L2,L3)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      PARAMETER (ONE=1.0D+00,TWO=2.00D+00)
C
      COMMON /IOFILE/ IR,IW,IP,IJK,IPK,IDAF,NAV,IODA(950)
      COMMON /WFNOPT/ SCFTYP,VBTYP,DFTYPE,TDDFTYP,CITYP,CCTYP,
     *                MPLEVL,MPCTYP
C
      DIMENSION DA(L2),DB(L2),DBF(L2),VEC(L3),OCC(NBUFFM)
C
      DATA RHF,RMC/8HRHF     ,8HMCSCF   /
      DATA RNONE/8HNONE    /
C
C     CALCULATES TOTAL DENSITY MINUS DENSITY OF THE BUFFER MO-S
C     ADAPTED FROM DENDD1 SUBROUTINE
C
      OCCN=ONE
      IF(SCFTYP.EQ.RHF .OR. SCFTYP.EQ.RMC .OR. CITYP.NE.RNONE) OCCN=TWO
C
C     IN OUR IMPLEMENTATION BUFFER ORBS ARE LIKE CORE ORBITALS, THUS THE
C     OCCUPATION NUMBERS ARE THE SAME FOR BOTH NA AND NB
C
      DO I=1,NBUFFM
        OCC(I)=OCCN
      END DO
C
      CALL DAREAD(IDAF,IODA,VEC,L3,15,0)
      CALL DMTX(DBF,VEC,OCC,NBUFFM,L1,L1)
      CALL DAREAD(IDAF,IODA,DA,L2,16,0)
      CALL VSUB(DBF,1,DA,1,DA,1,L2)
      IF(SCFTYP.EQ.RHF)  RETURN
      IF(SCFTYP.EQ.RMC)  RETURN
      IF(CITYP.NE.RNONE) RETURN
C
      CALL DAREAD(IDAF,IODA,VEC,L3,19,0)
      CALL DMTX(DBF,VEC,OCC,NBUFFM,L1,L1)
      CALL DAREAD(IDAF,IODA,DB,L2,20,0)
      CALL VSUB(DBF,1,DB,1,DB,1,L2)
C
C        RETURN TOTAL DENSITY IN -DA-
C
      CALL VADD(DA,1,DB,1,DA,1,L2)
      RETURN
      END
C*MODULE EFPCOV  *DECK FRFOCK
      SUBROUTINE FRFOCK(A,NA)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      LOGICAL MFRZ
      DIMENSION A(*)
      PARAMETER (MXAO=8192)
      PARAMETER (ZERO=0.0D+00)
      COMMON /MFRPAR/ MFRZ,NUMFRZ,IFRZ(MXAO)
C
C     ZEROING OUT IN FIRST NUMFRZ ROWS AND COLS
C     THE OFF-DIAGONAL TRIAGONAL MATRIX A ELEMENTS
C     CORRESPONDING TO THE NUMFRZ FROZEN ORBITALS
C
      IJ=1
      DO 200 I=1,NA
         DO 100 J=1,I
            IF(I.GT.NUMFRZ .AND. J.GT.NUMFRZ) GO TO 50
            IF(I.NE.J) A(IJ) = ZERO
   50       IJ = IJ + 1
  100    CONTINUE
  200 CONTINUE
      RETURN
      END
C*MODULE EFPCOV  *DECK INAMAX
      INTEGER FUNCTION INAMAX(N,IDX,INCX)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION IDX(1)
C
C     FINDS THE INDEX OF ELEMENT HAVING MAX. ABSOLUTE VALUE.
C     JACK DONGARRA, LINPACK, 3/11/78.
C     IT IS ROUTINE IDAMAX FROM BLAS MODULE
C     SLIGTHLY MODIFIED FOR INTEGER ARRAYS
C
      INAMAX = 0
      IF( N .LT. 1 ) RETURN
      INAMAX = 1
      IF(N.EQ.1)RETURN
      IF(INCX.EQ.1) GO TO 20
C
C        CODE FOR INCREMENT NOT EQUAL TO 1
C
      IX = 1
      IRMAX = ABS(IDX(1))
      IX = IX + INCX
      DO 10 I = 2,N
         IF(ABS(IDX(IX)).LE.IRMAX) GO TO 5
         INAMAX = I
         IRMAX = ABS(IDX(IX))
    5    IX = IX + INCX
   10 CONTINUE
      RETURN
C
C        CODE FOR INCREMENT EQUAL TO 1
C
   20 IRMAX = ABS(IDX(1))
      DO 30 I = 2,N
         IF(ABS(IDX(I)).LE.IRMAX) GO TO 30
         INAMAX = I
         IRMAX = ABS(IDX(I))
   30 CONTINUE
      RETURN
      END
C*MODULE EFPCOV  *DECK MFRZIN
      SUBROUTINE MFRZIN
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL MFRZ,GOPARR,DSKWRK,MASWRK
C
      PARAMETER (NNAM=2, MXATM=2000, MXAO=8192)
C
      DIMENSION QNAM(NNAM),KQNAM(NNAM)
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 /MFRPAR/ MFRZ,NUMFRZ,IFRZ(MXAO)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
C
C     ----- SET UP $MOFRZ NAMELIST -----
C
      DATA DMOFRZ/8HMOFRZ   /
      DATA QNAM/8HFRZ     ,8HIFRZ    /
      DATA KQNAM/0,-1/
C
      KQNAM(2) = MXAO*10 + 1
      MFRZ = .FALSE.
      NUMFRZ = 0
      CALL VICLR(IFRZ,1,MXAO)
C
C     ----- READ IN $MOFRZ NAMELIST -----
C
C    FRZ IS READ IN INTO MFRZ LOGICAL VARIABLE
      JRET = 0
      CALL NAMEIO(IR,JRET,DMOFRZ,NNAM,QNAM,KQNAM,
     *            MFRZ,IFRZ,
     *            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,0,0)
      IF (JRET .EQ. 2) THEN
         IF (MASWRK) WRITE (IW,9000)
         CALL ABRT
      END IF
      IF(.NOT.MFRZ) RETURN
C
C     COUNT THE NUMBER OF GREATER THAN ZERO ELEMENTS IN NUMFRZ
C
      IF(MFRZ) THEN
         NUMFRZ=0
         DO 100 I=1,MXAO
           IF(IFRZ(I).GT.0)NUMFRZ=NUMFRZ+1
           IF(IFRZ(I).LT.0)IFRZ(I)=0
 100     CONTINUE
         IF(NUMFRZ.LE.0)THEN
            IF (MASWRK) WRITE (IW,9050)
            CALL ABRT
         END IF
      END IF
C
C     NOW CHECK IF ANY OF FIRST NUMFRZ ELEMENTS IN IFRZ ARRAY ARE
C     ZEROES OR IF THERE ARE REPETITIVE ELEMENTS
C
      IF(MFRZ) THEN
          DO 200 I=1,NUMFRZ
            IF(IFRZ(I) .EQ. 0) THEN
               IF (MASWRK) WRITE(IW,9300) I
               CALL ABRT
            END IF
            DO 300 J=1,I-1
              IF(IFRZ(J) .EQ. IFRZ(I)) THEN
                 IF (MASWRK) WRITE(IW,9400)
                 CALL ABRT
              END IF
 300        CONTINUE
 200     CONTINUE
C
C     NOW DO SOME OTHER CHECKS
C
          IDM = INAMAX(NUMFRZ,IFRZ,1)
          IGRTST = IFRZ(IDM)
          IF(IFRZ(IDM).GT.NUM) THEN
            IF (MASWRK) WRITE(IW,9500) IGRTST
            CALL ABRT
          END IF
          IF(NUMFRZ.GT.NB) THEN
            IF (MASWRK) WRITE(IW,9600)
            CALL ABRT
          END IF
      END IF
      IF(MFRZ) THEN
         IF(MASWRK) THEN
            WRITE(IW,9100)
            WRITE(IW,9200) NUMFRZ
            WRITE(IW,9230)
            WRITE(IW,9240) (IFRZ(J),J=1,NUMFRZ)
            WRITE(IW,9250)
         END IF
      END IF
      RETURN
C
 9000 FORMAT(/1X,'ERROR IN $MOFRZ INPUT - STOP')
 9050 FORMAT(/1X,'FRZ=.T. IN $MOFRZ, BUT NO MO-S ARE FROZEN')
 9100 FORMAT(/1X,'**** MO FREEZING IN EFFECT ****')
 9200 FORMAT(/1X,I4,' ORBITAL(S) FROZEN')
 9230 FORMAT(/1X,'THEIR NUMBERS IN THE ORIGINAL MO SET ARE:')
 9240 FORMAT(1X,10I4)
 9250 FORMAT(/1X,'THE FROZEN MO-S WILL BE KEPT *FIRST* ',
     *           'IN THE MO MATRIX'/
     *        1X,'IN THE SUBSEQUENT CALCULATIONS')
 9300 FORMAT(/1X,'ERROR: CHECK IFRZ ELEMENT NUMBER ',I4,' IN INPUT')
 9400 FORMAT(/1X,'ERROR: YOU HAVE REPETITIVE ELEMENTS IN IFRZ ARRAY')
 9500 FORMAT(/1X,'THE LARGEST ELEMENT IN IFRZ IS GREATER ',
     *           'THAN THE NUMBER OF BASIS FUNCTIONS')
 9600 FORMAT(/1X,'SORRY, YOU SPECIFIED MORE FROZEN ORBITALS',
     *           'THAN THERE ARE CLOSED SHELL ORBITALS IN THE SYSTEM.'/
     *        1X,'ONLY THE CLOSED SHELLS CAN BE FROZEN AT THE MOMENT.')
      END
C*MODULE EFPCOV  *DECK RAFR
      SUBROUTINE RAFR(NROWS,NCOLS,A,IWRK)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION A(NROWS,NCOLS),IWRK(NCOLS)
      PARAMETER (MXAO=8192)
      LOGICAL MFRZ
      COMMON /MFRPAR/ MFRZ,NUMFRZ,IFRZ(MXAO)
C
C     REARRANGES MATRIX A (DIMENSION NROWS, NUMBER OF
C     VECTORS NCOLS) SO THAT THE ORBITALS (VECTORS) SPECIFIED
C     IN IFRZ ARRAY GO FIRST.
C
      DO 100 I = 1, NUMFRZ
          IWRK(I) = IFRZ(I)
  100 CONTINUE
      IJ = 0
      DO 400 I=NUMFRZ + 1, NCOLS
  222    IJ=IJ + 1
         DO 300 II = 1, NUMFRZ
           IF(IJ .EQ. IFRZ(II)) GO TO 222
  300    CONTINUE
             IWRK(I) = IJ
  400 CONTINUE
      CALL REORDR(A,IWRK,NCOLS,NROWS)
      RETURN
      END
C*MODULE EFPCOV  *DECK RHFLAG
      SUBROUTINE RHFLAG(F,D,XL,SCR,L1,L2,L3,OUT)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL OUT
C
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
C
      DIMENSION F(L2),D(L2),XL(L3),SCR(L1)
C
      PARAMETER (HALF=0.5D+00)
C
C-----RHF WAVEFUNCTION LAGRANGIAN-----
C     USEFUL IF THE FOCK MATRIX
C     IS NON DIAGONAL
C     SUCH AS IN THE FROZEN MO CASE.
C     ANALOGOUS TO GAMESS ROLAG ROUTINE
C
      CALL CPYTSQ(D,XL,L1,1)
      CALL TFTRI(D,F,XL,SCR,L1,L1,L1)
      CALL DSCAL(L2,-HALF,D,1)
      CALL DCOPY(L2,D,1,XL,1)
      CALL DAWRIT(IDAF,IODA,XL,L2,36,0)
C
      IF(OUT) THEN
         WRITE (IW,9000)
         CALL PRTRI(XL,L1)
      END IF
      RETURN
C
C
 9000 FORMAT(//20X, 'RHF LAGRANGIAN')
      END
C*MODULE EFPCOV  *DECK TRNCIN
      SUBROUTINE TRNCIN
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL DOPROJ,PLAIN,GOPARR,DSKWRK,MASWRK,AUTOID,
     *        MOIDON,EDCOMP,DIPDCM,DEPRNT,QADDCM,ZDO,POLDCM,
     *        POLANG,POLAPP,KMIDPT,POLDYN
C
      PARAMETER (NNAM=13, MXATM=2000, NMO=500, MXAO=8192)
      PARAMETER (ZTOL=1.00D-05,ZERO=0.00D+00)
C
      DIMENSION QNAM(NNAM),KQNAM(NNAM),IXCORL(500),IXLONE(500)
      DIMENSION NUMCOR(103)
C
      COMMON /ECP2  / CLP(400),ZLP(400),NLP(400),KFIRST(MXATM,6),
     *                KLAST(MXATM,6),LMAX(MXATM),LPSKIP(MXATM),
     *                IZCORE(MXATM)
      COMMON /EDCMP / ZIJ(NMO),ZMO(5,NMO),OCCUP(NMO),DPFREQ(50),
     *                MOIDNO(5,NMO),IJMO(2,NMO),MOIJ(NMO),NMOIJ(NMO),
     *                NMOAT(NMO),NDPFREQ,IPROT(5),NPROT,
     *                MOIDON,EDCOMP,DIPDCM,DEPRNT,QADDCM,ZDO,POLDCM,
     *                POLANG,POLAPP,KMIDPT,POLDYN
      COMMON /EFPBF2/ QBORD(500)
      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 /PROJ  / DOPROJ,PLAIN,NPUNOP,NMOPR,NZAT,NLAT,IMOPR(MXAO),
     *                IZAT(500),ILAT(500),NATAB,NATBF,NCAPBK,ICAPBK(10),
     *                NCAPFR,ICAPFR(10)
      COMMON /PRPOPT/ ILOCAL
C
C     ----- SET UP $TRUNCN NAMELIST -----
C
      DATA DPROJ /8HTRUNCN  /
      DATA QNAM/8HDOPROJ  ,8HIZAT    ,8HIMOPR   ,8HNPUNOP  ,8HILAT    ,
     *          8HPLAIN   ,8HNATAB   ,8HNATBF   ,8HICAPBK  ,8HICAPFR  ,
     *          8HAUTOID  ,8HIXCORL  ,8HIXLONE  /
      DATA KQNAM/0,5001,-1,1,5001,0,1,1,101,101,0,5001,5001/
      DATA NUMCOR/2*0,  8*1,  8*5,  2*9,10*9,6*14,  2*18,10*18,6*23,
     *            2*27,14*27,10*34,6*39,   2*43,14*43,50/
C
      KQNAM(3) = MXAO*10 + 1
      DOPROJ = .FALSE.
      PLAIN = .FALSE.
C    AUTOID=.T. WILL ASSUME THAT ORBITALS ARE LOCALIZED
      AUTOID = .FALSE.
C      IF(ILOCAL.EQ.0)PLAIN=.TRUE.
      NZAT = 0
      NLAT = 0
      NMOPR = 0
      NPUNOP = 2
      NATAB = 0
      NATBF = 0
      NCAPBK = 0
      NCAPFR = 0
      NXCORL = 0
      NXLONE = 0
      CALL VICLR(IZAT,1,500)
      CALL VICLR(ILAT,1,500)
      CALL VICLR(IMOPR,1,MXAO)
      CALL VICLR(ICAPBK,1,10)
      CALL VICLR(ICAPFR,1,10)
      CALL VICLR(IXCORL,1,500)
      CALL VICLR(IXLONE,1,500)
C
C     ----- READ IN $MOFRZ NAMELIST -----
C
      JRET = 0
      CALL NAMEIO(IR,JRET,DPROJ,NNAM,QNAM,KQNAM,
     *            DOPROJ,IZAT,IMOPR,NPUNOP,ILAT,PLAIN,NATAB,NATBF,
     *            ICAPBK,ICAPFR,AUTOID,IXCORL,IXLONE,
     *            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
         STOP
      END IF
      IF(.NOT. DOPROJ) RETURN
C
C     COUNT GREATER THAN 0  ELEMENTS IN ARRAYS IZAT,ILAT AND IMOPR
C
        CALL CNTNZ(IZAT,NZAT,500)
        CALL CNTNZ(ILAT,NLAT,500)
        CALL CNTNZ(IMOPR,NMOPR,MXAO)
        CALL CNTNZ(ICAPBK,NCAPBK,10)
        CALL CNTNZ(ICAPFR,NCAPFR,10)
        CALL CNTNZ(IXCORL,NXCORL,500)
        CALL CNTNZ(IXLONE,NXLONE,500)
C
C   IF THE POWER KEYWORDS NATAB AND NATBF BOTH ARE THERE,
C   THE PROGRAM WILL DETERMINE THE ORBITALS TO BE
C   TRUNCATED.
C
      IF(NATAB.EQ.0 .NEQV. NATBF.EQ.0)THEN
         IF (MASWRK) WRITE(IW,9640)
         CALL ABRT
         STOP
      END IF
      IF(NATAB.LT.0 .OR. NATBF.LT.0)THEN
         IF (MASWRK) WRITE(IW,9660)
         CALL ABRT
         STOP
      END IF
      NATAI=NATAB+NATBF
      IF(NATAI.EQ.0) GO TO 700
      IF(NATAI.GT.0 .AND. (NZAT.GT.0 .OR. NLAT.GT.0))THEN
         IF (MASWRK) WRITE(IW,9680)
         CALL ABRT
         STOP
      END IF
      IF(NATAI.GT.NAT)THEN
         IF (MASWRK) WRITE(IW,9600)NATAI,NAT
         CALL ABRT
         STOP
      END IF
      IF(NATAI.EQ.NAT)THEN
         IF (MASWRK) WRITE(IW,9620)
      END IF
      IF(NATAI.GT.0) GO TO 800
C
C   EXACTLY ONE OF NLAT AND NZAT  HAS TO BE ZERO
C
 700  IF (NZAT.EQ.0 .EQV. NLAT.EQ.0) THEN
         IF (MASWRK) WRITE(IW,9050)
         CALL ABRT
         STOP
      END IF
C
C   NOW, PROPERLY FILL THE IZAT AND NZAT ARRAYS
C
      IF(NZAT.EQ.0) THEN
         NZAT = NAT - NLAT
         IZ=1
         DO 100 I=1,NAT
            ITAG=0
            DO 110 J=1,NLAT
              IF(ILAT(J).EQ.I)ITAG=1
 110        CONTINUE
            IF(ITAG.EQ.0) THEN
               IZAT(IZ)=I
               IZ=IZ+1
            END IF
 100     CONTINUE
      END IF
      IF(NLAT.EQ.0) THEN
         NLAT = NAT - NZAT
         IL=1
         DO 120 I=1,NAT
            ITAG=0
            DO 130 J=1,NZAT
              IF(IZAT(J).EQ.I)ITAG=1
 130        CONTINUE
            IF(ITAG.EQ.0) THEN
               ILAT(IL)=I
               IL=IL+1
            END IF
 120     CONTINUE
      END IF
C
C     MAKE WORKING WITH ALL OCCUPIED ORBITALS A DEFAULT FOR THE
C     CANONICAL (NONLOCALIZED) ORBITALS. IMOPR FOR LOCALIZED
C     ORBITALS WILL BE DETERMINED LATER.
C
      IF(NMOPR.EQ.0 .AND. ILOCAL.EQ.0)THEN
         DO 210 I = 1,NA
           IMOPR(I) = I
 210     CONTINUE
         NMOPR=NA
      END IF
C
C     NOW CHECK IF ANY OF THE FIRST NZAT, NLAT OR NMOPR ELEMENTS IN
C     IZAT,ILAT AND IMOPR ARRAYS, CORRESPONDINGLY, ARE
C     ZEROES OR IF THERE ARE REPETITIVE ELEMENTS
C
      IF(NZAT.GT.0) CALL ARRCHK(IZAT,NZAT)
      IF(NLAT.GT.0) CALL ARRCHK(ILAT,NLAT)
      IF(NMOPR.GT.0) CALL ARRCHK(IMOPR,NMOPR)
      IF(NCAPBK.GT.0) CALL ARRCHK(ICAPBK,NCAPBK)
      IF(NCAPFR.GT.0) CALL ARRCHK(ICAPFR,NCAPFR)
      IF(NXCORL.GT.0) CALL ARRCHK(IXCORL,NXCORL)
      IF(NXLONE.GT.0) CALL ARRCHK(IXLONE,NXLONE)
C
C     NOW DO SOME OTHER CHECKS AND SORT SEVERAL ARRAYS.
C     IMOPR ARRAY NEEDS NOT TO BE SORTED SINCE
C     IN PRINCIPLE ORDER OF MOS COULD BE
C     IMPORTANT IF THEY ARE FOR SOME REASON
C     NON-ORTHOGONAL, SAY, IN CASE OF PLAIN=.T.
C
      CALL SORTIN(IZAT,NZAT)
      CALL SORTIN(ILAT,NLAT)
      CALL SORTIN(ICAPBK,NCAPBK)
      CALL SORTIN(ICAPFR,NCAPFR)
      CALL SORTIN(IXCORL,NXCORL)
      CALL SORTIN(IXLONE,NXLONE)
      IF(NZAT.NE.0) THEN
         IGRTST = IZAT(NZAT)
         IF(IGRTST .GT. NAT) THEN
            IF (MASWRK) WRITE(IW,9300) IGRTST
            CALL ABRT
            STOP
         END IF
      END IF
      IF(NMOPR.NE.0) THEN
         IDM = INAMAX(NMOPR,IMOPR,1)
         IGRTST = IMOPR(IDM)
         IF(IGRTST .GT. NUM) THEN
            IF (MASWRK) WRITE(IW,9400) IGRTST
            CALL ABRT
            STOP
         END IF
      END IF
      IF(NLAT.NE.0) THEN
         IGRTST = ILAT(NLAT)
         IF(IGRTST .GT. NAT) THEN
            IF (MASWRK) WRITE(IW,9500) IGRTST
            CALL ABRT
            STOP
         END IF
      END IF
C
C   IF NATBF IS GIVEN, THE ATOMS IN THE BUFFER WILL
C   BE CONVERTED TO ILAT ARRAY
C
 800  CONTINUE
      IF(NATBF.GT.0)THEN
         NLAT=NATBF
         DO 400 I=1,NLAT
            ILAT(I)=NATAB+I
 400     CONTINUE
         NZAT=NAT-NLAT
         DO 410 I=1,NATAB
           IZAT(I)=I
 410     CONTINUE
         DO 420 I=1,NAT-NATAI
           IZAT(NATAB+I)=NATAI+I
 420     CONTINUE
      END IF
C
C   IF ILAT IS THERE AND THE LOCALIZATION IS ON
C   WE'LL DETERMINE WHICH LMOS ARE ON THOSE ATOMS.
C
      IF(EDCOMP) THEN
         IF (MASWRK) WRITE(IW,9070)
         CALL ABRT
         STOP
      END IF
C
C   NO NEED TO ID ORBITALS IN THE FOLLOWING CASE
      IF(NMOPR.GT.0 .AND. NATBF.GT.0) GO TO 501
C
CC      IF(.NOT.MOIDON .AND. ILOCAL .NE. 0) THEN
CC         IF (MASWRK) WRITE(IW,9080)
CC         CALL ABRT
CC         STOP
CC      END IF
CC 9080 FORMAT(/1X,'ORBITALS ARE LOCALIZED, BUT I DO''NT KNOW WHICH',
CC     *           ' ONES TO TRUNCATE.'/
CC     *        1X,'EITHER SPECIFY MOIDON=.T. IN $LOCAL, OR'/
CC     *        1X,'SPECIFY IMOPR IN $TRUNCN BY HAND')
C
C -----THIS WILL BE EXECUTED ONLY IF MOPR-S NEED TO BE IDENTIFIED-----
C -----BASED ON THE GIVEN ILAT ARRAY-----
C
      IF(ILOCAL .NE. 0 .AND. .NOT.MOIDON .AND. .NOT. AUTOID) THEN
         WRITE(IW,9071)
         AUTOID=.TRUE.
         CALL MOIDSM(71)
      END IF
      IF(ILOCAL .EQ. 0 .AND. AUTOID) THEN
         CALL MOIDSM(15)
      END IF
C  CORE ORBITAL COUNT
      NCORE=0
      DO 855 I=1,NAT
         IZ=INT(ZAN(I))+IZCORE(I)
         IF(IZ.LE.0) GO TO 855
         IF((IZ.GT.103).AND.MASWRK) WRITE(IW,*)
     *               'Z.GT.103 IN SETTING CORE COUNT'
         IF(IZ.GT.103) CALL ABRT
         NCORE = NCORE + NUMCOR(IZ) - IZCORE(I)/2
  855 CONTINUE
C
      IF(ILOCAL.GT.0 .OR. AUTOID)THEN
        CALL VICLR(IMOPR,1,MXAO)
        IC=1
        DO 500 I=1,NA
          IFCORL=0
          IFLONE=0
          IF(NMOAT(I).EQ.1) IFCORL=1
          IF((IFCORL .EQ. 1) .AND. (I .GT. NCORE) ) IFLONE=1
          DO 510 KK=1,NMOAT(I)
            IAA=MOIDNO(KK,I)
            ITAG=0
            DO 520 J=1,NLAT
              IF(IAA.EQ.ILAT(J))ITAG=1
 520        CONTINUE
            IF(ITAG.EQ.0) GO TO 500
 510      CONTINUE
          DO 530 J=1,NXCORL
             IF((IFCORL.EQ.1).AND.(MOIDNO(1,I).EQ.IXCORL(J))) GO TO 500
 530      CONTINUE
          DO 540 J=1,NXLONE
             IF((IFLONE.EQ.1).AND.(MOIDNO(1,I).EQ.IXLONE(J))) GO TO 500
 540      CONTINUE
          IMOPR(IC)=I
          IC=IC+1
 500    CONTINUE
        CALL CNTNZ(IMOPR,NMOPR,MXAO)
      END IF
C
C--------END OF MOID PIECE-----------
C
C
C  DETERMINE HOW MANY "VALENCIES" ARE INSIDE THE BUFFER REGION.
C  THIS WILL BE USEFUL WHEN TRYING TO DETERMINE AUTOMATICALLY
C  THE CHARGES ON CAPPING ATOMS ETC.
C  IN THIS CASE NMOPR IS NUMBER OF ORBS IN THE BUFFER
C
 501  IF (NATBF.GT.0) THEN
        CALL VCLR(QBORD,1,500)
        DO 730 IA=ILAT(1),ILAT(NATBF)
          PILEUP=ZERO
          DO 710 ICNT=1,NMOPR
            IM=IMOPR(ICNT)
            DO 720 IN=1,NMOAT(IM)
              IF(MOIDNO(IN,IM).EQ.IA)THEN
                PILEUP=PILEUP+ZMO(IN,IM)
              END IF
 720        CONTINUE
 710      CONTINUE
C
C       DOUBLE CHECK CHARGES ON CAPPING ATOMS.
C
          PILE02=ZERO
          DO 711 IM=1,NMO
            DO 721 IN=1,NMOAT(IM)
              IF(MOIDNO(IN,IM).EQ.IA)THEN
                PILE02=PILE02+ZMO(IN,IM)
              END IF
 721        CONTINUE
 711      CONTINUE
          IF ( ABS(PILE02-ZAN(IA) ) .GT. ZTOL ) THEN
            IF((PILE02-PILEUP).LT.1.5D+00)
     *          PILEUP=PILEUP-(PILE02-ZAN(IA))
          END IF
C
          IF ( ABS(PILEUP-ZAN(IA) ) .GT. ZTOL ) QBORD(IA)=PILEUP
 730    CONTINUE
        IF(NCAPFR.GT.0 .OR. NCAPBK.GT.0) GO TO 3000
C
C   THIS PIECE DETERMINE AUTOMATICALLY WHICH ATOMS ARE CAPPING. THAT IS,
C   IT DETERMINES WHICH CAPPING ATOMS ARE CONNECTED TO THE AB INITIO
C   REGION (ICAPFR), AND WHICH ARE CONNECTED TO THE EFP REGION (ICAPBK).
C
        NCAPBK=0
        NCAPFR=0
        DO 735 I=1,NAT
           IF(QBORD(I).LT.ZTOL) GO TO 735
           DO 745 IMO=1,NA
              IFBUF=0
              IFAB=0
              IFEFP=0
              INMOAT=NMOAT(IMO)
              DO 750 J=1,INMOAT
                IF(MOIDNO(J,IMO).EQ.I)IFBUF=1
 750          CONTINUE
              IF(IFBUF.EQ.1)THEN
                 DO 760 J=1,INMOAT
                    JIMO=MOIDNO(J,IMO)
                    IF(JIMO.NE.I)THEN
                       IF(JIMO.LE.NATAB)IFAB=1
                       IF(JIMO.GT.NATAI)IFEFP=1
                    END IF
 760             CONTINUE
                IF(IFAB.EQ.1 .AND. IFEFP.EQ.1) THEN
                  IF (MASWRK) WRITE(IW,9770)I
                  CALL ABRT
                  STOP
                END IF
                IF(IFAB.EQ.1) THEN
                   NCAPFR=NCAPFR+1
                   ICAPFR(NCAPFR)=I
                   GO TO 735
                END IF
                IF(IFEFP.EQ.1) THEN
                   NCAPBK=NCAPBK+1
                   ICAPBK(NCAPBK)=I
                   GO TO 735
                END IF
              END IF
 745       CONTINUE
 735    CONTINUE
      END IF
C
C   START INFORMATION OUTPUT
C
3000  IF(MASWRK) THEN
       WRITE(IW,9100)
       IF(PLAIN) THEN
          WRITE(IW,9110)
       ELSE
          WRITE(IW,9120)
       END IF
       WRITE(IW,9200) PLAIN,NPUNOP,NMOPR,(IMOPR(J),J=1,NMOPR)
       WRITE(IW,9250) NZAT,(IZAT(J),J=1,NZAT)
       WRITE(IW,9260) NLAT,(ILAT(J),J=1,NLAT)
       IF(NXCORL.GT.0) WRITE(IW,9262) NXCORL,(IXCORL(J),J=1,NXCORL)
       IF(NXLONE.GT.0) WRITE(IW,9264) NXLONE,(IXLONE(J),J=1,NXLONE)
       IF(NATAB.GT.0) THEN
          WRITE(IW,9700) NATAB,NATBF
          IF(NCAPBK.GT.0) WRITE(IW,9705)NCAPBK,(ICAPBK(J),J=1,NCAPBK)
          IF(NCAPFR.GT.0) WRITE(IW,9706)NCAPFR,(ICAPFR(J),J=1,NCAPFR)
          IF(NATBF.GT.0) THEN
            WRITE(IW,9702)
            DO 740 I=1,NAT
              IF(ABS( QBORD(I) ). GT. ZTOL) WRITE (IW,9703)I,QBORD(I)
 740        CONTINUE
          END IF
          WRITE(IW,9710)
       END IF
       IF(ILOCAL.EQ.0) THEN
          WRITE(IW,9270)
          IF(AUTOID) WRITE(IW,9275)
       ELSE
          WRITE(IW,9280)
       END IF
      END IF
      RETURN
C
 9000 FORMAT(/1X,'ERROR IN $TRUNCN INPUT - STOP')
 9050 FORMAT(/1X,'ERROR: EXACTLY ONE OF IZAT OR ILAT ARRAYS ',
     *           'SHOULD BE PRESENT IN $TRUNCN')
 9070 FORMAT(/1X,'TO PERFORM TRUNCATION, YOU MUST SWITCH OFF ',
     *           'EDCOMP IN $LOCAL')
 9071 FORMAT(/1X,'THE LOCALIZATION IS ON, BUT MOID IS OFF ',
     *           'THEREFORE AUTOID WILL BE SWITCHED ON')
 9100 FORMAT(/10X,60(1H*)/10X,'TRUNCATION (PARTIAL ZEROING OUT)',
     *       ' OF THE SELECTED MO-S.')
 9110 FORMAT(/10X,'''THE TAIL'' IS SIMPLY ZEROED OUT'
     *       /10X,60(1H*))
 9120 FORMAT(/10X,'''THE TAIL'' IS PROJECTED ONTO THE REST OF THE MO'
     *       /10X,60(1H*))
 9200 FORMAT(/10X,'TRUNCATION/PROJECTION PARAMETERS:'/
     *        10X,'PLAIN=',L5/
     *        10X,'NPUNOP=',I4/
     *        10X,'NMOPR =',I4/
     *        10X,'IMOPR =',(T18,10I4))
 9250 FORMAT(10X,'NZAT  =',I4/
     *        10X,'IZAT  =',(T18,10I4))
 9260 FORMAT(10X,'NLAT  =',I4/
     *        10X,'ILAT  =',(T18,10I4))
 9262 FORMAT(10X,'NXCORL=',I4/
     *        10X,'IXCORL=',(T18,10I4))
 9264 FORMAT(10X,'NXLONE=',I4/
     *        10X,'IXLONE=',(T18,10I4))
 9270 FORMAT(/10X,'LOCALIZATION IS OFF')
 9275 FORMAT(10X,'BUT YOU ARE ASKING TO PERFORM MO',
     *            ' AUTOIDENTIFICATION.'/
     *        10X,'PLEASE MAKE SURE YOUR GUESS MO-S ARE ALREADY',
     *            ' LOCALIZED')
 9280 FORMAT(/10X,'LOCALIZATION IS ON')
 9300 FORMAT(/1X,'THE LARGEST ELEMENT IN IZAT IS GREATER ',
     *           'THAN THE NUMBER OF ATOMS')
 9400 FORMAT(/1X,'THE LARGEST ELEMENT IN IMOPR IS GREATER ',
     *           'THAN THE NUMBER OF MO-S')
 9500 FORMAT(/1X,'THE LARGEST ELEMENT IN ILAT IS GREATER ',
     *           'THAN THE NUMBER OF ATOMS')
 9600 FORMAT(/1X,'ERROR IN $TRUNCN INPUT: NATAB+NATBF (',I2,
     *           ') IS GREATER THAN THE TOTAL NUMBER OF ATOMS (',I2,')')
 9620 FORMAT(/1X,'NATAB+NATBF IS EQUAL TO THE TOTAL NUMBER OF ATOMS.'
     *        /1X,'NO ''EFP'' ZONE ATOM REMOVAL WILL BE PERFORMED')
 9640 FORMAT(/1X,'ERROR IN $TRUNCN INPUT: ONE OF NATAB AND NATBF ',
     *           'IS EQUAL TO ZERO')
 9660 FORMAT(/1X,'ERROR IN $TRUNCN INPUT: NATAB OR NATBF ',
     *           'IS NEGATIVE')
 9680 FORMAT(/1X,'IN $TRUNCN, EITHER CHOOSE NATAB & NATBF KEYWORDS,'
     *       /1X,' OR ILAT & IZAT !!!')
 9700 FORMAT(/10X,'NATAB =',I4/
     *        10X,'NATBF =',I4)
 9702 FORMAT(10X,'THE FOLLOWING ''EFFECTIVE CHARGES'' INSIDE THE BUFFER'
     *      /10X,'WERE FOUND ON THE CAPPING ATOMS:')
 9703 FORMAT(10X,'ATOM =',I4,'  CHARGE=',F7.3)
 9705 FORMAT(10X, 'NCAPBK=',I4/
     *        10X,'ICAPBK=',(T18,10I4))
 9706 FORMAT(10X, 'NCAPFR=',I4/
     *        10X,'ICAPFR=',(T18,10I4))
 9710 FORMAT(/1X,'GAMESS WILL PUNCH OUT INPUT DECKS',
     *    ' TO PERFORM QM/MM (EFP) AND MAKEFP RUNS')
 9770 FORMAT(/1X,'IN TRNCIN: THE CAPPING ATOM ',I3,
     *    'IS CONNECTED TO BOTH AB INITIO AND EFP REGIONS. ABORTING.')
      END
C*MODULE EFPCOV  *DECK TRUNC
      SUBROUTINE TRUNC
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL DOPROJ,PLAIN,GOPARR,DSKWRK,MASWRK
C
      PARAMETER (MXAO=8192)
C
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /PROJ  / DOPROJ,PLAIN,NPUNOP,NMOPR,NZAT,NLAT,IMOPR(MXAO),
     *                IZAT(500),ILAT(500),NATAB,NATBF,NCAPBK,ICAPBK(10),
     *                NCAPFR,ICAPFR(10)
      COMMON /PRPOPT/ ILOCAL
C
C     ----- TRUNCATE/PROJECT-OUT A PART OF MO(S) -----
C
      CALL TRNCIN
      IF(DOPROJ)THEN
C     A CRUDE CHECK FOR UNWISE RUNTYP
          CALL DERCHK(NDER)
          IF(NDER.GT.0)THEN
              IF (MASWRK) WRITE(IW,9000)
              CALL ABRT
              STOP
          END IF
          IF(ILOCAL.EQ.0) IDAFV=15
          IF(ILOCAL.GT.0) IDAFV=71
          CALL TRUNCX(IDAFV)
      END IF
      RETURN
 9000 FORMAT(/1X,'USE RUNTYP=ENERGY OR PROP, IF POSSIBLE',
     *       ' IF YOU ARE DOING TRUNCATION')
      END
C*MODULE EFPCOV  *DECK TRUNCX
      SUBROUTINE TRUNCX(IDAFV)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL DOPROJ,PLAIN,DELCOL,QDONE,GOPARR,DSKWRK,MASWRK,DBG
C
      DIMENSION NUMCOR(103)
C
      PARAMETER (MXATM=2000, MXAO=8192)
      PARAMETER (ONE=1.0D+00, TOANGS = 0.52917724924D+00)
C
      COMMON /ATLIM / LIMLOW(MXATM),LIMSUP(MXATM)
      COMMON /ECP2  / CLP(400),ZLP(400),NLP(400),KFIRST(MXATM,6),
     *                KLAST(MXATM,6),LMAX(MXATM),LPSKIP(MXATM),
     *                IZCORE(MXATM)
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /PROJ  / DOPROJ,PLAIN,NPUNOP,NMOPR,NZAT,NLAT,IMOPR(MXAO),
     *                IZAT(500),ILAT(500),NATAB,NATBF,NCAPBK,ICAPBK(10),
     *                NCAPFR,ICAPFR(10)
      COMMON /RUNLAB/ TITLE(10),ANAM(MXATM),BNAM(MXATM),BFLAB(MXAO)
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      COMMON /FMCOM / X(1)
C
      DATA DEBUG/8HDEBUG   /
      DATA NUMCOR/2*0,  8*1,  8*5,  2*9,10*9,6*14,  2*18,10*18,6*23,
     *            2*27,14*27,10*34,6*39,   2*43,14*43,50/
C
C     J.H.JENSEN, V.KAIRYS, UNIVERSITY OF IOWA
C     ----- TRUNCATE OR PROJECT-OUT  A TAIL OF THE MO -----
C     PROJECTION PART IS BASED ON THE IDEAS BY KING ET AL
C     (J. CHEM. PHYS. 47, 1936-1941(1967)
C     WRITTEN BY V. KAIRYS
C
      DBG = EXETYP.EQ.DEBUG .AND. MASWRK
      L1 = NUM
      L2 = (L1*L1+L1)/2
      L3 = L1 * L1
C
C     ----- ASSIGN MEMORY FOR PROJECTION -----
C
      LOADFM=0
      CALL VALFM(LOADFM)
      LIWRK  = LOADFM + 1
      LS     = LIWRK  + L1
      LQ     = LS     + L2
      LV     = LQ     + L3
      LE     = LV     + L3
      LSCR   = LE     + L1
      LWRK   = LSCR   + 8*L1
      LWRK1  = LWRK   + L3
      LWRK2  = LWRK1  + L3
      LAST   = LWRK2  + L3
      NEED = LAST - LOADFM - 1
      CALL GETFM(NEED)
C
C     DETERMINE DIMENSION L1CO OF THE REDUCED S MATRIX
C
      IF(DBG)THEN
      DO 21 I=1,NAT
      WRITE(IW,*)'LIMLOW(',I,')=',LIMLOW(I),'LIMSUP(',I,')=',LIMSUP(I)
 21   CONTINUE
      END IF
      IZ = 0
      DO 200 I=1,L1
         DO 100 J=1,NZAT
            JAT=IZAT(J)
            IF(I. GE. LIMLOW(JAT) .AND. I .LE. LIMSUP(JAT)) THEN
                IZ=IZ+1
                GO TO 200
            END IF
 100     CONTINUE
 200  CONTINUE
      L1CO=L1 - IZ
      IF(DBG) WRITE(IW,*)' L1CO=', L1CO
C
C IF ALL WE WANT IS A PLAIN TRUNCATION, SKIP LOTS OF CODE
C
      IF(PLAIN) GO TO 450
      CALL DAREAD(IDAF,IODA,X(LS),L2,12,0)
      CALL CPYTSQ(X(LS),X(LV),L1,1)
C
C     FORM REDUCED SIZE S MATRIX DURING 1ST PASS
C     AND THE RECTANGULAR SKL MATRIX ON THE 2ND PASS
C
      QDONE=.FALSE.
      DELCOL=.TRUE.
 305  CALL VCLR(X(LWRK),1,L3)
      I=0
      ISM=0
      DO 210 ICOL=1,L1
         DO 300 IROW=1,L1
             DO 307 J=1,NZAT
                IAT=IZAT(J)
                IF(DELCOL .AND. (ICOL .GE. LIMLOW(IAT) .AND. ICOL
     *               .LE. LIMSUP(IAT))) GO TO 310
                IF(IROW .GE. LIMLOW(IAT) .AND. IROW .LE. LIMSUP(IAT))
     *               GO TO 310
 307         CONTINUE
             X(LWRK+ISM)=X(LV+I)
            ISM=ISM+1
 310        I=I+1
 300     CONTINUE
 210   CONTINUE
      IF(QDONE) GO TO 400
      IF(DBG) THEN
         WRITE(IW,*)' REDUCED SIZE SQUARE S MATRIX'
         CALL PRSQ(X(LWRK),L1CO,L1CO,L1CO)
      END IF
C
C     FORM CANONICAL ORTHOGONALIZED ORBITALS IN THE REDUCED BASIS SET
C
      CALL CPYSQT(X(LWRK),X(LWRK1),L1CO,1)
      CALL QMATRX(X(LWRK1),X(LQ),X(LE),X(LSCR),X(LIWRK),
     *            L1CO,L1CO,L1CO,DBG)
      IF(DBG) THEN
        WRITE(IW,*)' Q MATRIX, REDUCED BASIS'
        CALL PRSQ(X(LQ),L1CO,L1CO,L1CO)
      END IF
      QDONE=.TRUE.
      DELCOL=.FALSE.
      GO TO 305
 400  CONTINUE
      IF(DBG) THEN
        WRITE(IW,*)' RECTANGULAR SAB MATRIX'
        CALL PRSQ(X(LWRK),L1,L1CO,L1CO)
      END IF
 450  CONTINUE
C
C     PICK VECTORS FOR TRANSFORMATION - FORM V(L1,NMOPR) MATRIX
C
      CALL DAREAD(IDAF,IODA,X(LWRK1),L3,IDAFV,0)
      DO 600 I =1, NMOPR
         IM=IMOPR(I)
         CALL DCOPY(L1,X(LWRK1+(IM-1)*L1),1,X(LV+(I-1)*L1),1)
 600  CONTINUE
      IF(DBG) THEN
        WRITE(IW,*)' MO-S WHICH ARE TO BE TRUNCATED'
        CALL PRSQ(X(LV),NMOPR,L1,L1)
      END IF
C
C   HERE WE DO THE PLAIN CHOPPING-OFF FOR PLAIN=.T.
C
      IF(PLAIN)THEN
       IF(NPUNOP.NE.3)THEN
         DO 610 I=1,NMOPR
            DO 620 J=1,NZAT
               JAT=IZAT(J)
               NBAS=LIMSUP(JAT)-LIMLOW(JAT)+1
               CALL VCLR(X(LV+(I-1)*L1+LIMLOW(JAT)-1),1,NBAS)
 620        CONTINUE
 610      CONTINUE
          CALL DCOPY(L3,X(LV),1,X(LQ),1)
          GO TO 902
       ELSE
C   CONSTRUCTING RECTANGULAR MOS (NMOPR X L1CO) FOR NPUNOP=3
         CALL VCLR(X(LWRK),1,L3)
         DO 630 I=1,NMOPR
            JJ=0
            DO 640 J=1,NLAT
               JAT=ILAT(J)
               NBAS=LIMSUP(JAT)-LIMLOW(JAT)+1
               CALL DCOPY(NBAS,X(LV+(I-1)*L1+LIMLOW(JAT)-1),1,
     *                    X(LWRK+(I-1)*L1CO+JJ),1)
               JJ=JJ+NBAS
 640        CONTINUE
 630      CONTINUE
       CALL VCLR(X(LV),1,L3)
       CALL DCOPY(L3,X(LWRK),1,X(LV),1)
       WRITE(IW,9000)
       CALL PREVNL(X(LV),X(LE),NMOPR,L1CO,L1CO)
       GO TO 901
       END IF
      END IF
C
C     D=(QT*SKL)*V
C
      CALL MRTRBR(X(LQ),L1CO,L1CO,L1CO,X(LWRK),L1CO,L1,X(LWRK1),L1CO)
      IF(DBG) THEN
        WRITE(IW,*)' QT * SKL'
        CALL PRSQ(X(LWRK1),L1,L1CO,L1CO)
      END IF
      CALL MRARBR(X(LWRK1),L1CO,L1CO,L1,X(LV),L1,NMOPR,X(LWRK),L1CO)
      IF(DBG) THEN
        WRITE(IW,*)' D= (QT * SKL)*V'
        CALL PRSQ(X(LWRK),NMOPR,L1CO,L1CO)
      END IF
C
C     D-DAGGER*D
C
      CALL MRTRBT(X(LWRK),L1CO,L1CO,NMOPR,X(LWRK),L1CO,X(LS),1,1)
      IF(DBG) THEN
        WRITE(IW,*)' D-DAGGER* D'
        CALL PRTRI(X(LS),NMOPR)
      END IF
C
C     DIAGONALIZE D-DAGGER*D AND FORM TRANSFORMATION MATRIX V
C
C---- SYMMETRIC TRANSFORMATION-------------
      CALL GLDIAG(NMOPR,NMOPR,NMOPR,X(LS),X(LSCR),X(LE),
     *            X(LWRK1),IERR,X(LIWRK))
      IF(DBG) THEN
        WRITE(IW,*)' DT*D EIGENVECS'
        CALL PRSQ(X(LWRK1),NMOPR,NMOPR,NMOPR)
      END IF
C
C     REORDER ALL EIGENVALUES AND CORRESPONDING EIGENVECS:
C               THE HIGHEST ONES GO FIRST
C
      CALL BAKORD(X(LE),X(LWRK1),X(LIWRK),NMOPR)
      CALL DCOPY(L3,X(LWRK1),1,X(LWRK2),1)
C
C     V*LAMBDA^(-1/2)
C
      DO 700 I=1,NMOPR
         SCAL=ONE/SQRT(X(LE+I-1))
         CALL DSCAL(NMOPR,SCAL,X(LWRK1+NMOPR*(I-1)),1)
 700  CONTINUE
      IF(DBG) THEN
        WRITE(IW,*)' V*L^(-1/2)'
        CALL PRSQ(X(LWRK1),NMOPR,NMOPR,NMOPR)
      END IF
C
C   (V*LAMBDA^(-1/2))*V-DAGGER
C
      CALL MRARTR(X(LWRK1),NMOPR,NMOPR,NMOPR,X(LWRK2),NMOPR,NMOPR,
     *      X(LV),NMOPR)
      IF(DBG) THEN
        WRITE(IW,*)' V*L^(-1/2)*V-DAGGER'
        CALL PRSQ(X(LV),NMOPR,NMOPR,NMOPR)
      END IF
C
C     U=D*(V*LMHALF*V-D)
C
      CALL MRARBR(X(LWRK),L1CO,L1CO,NMOPR,X(LV),NMOPR,NMOPR,
     *              X(LWRK1),L1CO)
      IF(DBG) THEN
        WRITE(IW,*)' U=DV'
        CALL PRSQ(X(LWRK1),NMOPR,L1CO,L1CO)
      END IF
C
C     FORM THE NEW REDUCED SIZE MO COEFFICIENT MATRIX C=Q*U,
C        DIMENSION L1CO X NMOPR
C
      CALL MRARBR(X(LQ),L1CO,L1CO,L1CO,X(LWRK1),L1CO,NMOPR,X(LV),L1CO)
C
C     PRINTING OUT THE TRANSFORMED VECTORS
C     NPUNOP=3 DOES NOT REQUIRE ADDITIONAL PREPARATION
C     ONLY THE REDUCED MO MATRIX HAS TO BE PRINTED OUT
C
       IF(DBG) THEN
        WRITE(IW,*)' NEW MO COEFFICIENT MATRIX'
        CALL PRSQ(X(LV),NMOPR,L1CO,L1CO)
       END IF
      CALL VCLR(X(LE),1,L1)
      IF(NPUNOP.EQ.3) THEN
        WRITE(IW,9000)
        CALL PREVNL(X(LV),X(LE),NMOPR,L1CO,L1CO)
        GO TO 901
      END IF
C
C     FOR NPUNOP=1 AND 2 THE MO MATRIX HAS TO BE RESTORED TO THE
C     FULL SIZE, PADDED WITH ZEROES WHERE APPROPRIATE
C
      CALL VCLR(X(LQ),1,L3)
      IPOINT=0
      DO 810 IAT=1,NAT
         LLOW=LIMLOW(IAT)
         LSUP=LIMSUP(IAT)
         LENAT=LSUP-LLOW+1
         KZER=0
         DO 820 IIA=1,NAT
           IF(IZAT(IIA) .EQ. IAT) KZER=1
 820     CONTINUE
           IF(KZER.EQ.0) THEN
             DO 800 IC=1,NMOPR
               CALL DCOPY(LENAT,X(LV+L1CO*(IC-1)+IPOINT),1,X(LQ+L1*
     *                   (IC-1)+LLOW-1),1)
 800         CONTINUE
             IPOINT=IPOINT+LENAT
           END IF
 810   CONTINUE
 902   IF(DBG .AND. (NPUNOP.EQ.1 .OR. NPUNOP .EQ. 2)) THEN
          WRITE(IW,*)' ORBITALS BEFORE THE EXPANSION TO THE FULL MO SET'
          CALL PREVNL(X(LQ),X(LE),NMOPR,L1,L1)
       END IF
C
C      FOR NPUNOP=1 OR 2, MO-S HAVE TO BE EXPANDED WITH THE REST OF
C      UNCHANGED MO-S
C
      CALL DAREAD(IDAF,IODA,X(LWRK),L3,IDAFV,0)
C
C     IF NPUNOP=2, THE ORIGINAL UNTOUCHED VECS WILL BE WRITTEN BEHIND
C                  THE X(LQ)
C     IF NPUNOP=1, THE TRANSFORMED VECTORS WILL OCCUPY PLACE WHERE THEY
C                  WERE IN THE ORIGINAL MO SET
C
C     IFROR IS THE 1ST ELEMENT IN X FOLLOWING AFTER THE TRANSFORMED MO-S
C
      IFROR=LQ+NMOPR*L1
      IOR=0
      DO 850 I=1,NA
         KORIG=1
         DO 830 J=1,NMOPR
             IF(IMOPR(J).EQ.I) THEN
                KORIG=0
                GO TO 840
             END IF
 830     CONTINUE
 840  CONTINUE
         IF(KORIG .EQ. 1 .AND. NPUNOP .EQ. 2) THEN
            CALL DCOPY(L1,X(LWRK+(I-1)*L1),1,X(IFROR+IOR*L1),1)
            IOR=IOR+1
         END IF
         IF(KORIG .EQ. 0 .AND. NPUNOP .EQ. 1)
     *      CALL DCOPY(L1,X(LQ+(J-1)*L1),1,X(LWRK+(I-1)*L1),1)
 850  CONTINUE
      IF(NPUNOP .EQ. 2) CALL DCOPY(L3,X(LQ),1,X(LV),1)
      IF(NPUNOP .EQ. 1) CALL DCOPY(L3,X(LWRK),1,X(LV),1)
      IF(NPUNOP.EQ.1 .OR. NPUNOP .EQ. 2 .AND. MASWRK) THEN
         WRITE(IW,9000)
         CALL PREV(X(LV),X(LE),NA,L1,L1)
      END IF
C
C  TO PREPARE VECTORS FOR THE PUNCHING OUT TO USE IN QM/MM USING EFS
C  IT IS NECESSARY TO IDENTIFY THE VECTORS AND TO REARRANGE THEM
C  SO THAT THE VECTORS AND ATOMS BELONGING TO MM PART ARE DROPPED
C
      IF(NATAB+NATBF.EQ.0) GO TO 901
C
C  AUTOMATICALLY DETERMINE THE NUMBER OF BUFFER + CHEMICAL CORE MO-S
C  TO INCLUDE IN THE POSSIBLE MP2 CALCULATION - IT MAKES LIFE A LITTLE
C  EASIER
C
C  FIRST, COUNT CHEMICAL CORE ORBITALS IN THE AB INITIO REGION
C
      NCORE=0
      DO 855 I=1,NATAB
         IZ=INT(ZAN(I))+IZCORE(I)
         IF(IZ.LE.0) GO TO 855
         IF((IZ.GT.103).AND.MASWRK) WRITE(IW,*)
     *               'Z.GT.103 IN SETTING CORE COUNT'
         IF(IZ.GT.103) CALL ABRT
         NCORE = NCORE + NUMCOR(IZ) - IZCORE(I)/2
  855 CONTINUE
C
C   SECOND, ADD BUFFER MO-S
C
      NCORE= NCORE+NMOPR
C
C   DETERMINE NUMBER OF CORE MO-S ALSO FOR THE MAKEFP RUN.
C   THIS NUMBER BE NEEDED WHEN DECIDING ON HOW MANY ORBITALS
C   ARE TO BE EXCLUDED OUT OF LOCALIZATION -
C   IF WE HAVE S, CL AND SUCH BOYS LOCALIZATION OF THE CORES FAILS
C
      NCORFP=0
      DO 858 I=NATAB+NATBF+1,NAT
         IZ=INT(ZAN(I))+IZCORE(I)
         IF(IZ.LE.0) GO TO 858
         IF((IZ.GT.103).AND.MASWRK) WRITE(IW,*)
     *               'Z.GT.103 IN SETTING CORE COUNT'
         IF(IZ.GT.103) CALL ABRT
         NCORFP = NCORFP + NUMCOR(IZ) - IZCORE(I)/2
  858 CONTINUE
      NCORFP=NCORFP+NMOPR
      IF(MASWRK)THEN
C
C    NOW, PREPARE THE QM/MM RUN INPUT FILE. GUESS VECTORS WILL
C    BE PUNCHED OUT BY MOIDBM/MOIDF SUBROUTINES
C
      WRITE(IP,FMT='(60(1H=))')
      WRITE(IP,FMT='(45H!BELOW ARE SOME INPUT CARDS FOR THE QM/MM RUN)')
      WRITE(IP,FMT='(45H $CONTRL SCFTYP=RHF UNITS=ANGS MAXIT=70      )')
      WRITE(IP,FMT='(45H  ICHARG=? RUNTYP=OPTIMIZE $END              )')
      WRITE(IP,FMT='(45H $SYSTEM MWORDS=100                   $END   )')
      WRITE(IP,FMT='(12H $MP2 NCORE=,I3,5H $END)')NCORE
      WRITE(IP,FMT='(24H $MOFRZ FRZ=.T. IFRZ(1)=,(10I3))')
     *     (I,I=1,NMOPR)
      WRITE(IP,FMT='(13H         $END)')
      WRITE(IP,FMT='(45H $GUESS GUESS=MOREAD $END                    )')
      WRITE(IP,9615)
      WRITE(IP,FMT='(7H $EFRAG,/,24H POSITION=FIXED NBUFFMO=,I2)')
     *      NMOPR
      WRITE(IP,FMT='(14H FRAGNAME=XXXX)')
      DO  860 I=2,0,-1
           XCOORD=C(1,NAT-I) * TOANGS
           YCOORD=C(2,NAT-I) * TOANGS
           ZCOORD=C(3,NAT-I) * TOANGS
      WRITE(IP,FMT='( 1H<,A1,I2,1H>,(3F18.10))' )ANAM(NAT-I),NAT-I,
     *                XCOORD,YCOORD,ZCOORD
 860  CONTINUE
      WRITE(IP,FMT='(5H $END)')
      WRITE(IP,FMT='(45H!**ATTENTION** REPLACE BRACKETS ABOVE WITH   )')
      WRITE(IP,FMT='(45H! THE CENTERS FROM THE EFP LIST              )')
      WRITE(IP,FMT='(45H! (COORDINATES SHOULD BE IN ANGSTROMS)       )')
      WRITE(IP,FMT='(19H $STATPT IFREEZ(1)=,(10I4))')
     *     ( I,I=3*ILAT(1)-2,3*ILAT(NLAT) )
      WRITE(IP,FMT='(45H NSTEP=200 NPUN=-2 NPRT=-2  $END             )')
      WRITE(IP,FMT='(''!IF YOU HAVE ECP-S ON THE CAPPING ATOM(S), YOU'',
     *          '' HAVE TO INPUT THEM MANUALLY IN THE $ECP GROUP!'')')
      END IF
C
C
      CALL MOLTWO(1,-1,1)
C     RECYCLE LOC. VECTOR STORAGE SPACE
      CALL DAWRIT(IDAF,IODA,X(LV),L1*L1,71,0)
      CALL MOIDBM(71)
      IF(MASWRK)THEN
C
C     PREPARE MAKEFP RUN FILE TOGETHER WITH INITIAL GUESS VECTORS
C
      WRITE(IP,FMT='(60(1H=))')
      WRITE(IP,9610)
C      THE WARNING BELOW IS TRUE ONLY FOR ANALYTICAL POLARIZABILITIES
C  WRITE(IP,FMT='(45H!**WARNING**DO NOT CHANGE ROHF BELOW INTO RHF)')
      WRITE(IP,FMT='(44H $CONTRL SCFTYP=RHF UNITS=ANGS RUNTYP=MAKEFP)')
      WRITE(IP,FMT='(34H ICHARG=? LOCAL=?    MAXIT=70 $END)')
      WRITE(IP,FMT='(44H $SYSTEM MWORDS=100                   $END  )')
      WRITE(IP,FMT='(44H $LOCAL FCORE=.T. POLNUM=.T. POLDYN=.F.     )')
      WRITE(IP,FMT='(5H $END)')
      WRITE(IP,FMT='(28H $GUESS GUESS=HUCKEL INSORB=,I3,5H $END)')NMOPR
      WRITE(IP,FMT='(24H $MOFRZ FRZ=.T. IFRZ(1)=,(10I3))')
     *     (I,I=1,NMOPR)
      WRITE(IP,FMT='(5H $END)')
      WRITE(IP,9615)
      WRITE(IP,FMT='(7H $STONE)')
      WRITE(IP,FMT='(9H         )')
      WRITE(IP,FMT='(9H  QMMMBUF)')
      WRITE(IP,FMT='(5H $END)')
      END IF
      CALL MOLTWO(1,-1,2)
      IF(MASWRK) WRITE(IP,*)'--VECTORS FOR THE MAKEFP RUN--'
      CALL DAREAD(IDAF,IODA,X(LV),L1*L1,71,0)
      IF(MASWRK)THEN
      WRITE(IP,FMT='(5H $VEC)')
C
C   THIS IS TAKEN FROM PUSQL ROUTINE
C
      LOWBUF=LIMSUP(NATAB)+1
C      DO 120 J = 1,NA
      DO 120 J = 1,NMOPR
        IC = 0
        MAX = LOWBUF-1
  110   MIN = MAX+1
        MAX = MAX+5
        IC = IC+1
        IF (MAX .GT. L1) MAX = L1
        MODJ=MOD(J,100)
        WRITE (IP,9008) MODJ,IC,(X(LV+(J-1)*L1+I-1),I = MIN,MAX)
        IF (MAX .LT. L1) GO TO 110
  120 CONTINUE
C
      WRITE(IP, FMT='(5H $END)')
      GO TO 903
      END IF
 901  IF(MASWRK)WRITE(IP,9500)NPUNOP,NMOPR
      IF(NPUNOP.EQ.3)THEN
         IF(MASWRK) WRITE(IP,FMT='(5H $VEC)')
         CALL PUSQL(X(LV),NMOPR,L1CO,L1CO)
         IF(MASWRK) WRITE(IP, FMT='(5H $END)')
      END IF
      IF(NPUNOP.EQ.1 .OR. NPUNOP .EQ. 2) THEN
         IF(MASWRK) WRITE(IP,FMT='(5H $VEC)')
         CALL PUSQL(X(LV),NA,L1,L1)
         IF(MASWRK) WRITE(IP, FMT='(5H $END)')
      END IF
 903  IF (MASWRK)
     *   WRITE(IW,FMT='('' ....... DONE TRUNCATING MO TAIL ........'')')
      CALL RETFM(NEED)
      CALL TIMIT(1)
      RETURN
 9000 FORMAT(/30X,18(1H-)/30X,'TRUNCATED ORBITALS'/30X,18(1H-))
 9008 FORMAT(I2,I3,1P,5E15.8)
 9500 FORMAT(1X,'TRUNCATED ORBITALS, NPUNOP=',I2,', NMOPR=',I3)
 9610 FORMAT('!BELOW ARE A FEW INPUT CARDS FOR THE MAKEFP RUN')
 9615 FORMAT(' $SCF DIIS=.T. SOSCF=.F. NPUNCH=1',
     *       ' DIRSCF=.T. FDIFF=.F. $END')
      END
C*MODULE EFPCOV  DECK MOIDBM
      SUBROUTINE MOIDBM(IVFILE)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      PARAMETER (MXATM=2000)
C
C
      COMMON /FMCOM / X(1)
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
C
      L1 = NUM
      L2 = (L1*L1+L1)/2
      L3 = L1*L1
C
C     ----- PARTITION FAST MEMORY -----
C
      CALL VALFM(LOADFM)
      LMOIDN = 1 + LOADFM
      LNMOAT = LMOIDN + 5*NA
      LSVEC  = LNMOAT + NA
      LV     = LSVEC  + L3
      LARRAY = LV     + L3
      LAMOD  = LARRAY + L2
      LOCC   = LAMOD  + NA
      LZMO   = LOCC   + 5*NA
      LAST   = LZMO   + NAT
C
      NEED = LAST - LOADFM - 1
      CALL GETFM(NEED)
C
      CALL MOIDBF(X(LSVEC),X(LV),X(LARRAY),X(LAMOD),X(LMOIDN),X(LNMOAT),
     *            X(LOCC),X(LZMO),L1,L2,NA,NAT,IVFILE)
C
      CALL RETFM(NEED)
      RETURN
      END
C*MODULE EFPCOV  *DECK MOIDBF
      SUBROUTINE MOIDBF(SVEC,V,ARRAY,AMODEN,MOIDNO,NMOAT,OCCUP,ZMO,
     *                  L1,L2,LNA,LNAT,IVFILE)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL DOPROJ,PLAIN,GOPARR,DSKWRK,MASWRK,MOIDON,EDCOMP,DIPDCM,
     *        DEPRNT,QADDCM,ZDO,POLDCM,POLANG,POLAPP,KMIDPT,POLDYN
C
      PARAMETER (MXATM=2000, MXSH=5000, MXGTOT=20000, MXAO=8192)
      PARAMETER (NMO=500)
C
      DIMENSION V(L1,L1), SVEC(L1,L1)
      DIMENSION ARRAY(L2), AMODEN(LNAT)
      DIMENSION MOIDNO(5,LNA), NMOAT(LNA), OCCUP(LNA), ZMO(5,LNA)
C
      COMMON /ATLIM / LIMLOW(MXATM),LIMSUP(MXATM)
      COMMON /EFPBUF/ POLCHG(10),NBUFMO,LBUFF(MXAO),LBF,NAPOL,IAPOL(10)
      COMMON /EDCMP / ZIJ(NMO),ZMOX(5,NMO),OCCUPX(NMO),DPFREQ(50),
     *                MOIDNX(5,NMO),IJMO(2,NMO),MOIJ(NMO),NMOIJ(NMO),
     *                NMOATX(NMO),NDPFREQ,IPROT(5),NPROT,
     *                MOIDON,EDCOMP,DIPDCM,DEPRNT,QADDCM,ZDO,POLDCM,
     *                POLANG,POLAPP,KMIDPT,POLDYN
      COMMON /GSSORD/ IORDER(MXAO),JORDER(MXAO),NORDER
      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 /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /PROJ  / DOPROJ,PLAIN,NPUNOP,NMOPR,NZAT,NLAT,IMOPR(MXAO),
     *                IZAT(500),ILAT(500),NATAB,NATBF,NCAPBK,ICAPBK(10),
     *                NCAPFR,ICAPFR(10)
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      COMMON /WFNOPT/ SCFTYP,VBTYP,DFTYPE,TDDFTYP,CITYP,CCTYP,
     *                MPLEVL,MPCTYP
C
      PARAMETER (ZERO=0.00D+00,ONE=1.0D+00, TWO=2.0D+00, VTOL=0.15D+00)
      PARAMETER (ZTOL=1.00D-05)
C
      DATA RHF,ROHF/8HRHF     ,8HROHF    /
      DATA DEBUG/8HDEBUG   /
C
C      THIS ROUTINE IDENTIFIES THE GUESS (L)MOS USING THE NORMALIZED
C      MULLIKEN POPULATION. IT IS A SIMPLIFIED VERSION OF MOID ROUTINE.
C      ITS PURPOSE IS TO IDENTIFY ATOMIC CENTERS CORRESPONDING
C      TO BUFFER MOS IN $EFRAG.
C
      CALL DAREAD(IDAF,IODA,V    ,L1*L1,IVFILE,0)
      CALL DAREAD(IDAF,IODA,ARRAY,L2   ,12,0)
      CALL CPYTSQ(ARRAY,SVEC,L1,1)
C
C     GENERATE THE OCCUPATION NUMBERS
C
      CALL VCLR(OCCUP,1,NAT)
      DO 100 I=1,LNA
         IF (SCFTYP .EQ. RHF)  OCCUP(I) = TWO
         IF (SCFTYP .EQ. ROHF) THEN
            IF (I.LE.NB) THEN
               OCCUP(I) = TWO
            ELSE
               OCCUP(I) = ONE
            END IF
         END IF
  100 CONTINUE
C
      DO 490 K = 1,LNA
         CALL VCLR(AMODEN,1,NAT)
         ICN = 0
         I = 0
         DO 390 II = 1,NSHELL
            IAT = KATOM(II)
            MINI = KMIN(II)
            MAXI = KMAX(II)
C 
         IF(EXETYP.EQ.DEBUG .AND. MASWRK) THEN
           WRITE(IW,*) 'ATOM #:',K
           WRITE(IW,*) 'SHELL:',II,'KMIN:',MINI,'KMAX:',MAXI
           WRITE(IW,*) '-----------------------'
         END IF
            DO 380 N = MINI,MAXI
               I = I + 1
               CXS = ZERO
               DO 370 L = 1,L1
                  CXS = CXS + V(L,K)*SVEC(L,I)
  370          CONTINUE
               AMODEN(IAT) = AMODEN(IAT) + V(I,K)*CXS
  380       CONTINUE
  390    CONTINUE
C
         IF(EXETYP.EQ.DEBUG .AND. MASWRK) THEN
         NMIN = MIN(NAT,11)
           WRITE(IW,*) 'NORMALIZED MULL. POP. FOR EACH LMO'
           WRITE(IW,FMT='(1X,I3,2X,11F6.3)') K, (AMODEN(JJ), JJ=1,NMIN)
           IF (NAT .GT. 11) WRITE(IW,FMT='(6X,      11F6.3)')
     *                                        (AMODEN(JJ), JJ=12,NAT)
         END IF
         DO 450 JJ = 1,NAT
            AVAL = AMODEN(JJ)
            IF (AVAL.GE.VTOL) THEN
               IATOM = JJ
               ICN = ICN + 1
               MOIDNO(ICN,K) = IATOM
            END IF
  450    CONTINUE
         NMOAT(K) = ICN
         DO 470 JJ = 1,ICN
            ZMO(JJ,K) = OCCUP(K)/ICN
  470    CONTINUE
  490 CONTINUE
C
C     ----- $LOCAL VALUES ARE NOW TRANSFERRED TO APPROPRIATE
C     ARRAYS -----
C
      DO 680 L = 1,NMO
         I = IJMO(1,L)
         J = IJMO(2,L)
         IF (MOIJ(L) .GT. 0) MOIDNO(I,J) = MOIJ(L)
         IF (ZIJ(L) .GE. ZERO) ZMO(I,J) = ZIJ(L)
         IF (NMOIJ(L) .GE. ZERO) NMOAT(L) = NMOIJ(L)
  680 CONTINUE
      IF(NBUFMO.GT.0) GO TO 800
C
C   WHEN CALLED FROM TRUNCX, THE PURPOSE OF THIS ROUTINE
C   TO REMOVE UNWANTED VECTORS FROM PUNCHING OUT
C
      NATAI = NATBF + NATAB
C     COUNT ORBITALS WHICH WILL STAY
      CALL VICLR(IORDER,1,MXAO)
      ILEFT=0
      DO 600 I=1,NA
         IORD=0
         ICN = NMOAT(I)
         DO 610 J=1,ICN
          IF(MOIDNO(J,I).GT.NATAI)IORD=1
 610     CONTINUE
      IF(IORD.EQ.0) THEN
           ILEFT=ILEFT+1
           IORDER(ILEFT)=I
          WRITE(IW,*) 'PUNCHING TRUNCATED ORBITAL',I ,'TO QM/MM INPUT'
      END IF
 600  CONTINUE
      IDEL=ILEFT
      DO 620 I=1,NA
         IORD=0
         ICN = NMOAT(I)
         DO 640 J=1,ICN
          IF(MOIDNO(J,I).GT.NATAI)IORD=1
 640     CONTINUE
      IF(IORD.EQ.1) THEN
           IDEL=IDEL+1
           IORDER(IDEL)=I
      END IF
 620  CONTINUE
      CALL REORDR(V,IORDER,NA,L1)
C
C     PUNCHING OUT VECTORS LOCALIZED IN THE AB INITIO/BUFFER REGIONS
C     FOR THE QM/MM RUN
C
      NATAI=NATAB+NATBF
      NBASAI=LIMSUP(NATAI)
      IF(MASWRK)THEN
        WRITE(IP,9501)NMOPR,NBASAI,ILEFT
        WRITE(IP,FMT='(5H $VEC)')
        CALL PUSQL(V,ILEFT,NBASAI,L1)
        WRITE(IP, FMT='(5H $END)')
      END IF
C
C     FORM VECTORS FOR THE MAKEFP RUN INITIAL GUESS BY REARRANGING
C     GUESS VECTORS FROM THE QM/MM RUN (WHICH WERE JUST NOW PUNCHED).
C     WE WILL WRITE THEM TO DICTIONARY FILE 71 TO USE THEM LATER.
C
C     WE ASSUME THAT THE NUMBER OF BUFFER ORBITALS IS NMOPR,
C     AND THEY GO FIRST IN THE VECTOR MATRIX WHICH WAS JUST
C     PUNCHED OUT.
C
C     FIRST ARE THE BUFFER ORBITALS
      DO 750 I=1,NMOPR
         IORDER(I)=I
 750  CONTINUE
C     NEXT, THE EFP REGION VECTORS FOLLOW
      NEFORB=NA-ILEFT
      DO 760 I=1,NEFORB
         IORDER(NMOPR+I)=ILEFT+I
 760  CONTINUE
C     FINALLY, THE AB INITIO REGION VECTORS WHICH BECOME
C     VIRTUALS IN THE MAKEFP RUN
      DO 770 I=1,ILEFT-NMOPR
         IORDER(NEFORB+NMOPR+I)=NMOPR+I
 770  CONTINUE
C     REARRANGE AND SAVE THE MAKEFP GUESS VECTORS
      CALL REORDR(V,IORDER,NA,L1)
      CALL DAWRIT(IDAF,IODA,V,L1*L1,71,0)
      GO TO 810
 800  CONTINUE
C
C     THE PROGRAM GOES THROUGH THE FOLLOWING WHEN CALLED FROM ENUC
C     COLLECT THE CENTERS WHICH ARE IN THE BUFFER ZONE INTO ARRAY LBUFF
C
      CALL VICLR(LBUFF,1,MXAO)
      IJ=0
      DO 500 I=1,LNAT
      IINB=0
        DO 510 J=1,NBUFMO
          DO 520 K=1,NMOAT(J)
            IF(I.EQ.MOIDNO(K,J)) IINB=1
  520     CONTINUE
  510   CONTINUE
      IF(IINB.EQ.1) THEN
         IJ=IJ+1
         LBUFF(IJ)=I
      END IF
  500 CONTINUE
      LBF=IJ
C   WE ASSUME ALL ATOMS BEFORE LBUFF(1) ARE AB INITIO PART
      IF( (LBUFF(LBF)-LBUFF(1)+1) .NE. LBF .OR. (LBUFF(LBF).LT.NAT))THEN
          IF(MASWRK) THEN
             WRITE(IW,*)' NUMBER OF BUFFER ATOMS  ',LBF
             WRITE(IW,*)' THE FIRST BUFFER ATOM IS CENTER NUMBER ',
     *                   LBUFF(1)
             WRITE(IW,*)' THE LAST BUFFER ATOM IS CENTER NUMBER ',
     *                   LBUFF(LBF)
             WRITE(IW,*)' TOTAL NUMBER OF ATOMS  ',NAT
             WRITE(IW,*)' ALL OF ''AB INITIO'' ATOMS ',
     *              'MUST PRECEDE ''BUFFER'' ATOMS. HASTA LA VISTA!'
          END IF
          CALL ABRT
          STOP
      END IF
C
C  NEXT, TRY TO DETERMINE THE CHARGES ON BUFFER ATOMS WHICH ARE
C  DEFINED AS THE NUCLEAR CHARGE MINUS CHARGE USED UP BY
C  BUFFER MOLECULAR ORBITALS. THIS WAY WE WILL FIND THE
C  JUNCTION ATOMS BETWEEN THE AB INITIO PART AND THE BUFFER PART.
C  THIS IS NECESSARY WHEN CONSIDERING INTERACTION OF EFP
C  POLARIZABILITIES WITH THE NUCLEI. THAT'S WHY THEY ARE
C  NAMED NAPOL, IAPOL.
C
      NAPOL=0
      DO 730 IA=LBUFF(1),LBUFF(LBF)
        ELIXIR=ZAN(IA)
        DO 710 IM=1,NBUFMO
          DO 720 IN=1,NMOAT(IM)
            IF(MOIDNO(IN,IM).EQ.IA)THEN
              ELIXIR=ELIXIR-ZMO(IN,IM)
            END IF
 720      CONTINUE
 710    CONTINUE
C
C          DOUBLE CHECK CHARGES ON CAPPING ATOMS.
C
        ELIX02=ZAN(IA)
        DO 711 IM=1,LNA
          DO 721 IN=1,NMOAT(IM)
            IF(MOIDNO(IN,IM).EQ.IA)THEN
              ELIX02=ELIX02-ZMO(IN,IM)
            END IF
 721      CONTINUE
 711    CONTINUE
        IF ( ABS(ELIX02) .GT. ZTOL ) THEN
          IF(ABS(ELIX02-ELIXIR).LT.1.5D+00) ELIXIR=ELIXIR-ELIX02
        END IF
C
        IF ( ABS(ELIXIR-ZERO) .GT. ZTOL ) THEN
           NAPOL=NAPOL+1
           IAPOL(NAPOL)=IA
           POLCHG(NAPOL)=ELIXIR
        END IF
 730  CONTINUE
C
C
      IF (EXETYP.EQ.DEBUG.AND.MASWRK) THEN
         WRITE(IW,9000)
         DO 700 K = 1,LNA
            ICN = NMOAT(K)
            WRITE(IW,9100) K, (MOIDNO(J,K),ZMO(J,K),J=1,ICN)
  700    CONTINUE
      END IF
      IF (MASWRK) THEN
         WRITE(IW,9300) LBF
         WRITE(IW,9310) (LBUFF(I),I=1,LBF)
         WRITE(IW,9320)
         WRITE(IW,9330)
         WRITE(IW,9340) NAPOL
         WRITE(IW,9310) (IAPOL(I),I=1,NAPOL)
         WRITE(IW,9350)
         WRITE(IW,9360) (POLCHG(I),I=1,NAPOL)
      END IF
  810 RETURN
C
 9000 FORMAT(/1X,'ATOMS ARE ASSIGNED TO THE MOS BASED ON THEIR ',
     *       'MULLIKEN POPULATION.  LMO NUCLEAR CHARGE IS IN ()')
 9100 FORMAT(1X,'ORBITAL ',I3,' BELONGS TO ATOM(S) ',
     *       3(I3,' (',F4.2,') '))
 9300 FORMAT(/1X,'THE PROGRAM FOUND THERE ARE ',I3,' ATOMS ',
     *       'IN THE BUFFER ZONE:'/)
 9310 FORMAT(1X,(10I4))
 9320 FORMAT(/1X,'THEY WILL BE EXCLUDED FROM THE EFP-NUCLEI ',
     *       'INTERACTIONS.')
 9330 FORMAT(/1X,'PLEASE VERIFY THESE ATOMIC CENTER ASSIGMENTS.'/1X,
     *      'IF THEY ARE INCORRECT YOU PROBABLY FOR SOME REASON',
     *      ' ARE USING NON-LOCALIZED MO-S.')
 9340 FORMAT(/1X,'THE PROGRAM FOUND THERE ARE ',I3,' ATOM(S)'/1X,
     *       'IN THE BUFFER WHICH ARE CONNECTED TO AB INITIO REGION:'/)
 9350 FORMAT(/1X,'THEIR CHARGES OUTSIDE BUFFER LMO-S ARE',
     *           ' RESPECTIVELY:'/)
 9360 FORMAT(1X,(10F6.3))
 9501 FORMAT(1X,'TRUNCATED AND CHOPPED ORBITALS TO INPUT INTO EFP RUN,',
     *          ' NMOPR=',I3,' NBAS=',I3,' NMOS=',I3)
      END
C*MODULE EFPCOV  *DECK ATMTWO
      SUBROUTINE ATMTWO(IUNTRD,CSINP,CPINP,CDINP,CFINP,CGINP,
     *                  MAXGAU,ICOORD,NTIME,RELNORM)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL DOPROJ,PLAIN,MIDI,NEWWAY,STOTYP,GENTYP,RELNORM
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      EXTERNAL REREAD
C
      PARAMETER (MXSH=5000, MXGTOT=20000, MXAO=8192, MXATM=2000,
     *           MAXA=103, MAXL=7)
C
      CHARACTER*10 ATOMNM,ENDWRD,UATOM
      CHARACTER*8 CTYPE,CBASIS
C
      DOUBLE PRECISION LABEL(28),LETK
C
      DIMENSION CSINP(MAXGAU),CPINP(MAXGAU),CDINP(MAXGAU),
     *          CFINP(MAXGAU),CGINP(MAXGAU)
      DIMENSION SKIPS(20),INTYP(MXSH),NS(MXATM),KS(MXATM),
     *          NBFS(27),MINF(27),MAXF(27),NANGM(27),
     *          EXX(6),CSS(6),CPP(6),CDD(6),SCFAC(4)
C
      COMMON /BASISC/ GBASIS,AEX(MAXA,MAXL),ABASIS(MAXA,MAXL),
     *                IAGAUS(MAXA,MAXL),IRDBAS
      COMMON /COORDN/ UZNUC(MXATM),CUNIQ(MXATM,3),NATREL,UATOM(MXATM)
      COMMON /EFPBF2/ QBORD(500)
      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,IEFLD
      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 /PROJ  / DOPROJ,PLAIN,NPUNOP,NMOPR,NZAT,NLAT,IMOPR(MXAO),
     *                IZAT(500),ILAT(500),NATAB,NATBF,NCAPBK,ICAPBK(10),
     *                NCAPFR,ICAPFR(10)
      COMMON /RUNLAB/ TITLE(10),A(MXATM),B(MXATM),BFLAB(MXAO)
      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,VBTYP,DFTYPE,TDDFTYP,CITYP,CCTYP,
     *                MPLEVL,MPCTYP
C
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00, HALF=0.5D+00,
     *           PT75=0.75D+00, PT187=1.875D+00, PT6562=6.5625D+00,
     *           UNITS = ONE/0.52917724924D+00,
     *           TM6=1.0D-06, TM10=1.0D-10)
C
      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 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        /
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    ,
     *           8HSV      /
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/
      DATA ENDWRD /'$END      '/
      DATA NONE/4HNONE/
C
C    THIS ROUTINE IS A SHORTENED VERSION OF ATOMS, RECYCLED FOR
C     THE SOLE PURPOSE OF RE-READING THE INPUT DECK AND
C     PREPARING $DATA DECK FOR THE QM/MM RUN
C
      PI = ACOS(-ONE)
      PI32 = PI * SQRT(PI)
      IDUM = 0
      IGAUSS = 0
      BASIS = BLANK
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
         CSINP(I) = ZERO
         CPINP(I) = ZERO
         CDINP(I) = ZERO
         CFINP(I) = ZERO
         CGINP(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
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
C
      IF(ATOMNM.EQ.ENDWRD) GO TO 900
      NAT = NAT+1
      IF(NAT.GT.MXATM) GO TO 1540
C
      IF (MASWRK .AND. (NTIME.EQ.1) .AND. (ICNT2.LE.NATAB+NATBF) ) THEN
         IF( ICNT2 .LE. NATAB) THEN
              WRITE(IP,9008) ATOMNM,ZNUC,X,Y,Z
         ELSE
              ISBORD=0
              DO 101 I=1,NCAPBK
                IF(ICNT2.EQ.ICAPBK(I)) ISBORD=1
  101         CONTINUE
              IF(ISBORD.EQ.1) THEN
                    WRITE(IP,9008) ATOMNM,QBORD(ICNT2),X,Y,Z
              ELSE
                    WRITE(IP,9008) ATOMNM,ZNUC,X,Y,Z
              END IF
         END IF
      END IF
      IF (MASWRK .AND. (NTIME.EQ.2) .AND. ICNT2.GT.NATAB ) THEN
          ISBORD=0
          DO 102 I=1,NCAPFR
            IF(ICNT2.EQ.ICAPFR(I)) ISBORD=1
  102     CONTINUE
          IF(ISBORD.EQ.1) THEN
                WRITE(IP,9008) ATOMNM,QBORD(ICNT2),X,Y,Z
          ELSE
                WRITE(IP,9008) ATOMNM,ZNUC,X,Y,Z
          END IF
      END IF
      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
      IF(ZNUC.GT.ZERO) THEN
         ZAN(NAT) = ZNUC
         NE = NE + INT(ZNUC)
      ELSE
         ZAN(NAT) = ZERO
         ZNUC = ABS(ZNUC)
      END IF
C
C     ----- READ IN THE BASIS FUNCTIONS ON THIS CENTER -----
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
      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
      ELSE
         IEOF = 0
         IERR = 0
         CALL RDCARD('$DATA 6U',IEOF)
         CBASIS='        '
         LENSTR=-8
         CALL GSTRNG(CBASIS,LENSTR)
         READ(UNIT=CBASIS,FMT='(A8)') BASIS
         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.
            CTYPE='        '
            LENSTR=-8
            CALL GSTRNG(CTYPE,LENSTR)
            READ(UNIT=CTYPE,FMT='(A8)') TYPE
            IF (TYPE.EQ.LETK) TYPE=LABEL(1)
            IF(TYPE.EQ.SV) THEN
               CTYPE='        '
               LENSTR=-8
               CALL GSTRNG(CTYPE,LENSTR)
               READ(UNIT=CTYPE,FMT='(A8)') TYPE
            END IF
C                WE MIGHT HAVE A "S", "P",..."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
               CTYPE='        '
               LENSTR=-8
               IF(STOTYP) CALL GSTRNG(CTYPE,LENSTR)
            ELSE
               CALL REREAD
               IGAUSS = IFIND('NGAUSS  ',IERR)
                             IF(IERR.NE.0) CALL ABRT
               CBASIS='        '
               LENSTR=-8
               CALL GSTRNG(CBASIS,LENSTR)
               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
         IF(ICNT.EQ.1) THEN
            ABASIS(NUCZ,1) = BASIS
            IAGAUS(NUCZ,1) = IGAUSS
         END IF
      END IF
C
C     DETERMINE IF THE CURRENT ATOM IS THE CAPPING ATOM IN THE
C     PROJECTION/TRUNCATION RUN
      ICAPB=0
      DO 211 I=1,NCAPBK
         IF(ICNT2.EQ.ICAPBK(I))ICAPB=1
  211 CONTINUE
      ICAPF=0
      DO 212 I=1,NCAPFR
         IF(ICNT2.EQ.ICAPFR(I))ICAPF=1
  212 CONTINUE
C
C  DETERMINE IF WE ARE USING A DICTIONARY BASIS SET
C
      IDICBS=0
      IF(BASIS.EQ.BASN31) IDICBS=1
      IF(BASIS.EQ.BASN21) IDICBS=1
      IF(BASIS.EQ.BASDH)  IDICBS=1
      IF(BASIS.EQ.BASBC)  IDICBS=1
      IF(BASIS.EQ.BASMC)  IDICBS=1
      IF(BASIS.EQ.BAS311) IDICBS=1
      IF(BASIS.EQ.BASMIN) IDICBS=1
      IF(BASIS.EQ.BASMID) IDICBS=1
      IF(BASIS.EQ.BASSB2) BASIS=BASSBK
      IF(BASIS.EQ.BASSBK) IDICBS=1
      IF(BASIS.EQ.BASHW)  IDICBS=1
      IF(BASIS.EQ.BASDZV) IDICBS=1
      IF(BASIS.EQ.BASTZV) IDICBS=1
      IF(BASIS.EQ.BASSTO) IDICBS=1
C
C        A BLANK STRING FOR BASIS MEANS THIS ATOM IS ALL DONE
C
      IF(BASIS.EQ.BLANK) THEN
         IF (MASWRK. AND. (NTIME. EQ.1) .AND. (ICNT2.LE.NATAB+NATBF) )
     *                                         WRITE (IP,8000) BLANK
         IF (MASWRK. AND. (NTIME. EQ.2) .AND. (ICNT2.GT.NATAB ) )
     *                                         WRITE (IP,8000) BLANK
         GO TO 800
      ELSE
         IF (MASWRK .AND. (NTIME.EQ.1) .AND. (ICAPB.EQ.0).AND.
     *    (ICNT2.LE.NATAB+NATBF) )    WRITE (IP,8000) BASIS,IGAUSS
         IF (MASWRK .AND. (NTIME.EQ.2) .AND. (ICAPF.EQ.0).AND.
     *    (ICNT2.GT.NATAB) )    WRITE (IP,8000) BASIS,IGAUSS
         IF (MASWRK .AND. (NTIME.EQ.1) .AND. (ICAPB.EQ.1) .AND.
     *       (IDICBS.EQ.0) .AND. (ICNT2.LE.NATAB+NATBF) )
     *                                  WRITE (IP,8000) BASIS,IGAUSS
         IF (MASWRK .AND. (NTIME.EQ.2) .AND. (ICAPF.EQ.1) .AND.
     *       (IDICBS.EQ.0) .AND. (ICNT2.GT.NATAB) )
     *                                  WRITE (IP,8000) BASIS,IGAUSS
      END IF
C
C     ----- DETERMINE IF WE ARE USING A SEMIEMPIRICAL HAMILTONIAN -----
C
      IF(MPCTYP.NE.NONE)THEN
         IF(MASWRK) WRITE(IW,*)' SEMIEMPIRICAL WAVEFUNCTION PROBABLY',
     *     ' IS NOT VERY USEFUL IN HYBRID QM/MM CALCULATIONS!'
         CALL ABRT
      END IF
C
C     ----- SET UP AB INITIO BASIS SETS -----
C
      IF(IDICBS.EQ.1) GO TO 300
C
C     IT MUST BE EITHER S,P,D,F,G,L,M,N OR AN -STO- SHELL
C
      ITYP = 0
      DO 230 I=1,27
         IF(BASIS.EQ.LABEL(I)) ITYP=I
  230 CONTINUE
C
C      ----- M,N SHELLS ARE NOT IMPLEMENTED IN INTEGRAL SECTION
C
      IF(ITYP.EQ.7 .OR. ITYP.EQ.8) THEN
         IF (MASWRK) WRITE(IW,*) 'INTEGRAL CODE CANNOT DO M OR N SHELLS'
         CALL ABRT
      END IF
      IF(ITYP.GT.0) GO TO 500
C
C     BASIS IS A COMPLETELY UNRECOGNIZED STRING.  KILL JOB.
C
      IF (MASWRK) WRITE (IW,9020) BASIS,IGAUSS
      CALL BERROR(4)
      STOP
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
      IERR1=0
      IERR2=0
      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 399
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 399
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 399
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 399
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 399
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 399
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 399
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
         STOP
      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
         STOP
      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 399
C
C     ----- STEVENS, BASCH, KRAUS, JASIEN, CUNDARI -ECP- BASIS SET -----
C
  380 CONTINUE
      IF(BASIS.NE.BASSBK) GO TO 400
      IF(IECP.EQ.0) THEN
         IF (MASWRK) WRITE(IW,*)
     *      '*** ERROR, -SBKJC- BASIS REQUIRES USE OF ECP IN $CONTRL'
         CALL ABRT
         STOP
      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 399
C
 399  CONTINUE
      IF(MASWRK .AND. ( (ICAPB.EQ.1 .AND. NTIME.EQ.1) .OR.
     *                  (ICAPF.EQ.1 .AND. NTIME.EQ.2) )  ) THEN
      DO 321 ISHELL=1,NS(ICNT2)
        ICURSH=KS(ICNT2)+ISHELL-1
        WRITE(IP,8000)LABEL(INTYP(ICURSH)),KNG(ICURSH)
        DO 322 IGAUSS=1,KNG(ICURSH)
          ICURGS=KSTART(ICURSH)+IGAUSS-1
          IF(INTYP(ICURSH).EQ.1)THEN
            WRITE(IP,8010)IGAUSS,EX(ICURGS),CSINP(ICURGS)
          END IF
          IF(INTYP(ICURSH).EQ.2)THEN
            WRITE(IP,8010)IGAUSS,EX(ICURGS),CPINP(ICURGS)
          END IF
          IF(INTYP(ICURSH).EQ.3)THEN
            WRITE(IP,8010)IGAUSS,EX(ICURGS),CDINP(ICURGS)
          END IF
          IF(INTYP(ICURSH).EQ.4)THEN
            WRITE(IP,8010)IGAUSS,EX(ICURGS),CFINP(ICURGS)
          END IF
          IF(INTYP(ICURSH).EQ.5)THEN
            WRITE(IP,8010)IGAUSS,EX(ICURGS),CGINP(ICURGS)
          END IF
          IF(INTYP(ICURSH).EQ.6)THEN
            WRITE(IW,*) 'TRUNCATION CANNOT CURRENTLY HANDLE H ORBITALS' 
            CALL ABRT
          END IF
          IF(INTYP(ICURSH).EQ.7)THEN
            WRITE(IW,*) 'TRUNCATION CANNOT CURRENTLY HANDLE I ORBITALS'
            CALL ABRT
          END IF
          IF(INTYP(ICURSH).EQ.8)THEN
            WRITE(IP,8010)IGAUSS,EX(ICURGS),CSINP(ICURGS),CPINP(ICURGS)
          END IF
  322   CONTINUE
  321 CONTINUE
      END IF
      GO TO 200
C
  400 CONTINUE
      IF (MASWRK) WRITE(IW,*) 'IT IS NOT POSSIBLE TO GET HERE!'
      CALL ABRT
      STOP
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
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
         C3 = ZERO
         C4 = ZERO
C                 READ (IR,*) IDUM,EX(K),C1,C2,C3,C4
         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
                         STOP
                      END IF
            C1 = RFIND('C1     ',IERR)
                      IF(IERR.NE.0) CALL ABRT
            C2 = RFIND('C2     ',IERR)
                      IF(IERR.NE.0) CALL ABRT
            C3 = RFIND('C3     ',IERR)
                      IF(IERR.NE.0) CALL ABRT
            C4 = RFIND('C4     ',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!'
               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
               STOP
            END IF
         END IF
C
         IF(RELNORM) THEN
            IF(IGAUSS.EQ.1) C1=ONE
            IF(IGAUSS.EQ.1) C2=ONE
            IF(IGAUSS.EQ.1) C3=ONE
            IF(IGAUSS.EQ.1) C4=ONE
         END IF
C
         IF (MASWRK .AND. (NTIME.EQ.1) .AND.
     *                  (ICNT2.LE.NATAB+NATBF) ) THEN
            IF(ITYP.LE.5) WRITE (IP,8010) IDUM,EX(K),C1
            IF(ITYP.EQ.6) WRITE (IP,8010) IDUM,EX(K),C1,C2
         END IF
         IF (MASWRK .AND. (NTIME.EQ.2) .AND.
     *                  (ICNT2.GT.NATAB) ) THEN
            IF(ITYP.LE.5) WRITE (IP,8010) IDUM,EX(K),C1
            IF(ITYP.EQ.6) 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) CSINP(K) = C1
         IF(ITYP.EQ.6) CPINP(K) = C2
         IF(ITYP.EQ.7) CSINP(K) = C1
         IF(ITYP.EQ.7) CPINP(K) = C2
         IF(ITYP.EQ.7) CDINP(K) = C3
         IF(ITYP.EQ.8) CSINP(K) = C1
         IF(ITYP.EQ.8) CPINP(K) = C2
         IF(ITYP.EQ.8) CDINP(K) = C3
         IF(ITYP.EQ.8) CFINP(K) = C4
         CS(K) = CSINP(K)
         CP(K) = CPINP(K)
         CD(K) = CDINP(K)
         CF(K) = CFINP(K)
         CG(K) = CGINP(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)
      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)
      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)
         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)
  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
      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)
            IF(IG .NE. JG) THEN
               DUMS = DUMS+DUMS
               DUMP = DUMP+DUMP
               DUMD = DUMD+DUMD
               DUMF = DUMF+DUMF
               DUMG = DUMG+DUMG
            END IF
            FACS = FACS+DUMS
            FACP = FACP+DUMP
            FACD = FACD+DUMD
            FACF = FACF+DUMF
            FACG = FACG+DUMG
  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(.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
  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. TM6) 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)
         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
      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
                  STOP
               END IF
               IF (MASWRK) WRITE(IW,9046)
     *            UATOM(I),UZNUC(I),(CUNIQ(I,J),J=1,3)
  910       CONTINUE
            CALL ABRT
            STOP
         END IF
         CALL RESHUF
      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     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
 1620 CONTINUE
      RETURN
C
 8000 FORMAT(3X,A4,I4)
 8010 FORMAT(3X,I3,1X,F20.10,2F12.8)
C
 9008 FORMAT(A10,F5.1,3F18.10)
 9009 FORMAT(1X,A10)
 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)
 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')
      END
C*MODULE INPUTB  *DECK MOLTWO
      SUBROUTINE MOLTWO(IUNTRD,ICOORD,NTIME)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      PARAMETER (MXATM=2000, MXGTOT=20000, MXAO=8192)
      PARAMETER (MAXA=103, MAXL=7)
C
      COMMON /BASISC/ GBASIS,AEX(MAXA,MAXL),ABASIS(MAXA,MAXL),
     *                IAGAUS(MAXA,MAXL),IRDBAS
      COMMON /FMCOM / X(1)
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /RUNLAB/ TITLE(10),ANAM(MXATM),BNAM(MXATM),BFLAB(MXAO)
C
C   THIS IS A SLIGHTLY CHANGED COPY OF MOLE WHICH IS USED TO SCAN
C   THE $DATA GROUP FOR THE SECOND TIME - TO GENERATE INPUT
C   DOCK FORM THE QM/MM RUN
C
C
C     ----- POSITION THE INPUT FILE TO $DATA -----
C
      CALL SEQREW(IR)
      CALL FNDGRP(IR,' $DATA  ',IEOF)
      IF(IEOF.NE.0) THEN
         IF(MASWRK) WRITE (IW,9028)
         CALL ABRT
         STOP
      END IF
C
C     READ TITLE CARD.
C
         IF (MASWRK) THEN
           READ (IR,9088) TITLE
           WRITE(IP,9008)
           WRITE(IP,9088) TITLE
         END IF
C
C        READ SYMMETRY POINT GROUP OF THE MOLECULE,
C        AND GENERATE THE TRANSFORMATION MATRICES.
C        LEAVE IT AS IT IS, EVEN THOUGH THE OUTPUT IS REDUNDANT
      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  .AND.  ICOORD.GT.0) CALL MBLDR(IUNTRD)
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
      LAST = LG + MXGTOT
      NEED = LAST - LS - 1
      CALL GETFM(NEED)
C  ASSUME THE BASIS SET IS NORMALIZED (.TRUE. AS THE LAST ARGUMENT)
      CALL ATMTWO(IUNTRD,X(LS),X(LP),X(LD),X(LF),X(LG),
     *            MXGTOT,ICOORD,NTIME,.TRUE.)
      CALL RETFM(NEED)
      RETURN
C
 9008 FORMAT(' $DATA')
 9028 FORMAT(1X,'**** ERROR, NO $DATA GROUP WAS FOUND')
 9088 FORMAT(10A8)
      END
C*MODULE EFPCOV  DECK MOIDSM
      SUBROUTINE MOIDSM(IVFILE)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      PARAMETER (MXATM=2000)
C
C
      COMMON /FMCOM / X(1)
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
C
      L1 = NUM
      L2 = (L1*L1+L1)/2
      L3 = L1*L1
C
C     ----- PARTITION FAST MEMORY -----
C
      CALL VALFM(LOADFM)
      LMOIDN = 1 + LOADFM
      LNMOAT = LMOIDN + 5*NA
      LSVEC  = LNMOAT + NA
      LV     = LSVEC  + L3
      LARRAY = LV     + L3
      LAMOD  = LARRAY + L2
      LOCC   = LAMOD  + NA
      LZMO   = LOCC   + 5*NA
      LAST   = LZMO   + NAT
C
      NEED = LAST - LOADFM - 1
      CALL GETFM(NEED)
C
      CALL MOIDSH(X(LSVEC),X(LV),X(LARRAY),X(LAMOD),L1,L2,NA,NAT,IVFILE)
C
      CALL RETFM(NEED)
      RETURN
      END
C*MODULE EFPCOV  *DECK MOIDSH
C      SUBROUTINE MOIDSH(SVEC,V,ARRAY,AMODEN,MOIDNO,NMOAT,OCCUP,ZMO,
C     *                  L1,L2,LNA,LNAT,IVFILE)
      SUBROUTINE MOIDSH(SVEC,V,ARRAY,AMODEN,
     *                  L1,L2,LNA,LNAT,IVFILE)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK,MOIDON,EDCOMP,DIPDCM,DEPRNT,QADDCM,
     *        ZDO,POLDCM,POLANG,POLAPP,KMIDPT,POLDYN
C
      PARAMETER (MXATM=2000, MXSH=5000, MXGTOT=20000, NMO=500)
C
      DIMENSION SVEC(L1,L1),V(L1,L1),ARRAY(L2),AMODEN(LNAT)
C
      COMMON /EDCMP / ZIJ(NMO),ZMO(5,NMO),OCCUP(NMO),DPFREQ(50),
     *                MOIDNO(5,NMO),IJMO(2,NMO),MOIJ(NMO),NMOIJ(NMO),
     *                NMOAT(NMO),NDPFREQ,IPROT(5),NPROT,
     *                MOIDON,EDCOMP,DIPDCM,DEPRNT,QADDCM,ZDO,POLDCM,
     *                POLANG,POLAPP,KMIDPT,POLDYN
      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 /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      COMMON /WFNOPT/ SCFTYP,VBTYP,DFTYPE,TDDFTYP,CITYP,CCTYP,
     *                MPLEVL,MPCTYP
C
      PARAMETER (ZERO=0.0D+00,ONE=1.0D+00, TWO=2.0D+00, VTOL=0.15D+00)
C
      DATA RHF,ROHF/8HRHF     ,8HROHF    /
      DATA DEBUG/8HDEBUG   /
C
C     ----- THIS SUBROUTINE IDENTIFIES  (L)MOS USING THE NORMALIZED
C      MULLIKEN POPULATION. IT IS A SIMPLIFIED VERSION OF MOID ROUTINE
C      AND SHORTENED VERSION OF MOIDBF
C
      CALL DAREAD(IDAF,IODA,V    ,L1*L1,IVFILE,0)
      CALL DAREAD(IDAF,IODA,ARRAY,L2   ,12,0)
      CALL CPYTSQ(ARRAY,SVEC,L1,1)
C
C     GENERATE THE OCCUPATION NUMBERS
C
      CALL VCLR(OCCUP,1,NAT)
      DO 100 I=1,LNA
         IF (SCFTYP .EQ. RHF)  OCCUP(I) = TWO
         IF (SCFTYP .EQ. ROHF) THEN
            IF (I.LE.NB) THEN
               OCCUP(I) = TWO
            ELSE
               OCCUP(I) = ONE
            END IF
         END IF
  100 CONTINUE
C
      DO 490 K = 1,LNA
         CALL VCLR(AMODEN,1,NAT)
         ICN = 0
         I = 0
         DO 390 II = 1,NSHELL
            IAT = KATOM(II)
            MINI = KMIN(II)
            MAXI = KMAX(II)
            DO 380 N = MINI,MAXI
               I = I + 1
               CXS = ZERO
               DO 370 L = 1,L1
                  CXS = CXS + V(L,K)*SVEC(L,I)
  370          CONTINUE
               AMODEN(IAT) = AMODEN(IAT) + V(I,K)*CXS
  380       CONTINUE
  390    CONTINUE
C
         IF(EXETYP.EQ.DEBUG .AND. MASWRK) THEN
         NMIN = MIN(NAT,11)
           WRITE(IW,*) 'NORMALIZED MULL. POP. FOR EACH LMO'
           WRITE(IW,FMT='(1X,I3,2X,11F6.3)') K, (AMODEN(JJ), JJ=1,NMIN)
           IF (NAT .GT. 11) WRITE(IW,FMT='(6X,      11F6.3)')
     *                                        (AMODEN(JJ), JJ=12,NAT)
         END IF
         DO 450 JJ = 1,NAT
            AVAL = AMODEN(JJ)
            IF (AVAL.GE.VTOL) THEN
               IATOM = JJ
               ICN = ICN + 1
               MOIDNO(ICN,K) = IATOM
            END IF
  450    CONTINUE
         NMOAT(K) = ICN
         DO 470 JJ = 1,ICN
            ZMO(JJ,K) = OCCUP(K)/ICN
  470    CONTINUE
  490 CONTINUE
C
C     ----- $LOCAL VALUES ARE NOW TRANSFERRED TO APPROPRIATE
C     ARRAYS -----
C
      DO 680 L = 1,NMO
         I = IJMO(1,L)
         J = IJMO(2,L)
         IF (MOIJ(L) .GT. 0) MOIDNO(I,J) = MOIJ(L)
         IF (ZIJ(L) .GE. ZERO) ZMO(I,J) = ZIJ(L)
         IF (NMOIJ(L) .GE. ZERO) NMOAT(L) = NMOIJ(L)
  680 CONTINUE
      IF (EXETYP.EQ.DEBUG.AND.MASWRK) THEN
         WRITE(IW,9000)
         DO 700 K = 1,LNA
            ICN = NMOAT(K)
            WRITE(IW,9100) K, (MOIDNO(J,K),ZMO(J,K),J=1,ICN)
  700    CONTINUE
      END IF
      RETURN
C
 9000 FORMAT(/1X,'ATOMS ARE ASSIGNED TO THE MOS BASED ON THEIR ',
     *       'MULLIKEN POPULATION.  LMO NUCLEAR CHARGE IS IN ()')
 9100 FORMAT(1X,'ORBITAL ',I3,' BELONGS TO ATOM(S) ',
     *       3(I3,' (',F4.2,') '))
      END
