C 19 SEP 05 - MK  - MMPINF INACTIVED, READ FROM EXTERNAL FILE IN MMPRED
C  5 JUL 05 - MWS - SELECT NEW ATOM,BASIS,EFP,PCM,DAF DIMENSIONS
C 13 FEB 05 - MWS - PAD COMMON BLOCK NSHEL
C  9 DEC 03 - MWS - SYNCH COMMON BLOCK RUNOPT
C 16 JUN 03 - MWS - MODEL CORE POTENTIALS INCLUDED IN GAMESS
C 30 JUN 01 - MK  - MMPCOR: PRINT ADJUSTED ELECTRON COUNTS; PASS IZCORE
C 23 AUG 00 - MK  - READING/WRITING FOR MASWRK ONLY
C 22 AUG 00 - MK  - READ MCPFMT (FOR OLD MCP FILES)
C 17 AUG 00 - MK  - FIX OUT=MASWRK PRINTING
C 17 JUN 00 - MK  - FIX PROBLEMS WITH AIX
C 11 JUN 97 - MK  - IN MMPINP, SET COEF TO 1.0 IF IGAUSS=1
C 10 JUN 97 - MK  - ADD IW UNIT TO MMPINF
C 22 DEC 94 - DK  - EXTEND MAX.NO. CORE-PGTF PER ATOM FROM 150 TO 320
C                   CHECK IF LIMIT EXCEEDED BUILT-IN
C
C*MODULE MCPINP  *DECK MMPCOR
C
      SUBROUTINE MMPCOR
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK,OUT
C
      PARAMETER (MXATM=2000, MXAO=8192)
C
C     --- MXMPA:   MAX.NO.OF MOD.POT. A-TERMS FOR GIVEN N-VALUE
C     --- MXMPSH:  MAX.NO.OF CORE-SHELLS IN ALL MOD.POT.ATOMS
C     --- MXMPGT:  MAX.NO.OF PGTFS FOR ALL CORE-SHELLS IN MOD.POT.ATOMS
C     --- MXCPGA:  MAX.NO.OF CORE-PGTFS FOR ONE MOD.POT.ATOM
C
      PARAMETER (MXMPA=3*MXATM)
      PARAMETER (MXMPSH=2*MXATM, MXMPGT=5*MXMPSH)
      PARAMETER (MXCPGA=320,ZERO=0.0D+00)
C
C     --- MODEL-POTENTIAL VARIABLES
      CHARACTER*20  CDFCTR(15),SHINFO
      DIMENSION AN0I(10),ALPN0I(10),AN1I(10),ALPN1I(10)
      DIMENSION BPARI(15),KNGI(15),KTYPI(15)
      DIMENSION EXPI(MXCPGA),CMPI(MXCPGA)
      DIMENSION CTMP(MXMPGT)
      DIMENSION INFTYP(10)
      DIMENSION CSNORM(MXCPGA),CPNORM(MXCPGA),CDNORM(MXCPGA),
     *          CFNORM(MXCPGA)
C
      COMMON /ECP2  / CLP(400),ZLP(400),NLP(400),KFIRST(MXATM,6),
     *                KLAST(MXATM,6),LMAX(MXATM),LPSKIP(MXATM),
     *                IZCORE(MXATM)
C     DIMENSION       NZCORE(MXATM)
      COMMON /INFOA / NATOMS,ICH,MUL,NBASIS,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /INTOPT/ ISCHWZ,IECP,NECP,IEFLD
      COMMON /IOFILE/ IR,IW,IP,IJK,IPK,IDAF,NAV,IODA(950)
      COMMON /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /RUNLAB/ TITLE(10),A(MXATM),B(MXATM),BFLAB(MXAO)
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
C
C     --- MODEL-POTENTIAL PARAMETERS AND CORE-SHELL BASIS-SET INFO
C     --- (SEE SUBROUTINE ECPPAR FOR INPUT)
      COMMON /MMPDOC/ MPTYP(MXATM)
      COMMON /MMP1  / AN0(MXMPA),ALPN0(MXMPA),AN1(MXMPA),ALPN1(MXMPA),
     2                MPSKP(MXATM),NOAN0(MXATM),NOAN1(MXATM)
C
      COMMON /MMP2  /BPAR(MXMPSH),EXPMP(MXMPGT),CSMP(MXMPGT),
     2               CPMP(MXMPGT),CDMP(MXMPGT),CFMP(MXMPGT),
     3               MPSKIP(MXATM),NOCOSH(MXATM),MPKSTA(MXMPSH),
     4               MPKNG(MXMPSH),MPKTYP(MXMPSH),MPKMIN(MXMPSH),
     5               MPKMAX(MXMPSH),MPKLOC(MXMPSH)
C
      DOUBLE PRECISION LABEL(8)
      DIMENSION MINF(8),MAXF(8)
C
      DATA LABEL/8HS       ,8HP       ,8HD       ,8HF       ,
     *           8HG       ,8HH       ,8HI       ,8HL       /
      DATA MINF/ 1, 2, 5,11,21,36,57,   1/
      DATA MAXF/ 1, 4,10,20,35,56,84,   4/
C
      DATA DBUG,DBUGME/8HDEBUG   ,8HMCPCOR  /
C
      OUT = (NPRINT.EQ.3 .OR. EXETYP.EQ.DBUG .OR. EXETYP.EQ.DBUGME)
     *      .AND. MASWRK
C
C     --- MODEL-POTENTIAL VARIABLES:
C     --- IMP:     A-TERMS (N=0) CONSECUTIVELY NUMBERED
C     --- JMP:     A-TERMS (N=1) CONSECUTIVELY NUMBERED
C     --- ICORSH:  CORE-SHELLS CONSECUTIVELY NUMBERED
C     --- IGTF:    PGTFS CONSECUTIVELY NUMBERED
C     --- MPCELC:  NO.OF REMOVED CORE-ELECTRONS
C     --- MPKLOC:  NUMBERS ALL (CONTRACTED) BASIS FUNCTIONS
C     --- MPSKIP=0 FOR MODEL-POTENTIAL ATOM
C         (MPSKP IN MMP1 AND MPSKIP IN MMP2)
C
      IMP=0
      JMP=0
      ICORSH=0
      IGTF  =0
      MPCELC=0
      MPKLOC(1)=1
C
C     IZCORE IS THE NUMBER OF ELECTRONS REMOVED FROM EACH ATOM.
C
      DO 3 I=1,NATOMS
         LPSKIP(I) = 1
         MPSKIP(I) = 1
         MPSKP(I)  = 1
         IZCORE(I) = 0
    3 CONTINUE
      IF (MASWRK) WRITE(IW,8000)
C
C     --- SUM OVER ALL ATOMS
C
      DO 200 ICNTR=1,NATOMS
C
        MTYP=MPTYP(ICNTR)
C       --- SKIP IF NOT MOD.POT.ATOM
        IF (MTYP.EQ.0) GOTO 200
        MPSKIP(ICNTR)=0
        MPSKP(ICNTR) =0
        LPSKIP(ICNTR)=0
        IZSAVE=INT(ZAN(ICNTR)+0.01D+00)
        IF(OUT) WRITE(IW,*)
     1     '@MMPCOR: ICNTR MTYP IZSAVE',ICNTR,MTYP,IZSAVE
C
        IF (MTYP.EQ.3) THEN
C         --- READ MODEL-POTENTIAL FROM  $MCP GROUP
          CALL MMPRED(ICNTR,NOCOSI,KTYPI,KNGI,EXPI,CMPI,ZCORE,
     2              NOAN0I,NOAN1I,AN0I,ALPN0I,AN1I,ALPN1I,BPARI)
        ELSE
C        --- READ THE MODEL-POTENTIAL FROM ROUTINE MCPLIB ---
         MMPMOD=1
         CALL MCPLIB(MMPMOD,IZSAVE,MTYP,SHINFO,CDFCTR,NOCOSI,KTYPI,KNGI,
     2              EXPI,CMPI,ZCORE,NOAN0I,NOAN1I,AN0I,ALPN0I,AN1I,
     3              ALPN1I,BPARI,INFTYP,IERR)
        END IF
        IZCORE(ICNTR) = INT(ZCORE+0.01D+00)
        NOAN0(ICNTR)  = NOAN0I
        NOAN1(ICNTR)  = NOAN1I
        DO 80 L=1,NOAN0I
          IMP=IMP+1
          AN0(IMP)  = AN0I(L)
          ALPN0(IMP)= ALPN0I(L)
   80  CONTINUE
       DO 82 L=1,NOAN1I
          JMP=JMP+1
          AN1(JMP)  = AN1I(L)
          ALPN1(JMP)= ALPN1I(L)
   82  CONTINUE
       NOCOSH(ICNTR)=NOCOSI
C      --- ICORSH:         CORE-SHELLS CONSECUTIVELY NUMBERED
C      --- NOCOSI:         NO.OF B-TERMS (CORE-SHELLS) IN ATOM ICNTR
C      --- BPAR(ICORSH):   B-PARAMETER OF CORE-SHELL ICORSH
C      --- MPKNG(ICORSH):  NO.OF PGTFS IN CORE-SHELL ICORSH
C      --- MPKSTA(ICORSH): NO.OF THE FIRST PGTF IN SHELL ICORSH
C      --- MPKTYP(ICORSH): 1+HIGHEST ANG.MOM.OF SHELL ICORSH
C      --- MPKMIN(ICORSH): NO.OF THE FIRST FCT AMONG S,PX,PY,... PGTFS
C                          (SEE KMIN,KMAX IN ATOMS)
C      --- MPKMAX(ICORSH): NO.OF THE LAST  FCT AMONG S,PX,PY,... PGTFS
C      --- MPKLOC(ICORSH): 1+SUM(OVER ALL SHELLS ICORSH-1) OF THE NUMBER
C                          OF THE S,PX,PY,... PGTFS PER SHELL
C
       LMP=0
       DO 88 L=1,NOCOSI
         ICORSH=ICORSH+1
         BPAR(ICORSH)  = BPARI(L)
         NOGTF         = KNGI(L)
         MPKNG(ICORSH) = NOGTF
         KTYPIL        = KTYPI(L)
         MPKTYP(ICORSH)= KTYPIL
         KMINIL        = MINF(KTYPIL)
         MPKMIN(ICORSH)= KMINIL
         KMAXIL        = MAXF(KTYPIL)
         MPKMAX(ICORSH)= KMAXIL
         MPKLOC(ICORSH+1)=MPKLOC(ICORSH)+KMAXIL-KMINIL+1
C
         MPKSTA(ICORSH)= IGTF+1
         MINGTF=LMP+1
         MAXGTF=LMP+NOGTF
C
         DO 84 K=1,NOGTF
C          --- IGTF:      ALL PGTFS CONSECUTIVELY NUMBERED
           LMP=LMP+1
           CSNORM(LMP)=ZERO
           CPNORM(LMP)=ZERO
           CDNORM(LMP)=ZERO
           CFNORM(LMP)=ZERO
C
           IF (KTYPIL.EQ.1) CSNORM(LMP)=CMPI(LMP)
           IF (KTYPIL.EQ.2) CPNORM(LMP)=CMPI(LMP)
           IF (KTYPIL.EQ.3) CDNORM(LMP)=CMPI(LMP)
           IF (KTYPIL.EQ.4) CFNORM(LMP)=CMPI(LMP)
           IF (KTYPIL.EQ.6) CSNORM(LMP)=CMPI(LMP)
           IF (KTYPIL.EQ.6) CPNORM(LMP)=CMPI(LMP)
   84    CONTINUE
C
C        --- NORMALIZE THE CONTRACTED CORE-SHELL BASIS FUNCTIONS
         MPNORF=0
         MPNORP=0
         CALL MMPNOR(IZSAVE,L,MPNORF,MPNORP,
     *        MINGTF,MAXGTF,EXPI,CSNORM,CPNORM,CDNORM,CFNORM)
C
         DO 86 KMP=MINGTF,MAXGTF
           IGTF   = IGTF+1
           EXPMP(IGTF) = EXPI(KMP)
           CSMP(IGTF)=CSNORM(KMP)
           CPMP(IGTF)=CPNORM(KMP)
           CDMP(IGTF)=CDNORM(KMP)
           CFMP(IGTF)=CFNORM(KMP)
           CTMP(IGTF)=CMPI(KMP)
   86    CONTINUE
   88  CONTINUE
C
C      CHECK NO.OF CORE-PGTFS FOR THIS ATOM
C
       IF (KMP.GT.MXCPGA) THEN
          WRITE(IW,8020) KMP,MXCPGA
          CALL ABRT
       ENDIF
C
C       --- END OF MODEL-POTENTIAL PART ---
C
C       ADJUST THE NUMBER OF ELECTRONS AND THE NUCLEAR CHARGE
C
          NE = NE-IZCORE(ICNTR)
          NA = NA-IZCORE(ICNTR)/2
          NB = NB-IZCORE(ICNTR)/2
          ZAN(ICNTR)=ZAN(ICNTR)-IZCORE(ICNTR)
          MPCELC = MPCELC + IZCORE(ICNTR)
C     --- END OF SUM OVER ATOMS
  200 CONTINUE
      NECP = MPCELC
C     --- ADJUST THE NUCLEAR REPULSION ENERGY
      VNN= ENUC(NATOMS,ZAN,C)
      IF(MASWRK) THEN
        WRITE(IW,8040) MPCELC,NE,NA,NB
        WRITE(IW,8050) VNN
      ENDIF
C
C     --- PRINT MODEL-POTENTIAL-PARAMETERS
C
      IF (MASWRK) THEN
        IMP=0
        JMP=0
        WRITE (IW,9000)
        WRITE (IW,9010)
C       --- SUM OVER ALL ATOMS
        DO 760 ICNTR=1,NATOMS
          MTYP=MPTYP(ICNTR)
C         --- SKIP IF NOT MOD.POT.ATOM
          IF (MTYP.EQ.0) GOTO 760
          WRITE (IW,9020) A(ICNTR),B(ICNTR)
          NOAN0I = NOAN0(ICNTR)
          NOAN1I = NOAN1(ICNTR)
          N=0
          DO 720 L=1,NOAN0I
            IMP=IMP+1
            WRITE(IW,9030) L,N,ALPN0(IMP),AN0(IMP)
  720     CONTINUE
          N=1
          DO 740 L=1,NOAN1I
            JMP=JMP+1
            WRITE(IW,9030) L,N,ALPN1(JMP),AN1(JMP)
  740     CONTINUE
  760   CONTINUE
      END IF
C
C     --- PRINT CORE-BASIS-SET FOR MODEL-POTENTIAL ATOMS
C
      IF (MASWRK) THEN
        ICORSH=0
        IGTF  =0
        WRITE (IW,9080)
        WRITE (IW,9110)
C       --- SUM OVER ALL ATOMS
        DO 800 ICNTR=1,NATOMS
          MTYP=MPTYP(ICNTR)
C         --- SKIP IF NOT MOD.POT.ATOM
          IF (MTYP.EQ.0) GOTO 800
          WRITE (IW,9120) A(ICNTR),B(ICNTR)
          NOCOSI=NOCOSH(ICNTR)
          LMP=0
          DO 790 L=1,NOCOSI
            ICORSH=ICORSH+1
            BPARL        = BPAR(ICORSH)
            NOGTF        = MPKNG(ICORSH)
            KTYPL        = MPKTYP(ICORSH)
            WRITE(IW,9130)
            WRITE(IW,9135) ICORSH,LABEL(KTYPL),BPARL
            MINGTF=LMP+1
            MAXGTF=LMP+NOGTF
C
            DO 780 KMP=MINGTF,MAXGTF
              IGTF   = IGTF+1
              EX = EXPMP(IGTF)
              C2 = CTMP(IGTF)
              IF (KTYPL.EQ.1) C1=CSMP(IGTF)
              IF (KTYPL.EQ.2) C1=CPMP(IGTF)
              IF (KTYPL.EQ.3) C1=CDMP(IGTF)
              IF (KTYPL.EQ.4) C1=CFMP(IGTF)
C             --- L-SHELL NOT IMPLEMENTED YET
C              IF (KTYPL.EQ.8) C1=CSMP(IGTF)
C              IF (KTYPL.EQ.8) C1=CSMP(IGTF)
              WRITE(IW,9140) ICORSH,LABEL(KTYPL),IGTF,EX,C1,C2
  780      CONTINUE
  790    CONTINUE
C
  800 CONTINUE
      END IF
      RETURN
C
 8000 FORMAT(/10X,16(1H-)/10X,'MODEL-POTENTIALS'/10X,16(1H-))
 8020 FORMAT(1X,I3,' EXCEEDS MAX.NO.OF CORE-PGTFS FOR A ',
     *       'MODEL-POTENTIAL ATOM.  THE MAX.NO. IS: ',I3)
 8040 FORMAT(/1X,'THE MCP RUN REMOVES',I5,' CORE ELECTRONS, ',
     *       'AND THE SAME NUMBER OF PROTONS.'/
     *        1X,'NUMBER OF ELECTRONS KEPT IN THE CALCULATION IS =',I5/
     *        1X,'NUMBER OF OCCUPIED ORBITALS (ALPHA) KEPT IS    =',I5/
     *        1X,'NUMBER OF OCCUPIED ORBITALS (BETA ) KEPT IS    =',I5)
 8050 FORMAT(1X,'THE ADJUSTED NUCLEAR REPULSION ENERGY=',F20.10)
 9000 FORMAT(/5X,'MODEL-POTENTIAL PARAMETERS',
     *       /5X,26(1H-))
 9010 FORMAT(/2X,'NO.    N',7X,'ALPHA',11X,'A')
 9020 FORMAT(/1X,A8,A2)
 9030 FORMAT(1X,I3,3X,I3,F15.6,F12.6)
 9080 FORMAT(/5X,'CORE-SHELL BASIS SET FOR MODEL-POTENTIAL ATOMS',
     *       /5X,46(1H-))
 9110 FORMAT(/1X,'SHELL TYPE PRIM    EXPONENT',
     *       10X,'CONTRACTION COEFFICIENTS')
 9120 FORMAT(/1X,A8,A2)
 9130 FORMAT(1X)
 9135 FORMAT(1X,I3,3X,A2,3X,'PARAMETER B = ',F16.6)
 9140 FORMAT(1X,I3,3X,A2,I4,F17.6,3(F12.6,' (',F10.6,') '))
      END
C
C*MODULE MCPINP  *DECK MMPINF
C
C     --- PRINTS MODEL-POTENTIAL INFO IN A ECP=MMPINFO RUN
C     --- CALLED FROM SUBROUTINE ATOMS IN MODULE INPUTA
C     
C
      SUBROUTINE MMPINF(NUCZ,CSINP,
     *         IERR1,IERR2,INTYP,
     *         LOC,NGAUSS,NS)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      PARAMETER (MXSH=5000, MXGTOT=20000, MXATM=2000, MXAO=8192)
      PARAMETER (MXCPGA=320)
C
      DIMENSION CSINP(*),INTYP(*),NS(*)
C
C     --- PARAMETERS FOR ROUTINE-CALL MCPLIB
C
      CHARACTER*20  CDFCTR(15)
      DIMENSION KTYPV(15),KNGV(15)
      DIMENSION EEX(MXCPGA),CC(MXCPGA)
      DIMENSION AN0I(10),ALPN0I(10),AN1I(10),ALPN1I(10)
      DIMENSION BPARI(15)
      DIMENSION INFTYP(10)
C
      CHARACTER*20 CCTR(5),SHINFO
      CHARACTER*1  CCT(20,5)
      CHARACTER*2  LABEL2(8)
      CHARACTER*20 SPACE20
C
      EQUIVALENCE (CCTR,CCT)
      DOUBLE PRECISION LTYP(4)
C
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /IOFILE/ IR,IW,IP,IJK,IPK,IDAF,NAV,IODA(950)
      COMMON /INTOPT/ ISCHWZ,IECP,NECP,IEFLD
      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 /MMPDOC/ MPTYP(MXATM)
      COMMON /RUNLAB/ TITLE(10),A(MXATM),B(MXATM),BFLAB(MXAO)
C
      DATA LTYP /8HNR      ,8HQR      ,8HREAD    ,8H        /
      DATA LABEL2   /'S ','P ','D ','F ','G ','H ','I ','L '/
      DATA SPACE20 /'                    '/
C -----
C
      IF(IW.GT.0) RETURN
C
C -----
C
C     --- IF IT IS THE FIRST MOD.POT.ATOM, PRINT TITLE
C
      ISUM=0
      DO 60 I=1,(NAT-1)
        ISUM=ISUM+MPTYP(I)
  60  CONTINUE
      IF ((ISUM.EQ.0).AND.(IECP.EQ.6)) THEN
C       --- PRINT TITLE FOR MMPINFO-RUN
          WRITE(IW,9010)
          WRITE(IW,9020)
          WRITE(IW,9030)
      END IF
C
C     --- SET MATRIX OF CONTRACTION PATTERN ZERO
C
      DO 110 I=1,5
        CCTR(I)=SPACE20
C       DO 100 J=1,20
C         ICNTR(J,I)=0
C100  CONTINUE
 110  CONTINUE
C
C     --- SET TO A NOT-POSSIBLE MOD.POT.TYPE
      MTYP=-1
C
C     --- GET VALENCE-SHELL BASIS-SET -> MMPMOD=0
C     --- INPUT: NUCZ    CHARGE OF ATOM
C     ---        MTYP  MOD.POT.TYPE
C
      MMPMOD=0
C     --- SCAN THROUGH ALL TEN POSSIBLE MODEL-POTENTIALS
      DO 130 KK=1,10
C
      CALL MCPLIB(MMPMOD,NUCZ,MTYP,SHINFO,CDFCTR,NOFCVS,KTYPV,KNGV,
     2            EEX,CC,ZCORE,NOAN0I,NOAN1I,AN0I,ALPN0I,AN1I,
     3            ALPN1I,BPARI,INFTYP,IERR)
C
C     --- CDFCTR(I) CODED DEFAULT CONTRACTION OF SHELL I
C     --- NOFCVS    NO.OF FULLY CONTRACTED VAL.SHELLS
C     --- KTYPV(I)  TYPE OF SHELL I
C     --- KNGV(I)   NO.OF GTFS IN SHELL I
C     --- IERR      0: OK  1: NOT MCP-ATOM  2: MPTYP WRONG
C
C     --- IF WRONG MTYP, TRY THE NEXT ONE
      IF (IERR.EQ.2) THEN
         MTYP=INFTYP(KK)
         GOTO 130
      END IF
      IF (IERR.EQ.1) THEN
         WRITE(IW,9060) A(NAT),B(NAT),NUCZ
         GOTO 300
      END IF
C
C     --- SUM OVER FULLY CONTRACTED VALENCE-SHELLS
      DO 250 II=1,NOFCVS
C       --- TAKE DEFAULT CONTRACTION
        CCTR(II)=CDFCTR(II)
  250 CONTINUE
C
C     ---  GET NO.OF MOD.POT.TYP (NR,QR,RD,...)
C
      JJ=MOD(MTYP,10)
C
C     --- WRITE MODEL-POTENTIAL TYPE
C
      WRITE(IW,9100) A(NAT),B(NAT),NUCZ,ZCORE,LTYP(JJ),
     *   SHINFO,LABEL2(KTYPV(1)),CCTR(1),LABEL2(KTYPV(2)),
     *   CCTR(2)
      IF (NOFCVS.GT.2) WRITE(IW,9110)
     *   LABEL2(KTYPV(3)),CCTR(3),LABEL2(KTYPV(4)),CCTR(4)
      IF (NOFCVS.GT.4) WRITE(IW,9120)
     *   LABEL2(KTYPV(5)),CCTR(5)
C
      MTYP=INFTYP(KK)
C     --- GO BACK TO READ ANOTHER MODEL-POTENTIAL
 130  CONTINUE
C
C     --- FEED IN ONE S-FUNCTION, OTHERWISE THE JOB MIGHT BE
C     --- TERMINATED AS THERE IS NO BASISFUNCTION FOR THIS CENTER
C
 300  CONTINUE
C     --- RETURN MPTYP TO RECOGNIZE THIS ATOM AS MOD.POT.ATOM
      MPTYP(NAT)=-1
      NSHELL = NSHELL+1
      IF(NSHELL.GT.MXSH) THEN
        IERR1=1
        RETURN
      END IF
      NS(NAT) = NS(NAT)+1
      KMIN(NSHELL) = 1
      KMAX(NSHELL) = 1
      KSTART(NSHELL) = NGAUSS+1
      KATOM(NSHELL) = NAT
      KTYPE(NSHELL) = 1
      INTYP(NSHELL) = 1
      KNG(NSHELL) =   1
      KLOC(NSHELL) = LOC+1
      NGAUSS = NGAUSS+1
      IF(NGAUSS.GT.MXGTOT) THEN
        IERR2=1
        RETURN
      END IF
      LOC = LOC+1
      K1 = KSTART(NSHELL)
      EX(K1)    = 1.00D+00
      CSINP(K1) = 1.00D+00
C     --- UNNORMALIZED COEFFICIENT
      CS(K1) =    0.712705D+00
C
      RETURN
C
 9010 FORMAT(/5X,41(1H-),/19X,'MCPINFO-RUN:')
 9020 FORMAT(/5X,'BUILT-IN MODEL-POTENTIALS FOR GIVEN ATOMS',
     *       /5X,41(1H-))
 9030 FORMAT(/1X,'ATOM',5X,'ATOMIC',2X,' CORE- ',2X,'TYPE',3X,
     *      'VALENCE-',7X,'DEFAULT-CONTRACTION',/10X,'CHARGE',
     *      1X,'ELECTRONS',8X,'SHELLS')
 9060 FORMAT(/1X,A8,A2,I3,20X,'NO MODEL-POTENTIAL BUILT-IN')
 9100 FORMAT(/1X,A8,A2,I3,5X,F3.0,6X,A6,A15,2(A2,A15))
 9110 FORMAT(49X,2(A2,A20))
 9120 FORMAT(49X,A2,A20)
C
      END
C
C*MODULE MCPINP  *DECK MMPINP
C
C     - TO CHANGE:
C     -    HOW MANY VAL-SHELLS POSSIBLE DUE TO CODE-WORD MTYP?
C
      SUBROUTINE MMPINP(NUCZ,CSINP,CPINP,CDINP,CFINP,
     *         IERR1,IERR2,INTYP,NANGM,NBFS,MINF,MAXF,
     *         LOC,NGAUSS,NS)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      PARAMETER (MXSH=5000, MXGTOT=20000, MXATM=2000, MXAO=8192)
      PARAMETER (MXCPGA=320)
C
      DIMENSION CSINP(*),CPINP(*),CDINP(*),CFINP(*),
     *          INTYP(*),NANGM(*),NBFS(*),MINF(*),MAXF(*),NS(*)
C
C     --- PARAMETERS ROUTINE-CALL MCPLIB
C
      CHARACTER*20  CDFCTR(15)
      DIMENSION KTYPV(15),KNGV(15)
      DIMENSION EEX(MXCPGA),CC(MXCPGA)
      DIMENSION AN0I(10),ALPN0I(10),AN1I(10),ALPN1I(10)
      DIMENSION BPARI(15)
      DIMENSION INFTYP(10)
C
C
      DIMENSION ICNTR(20,15)
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      CHARACTER*20 RSTRNG,STRNG,CCTR(5),SHINFO
      CHARACTER*1  CCT(20,5),SPACE1,CNUM
      CHARACTER*2  LABEL2(8)
      CHARACTER*8  RTYP
      CHARACTER*20 LABEL(8),SPACE20
C
      EQUIVALENCE (CCTR,CCT)
      DOUBLE PRECISION LTYP(8)
C
C
      COMMON /MMPDOC/ MPTYP(MXATM)
C
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /IOFILE/ IR,IW,IP,IJK,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 /RUNLAB/ TITLE(10),A(MXATM),B(MXATM),BFLAB(MXAO)
C
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00, PT5=0.5D+00, PT75=0.75D+00)
      PARAMETER (PI32=5.56832799683170D+00, PT187=1.875D+00)
      PARAMETER (TOL=1.0D-10)
C
      DATA LTYP /8HNR      ,8HQR      ,8HREAD    ,8H        ,
     +           8HNRLC    ,8HNRSC    ,8HQRLC    ,8HQRSC    /
      DATA LABEL2   /'S ','P ','D ','F ','G ','H ','I ','L '/
      DATA LABEL/'S                   ','P                   ',
     *           'D                   ','F                   ',
     *           'G                   ','H                   ',
     *           'I                   ','L                   '/
      DATA SPACE20 /'                    '/
      DATA SPACE1  /' '/
C
C     --- IF IT IS THE FIRST MCP ATOM, PRINT TITLE
      ISUM=0
      DO 60 I=1,(NAT-1)
        ISUM=ISUM+MPTYP(I)
  60  CONTINUE
      IF (ISUM.EQ.0 .AND. MASWRK) THEN
         WRITE(IW,9000)
         WRITE(IW,9010)
      END IF
      RTYP = '        '
      LENGST = -8
      CALL GSTRNG(RTYP,LENGST)
      READ(UNIT=RTYP,FMT='(A8)') TYP
C     WRITE(*,FMT='(A,I4,A)') ' NUCZ TYP',NUCZ,TYP
      DO 120 I=1,8
        IF (TYP.EQ.LTYP(I)) THEN
          MTYP=I
          GOTO 130
        END IF
 120  CONTINUE
C     --- UNRECOGNIZED STRING
      IF(MASWRK) WRITE(IW,9015) A(NAT),B(NAT),NUCZ,TYP
      CALL ABRT
      STOP
 130  CONTINUE
C     WRITE(*,*) 'MTYP',MTYP
C     MOPTION=1
C NRLC
      IF(MTYP.EQ.5) THEN
        MCPREL=1
        MCPCOR=1
      ENDIF
C NRSC
      IF(MTYP.EQ.6) THEN
        MCPREL=1
        MCPCOR=2
      ENDIF
C QRLC
      IF(MTYP.EQ.7) THEN
        MCPREL=2
        MCPCOR=1
      ENDIF
C QRSC
      IF(MTYP.EQ.8) THEN
        MCPREL=2
        MCPCOR=2
      ENDIF
C ... TYP=4 DEFAULTS -- OPTIONS NEED FIXING!
      IF(MTYP.EQ.4) THEN
C--     MOPTION=0
        MCPTYP=1
        IF(NUCZ.LE.36) THEN
          MCPREL=1
        ELSE
          MCPREL=2
        ENDIF
        MCPCOR=1
        IF(NUCZ.EQ.11 .OR. NUCZ.EQ.12 .OR.
     +     NUCZ.EQ.19 .OR. NUCZ.EQ.20 .OR.
     +     NUCZ.EQ.37 .OR. NUCZ.EQ.38 .OR.
     +     NUCZ.EQ.55 .OR. NUCZ.EQ.56) THEN
           MCPCOR=2
        ENDIF
      ENDIF
C     WRITE(*,*) 'MTYP',MTYP
      IF (MTYP.EQ.3) THEN
        MPTYP(NAT)=MTYP
C       -- MOD.POT.TO READ FROM $MCP
        IF(MASWRK) WRITE(IW,9020) A(NAT),B(NAT),NUCZ
        RETURN
      END IF
C
C     --- SET MATRIX OF CONTRACTION PATTERN ZERO
C
      DO 150 I=1,5
        CCTR(I)=SPACE20
        DO 140 J=1,20
          ICNTR(J,I)=0
 140  CONTINUE
 150  CONTINUE
C
      NOVSH=0
      DO 170 I=1,10
        RSTRNG(1:1) = ' '
        LENGST = -20
        CALL GSTRNG(RSTRNG,LENGST)
        READ(UNIT=RSTRNG,FMT='(A20)') STRNG
        DO 160 J=1,8
          IF (STRNG.EQ.LABEL(J)) THEN
            NOVSH=NOVSH+1
            IF (NOVSH.GT.5) THEN
              WRITE(IW,9025)
              CALL ABRT
              STOP
            END IF
            MTYP=MTYP+J*10**NOVSH
C           WRITE(*,*) 'MTYP',MTYP
            GOTO 170
          END IF
 160    CONTINUE
        MPTYP(NAT)=MTYP
C       --- IF SPACE THEN IT IS DONE
        IF (STRNG.EQ.SPACE20) GOTO 180
C       --- READ CONTRACTION PATTERN
        CCTR(NOVSH)=STRNG
 170  CONTINUE
C
 180  CONTINUE
C     WRITE(*,*) 'MTYP MCPTYP MCPREL MCPCOR',MTYP,MCPTYP,MCPREL,MCPCOR
CC ... NO MCP OPTIONS USED - SET DEFAULTS DEPENDING ON Z
C      IF(MOPTION.EQ.0) THEN
C        IF(NUCZ.GE.03 .AND. NUCZ.LE.04) MTYP=   1*10 + MTYP
C        IF(NUCZ.GE.05 .AND. NUCZ.LE.20) MTYP=  21*10 + MTYP
C*       IF(NUCZ.GE.21 .AND. NUCZ.LE.30) MTYP= 321*10 + MTYP
C        IF(NUCZ.GE.21 .AND. NUCZ.LE.30) MTYP=  31*10 + MTYP
C        IF(NUCZ.GE.31 .AND. NUCZ.LE.36) MTYP=  21*10 + 1
C        IF(NUCZ.GE.37 .AND. NUCZ.LE.38) MTYP=  21*10 + 2
C*       IF(NUCZ.GE.39 .AND. NUCZ.LE.48) MTYP= 321*10 + 2
C        IF(NUCZ.GE.39 .AND. NUCZ.LE.48) MTYP=  31*10 + 2
C        IF(NUCZ.GE.49 .AND. NUCZ.LE.54) MTYP=  21*10 + 2
C        IF(NUCZ.GE.55 .AND. NUCZ.LE.56) MTYP=  21*10 + 2
C        IF(NUCZ.GE.57 .AND. NUCZ.LE.70) MTYP=   2*10 + 2
C*       IF(NUCZ.GE.71 .AND. NUCZ.LE.80) MTYP= 321*10 + 2
C        IF(NUCZ.GE.71 .AND. NUCZ.LE.80) MTYP=  31*10 + 2
C        IF(NUCZ.GE.81 .AND. NUCZ.LE.86) MTYP=  21*10 + 2
        MTYP = MCPTYP*100 + MCPREL*10 + MCPCOR
        MPTYP(NAT)=MTYP
C      ENDIF
C     WRITE(*,*) 'MTYP ',MTYP
C     WRITE(*,*) 'NOVSH',NOVSH
C     WRITE(*,FMT='(I3,2X,A20)') (I,CCTR(I),I=1,NOVSH)
C
C     ----------
C
      DO 190 I = 1,100
         EEX(I) = ZERO
         CC(I) = ZERO
  190 CONTINUE
C
C     --- GET VALENCE-SHELL BASIS-SET -> MMPMOD=0
C     --- INPUT: NUCZ    CHARGE OF ATOM
C     ---        MTYP  MOD.POT.TYPE
C
      MMPMOD=0
      CALL MCPLIB(MMPMOD,NUCZ,MTYP,SHINFO,CDFCTR,NOFCVS,KTYPV,KNGV,
     2            EEX,CC,ZCORE,NOAN0I,NOAN1I,AN0I,ALPN0I,AN1I,
     3            ALPN1I,BPARI,INFTYP,IERR)
C     WRITE(*,*) ' >>> MCPLIB EXIT ...'
C     WRITE(*,*) ' >>> IERR',IERR
C
C     --- CDFCTR(I) CODED DEFAULT CONTRACTION OF SHELL I
C     --- NOFCVS    NO.OF FULLY CONTRACTED VAL.SHELLS
C     --- KTYPV(I)  TYPE OF SHELL I
C     --- KNGV(I)   NO.OF GTFS IN SHELL I
C     --- EEX(J)    EXPONENT OF J-TH GTF
C     --- CC(J)     COEFFICIENT OF J-TH GTF
C     --- IERR      0: OK  1: NOT MCP-ATOM  2: MPTYP WRONG
C
      IF (IERR.NE.0) THEN
         IF (IERR.EQ.1) THEN
           WRITE(IW,9100)  A(NAT),B(NAT),NUCZ
         ELSE IF (IERR.EQ.2) THEN
           WRITE(IW,9120)  A(NAT),B(NAT),NUCZ
         END IF
         CALL ABRT
         STOP
      END IF
C
C     --- SOS       SUM OVER SHELLS
C     --- SOG       SUM OVER GTFS
C     --- IPASS     SUM OVER SHELLS
C     --- IGX       SUM OVER GTFS
C
      SOS=0
C     SOG=0
      IPASS=0
      IGX=0
C
C     --- SUM OVER FULLY CONTRACTED VALENCE-SHELLS
C
      DO 500 II=1,NOFCVS
C       --- IF CCT=' ' TAKE DEFAULT CONTRACTION
        IF (CCT(1,II).EQ.SPACE1) CCTR(II)=CDFCTR(II)
C       --- IF CCT='0' DO NOT TAKE MOD.POT.-VALENCE-BASIS-SET
        IF (CCT(1,II).EQ.'0')  THEN
           WRITE(IW,9140) A(NAT),B(NAT),NUCZ
           RETURN
        END IF
C       --- DECODE THE CONTRACTION PATTERN
        ISUM=0
        DO 220 J=1,20
           CNUM=CCT(J,II)
           IF (CNUM.EQ.'1')        THEN
                  NUM=1
             ELSE IF (CNUM.EQ.'2') THEN
                  NUM=2
             ELSE IF (CNUM.EQ.'3') THEN
                  NUM=3
             ELSE IF (CNUM.EQ.'4') THEN
                  NUM=4
             ELSE IF (CNUM.EQ.'5') THEN
                  NUM=5
             ELSE IF (CNUM.EQ.'6') THEN
                  NUM=6
             ELSE IF (CNUM.EQ.'7') THEN
                  NUM=7
             ELSE IF (CNUM.EQ.'8') THEN
                  NUM=8
             ELSE IF (CNUM.EQ.'9') THEN
                  NUM=9
             ELSE IF (CNUM.EQ.'A') THEN
                  NUM=10
             ELSE IF (CNUM.EQ.'0') THEN
                  NUM=0
             ELSE IF (CNUM.EQ.SPACE1) THEN
                  GOTO 230
             ELSE
                  WRITE(IW,9160) A(NAT),B(NAT),NUCZ,ZCORE,
     *                 TYP,SHINFO,CCTR(II)
                  CALL ABRT
                  STOP
           END IF
           ICNTR(J,II)=NUM
           ISUM=ISUM+NUM
 220    CONTINUE
 230    CONTINUE
C
        NG =KNGV(II)
C       --- CHECK IF NO.OF GTFS IN THE CONTRACTION IS CORRECT
        IF (ISUM.NE.NG) THEN
C         --- TRY TO READ THE FIRST TWO FIGURES
C         --- AS ONE NUMBER GREATER/EQUAL TEN
          ICNTR(1,II)=ICNTR(1,II)*10+ICNTR(2,II)
          ISUM=ICNTR(1,II)
          DO 240 K=2,(J-1)
            ICNTR(K,II)=ICNTR(K+1,II)
            ISUM=ISUM+ICNTR(K,II)
 240      CONTINUE
          ICNTR(J,II)=0
C         --- CHECK IF THIS CONTRACTION IS CORRECT
          IF (ISUM.NE.NG .AND. MASWRK) THEN
            WRITE(IW,9200) A(NAT),B(NAT),NUCZ,CCTR(II)
            WRITE(IW,9210) II,NG
            WRITE(IW,9220)
            CALL MMPINF(NUCZ,CSINP,
     *           IERR1,IERR2,INTYP,
     *           LOC,NGAUSS,NS)
            WRITE(IW,*)
            CALL ABRT
            STOP
          END IF
        END IF
C
C       --- SUM OVER SHELLS WITHIN THE FULLY CONTRACTED SHELL II
C
        DO 460 IJ=1,20
          NF=ICNTR(IJ,II)
C         --- IF NO GTFS IN THIS SHELL GOTO NEW FULLY CONTR.SHELL
          IF (NF.EQ.0) GOTO 500
          SOS=SOS+1
          IPASS=IPASS+1
C         --- CODE FROM DZVBAS-SUBROUTINE IN BASEXT-MODULE:
          IGAUSS = ICNTR(IJ,II)
          ITYP   = KTYPV(II)
C
          NSHELL = NSHELL+1
          IF(NSHELL.GT.MXSH) THEN
            IERR1=1
            RETURN
          END IF
          NS(NAT) = NS(NAT)+1
          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) THEN
            IERR2=1
            RETURN
          END IF
          LOC = LOC+NBFS(ITYP)
          K1 = KSTART(NSHELL)
          K2 = K1+KNG(NSHELL)-1
C         WRITE(*,*) ' >>> IGAUSS ',IGAUSS
          DO 260 I = 1,IGAUSS
            K = K1+I-1
            EX(K)    = EEX(IGX+I)
            IF (ITYP.EQ.1) THEN
                CSINP(K) = CC(IGX+I)
            ELSE IF (ITYP.EQ.2) THEN
                CPINP(K) = CC(IGX+I)
            ELSE IF (ITYP.EQ.3) THEN
                CDINP(K) = CC(IGX+I)
            ELSE IF (ITYP.EQ.4) THEN
                CFINP(K) = CC(IGX+I)
            ELSE IF (ITYP.EQ.8) THEN
                CSINP(K) = CC(IGX+I)
                CPINP(K) = CC(IGX+I)
            ELSE
                WRITE(IW,*) 'NO WAY TO GET HERE'
                CALL ABRT
                STOP
            END IF
            IF (IGAUSS.EQ.1) THEN
              CSINP(K) = ONE
              CPINP(K) = ONE
              CDINP(K) = ONE
              CFINP(K) = ONE
            ENDIF
            CS(K) = CSINP(K)
            CP(K) = CPINP(K)
            CD(K) = CDINP(K)
            CF(K) = CFINP(K)
  260    CONTINUE
C        WRITE(*,*) ' >>> AFTER 260'
      IGX = IGX + IGAUSS
C
C     ----- ALWAYS UNNORMALIZE PRIMITIVES -----
C
      DO 280 K = K1,K2
         EE = EX(K)+EX(K)
         FACS = PI32/(EE*SQRT(EE))
         FACP = PT5*FACS/EE
         FACD = PT75*FACS/(EE*EE)
         FACF = PT187*FACS/(EE**3)
         CS(K) = CS(K)/SQRT(FACS)
         CP(K) = CP(K)/SQRT(FACP)
         CD(K) = CD(K)/SQRT(FACD)
         CF(K) = CF(K)/SQRT(FACF)
  280 CONTINUE
C
C     ----- IF(NORMF.EQ.0) NORMALIZE BASIS FUNCTIONS. -----
C
      NORMF=0
      IF (NORMF .EQ. 1) GO TO 460
      FACS = ZERO
      FACP = ZERO
      FACD = ZERO
      FACF = ZERO
      DO 320 IG = K1,K2
         DO 300 JG = K1,IG
            EE = EX(IG)+EX(JG)
            FAC = EE*SQRT(EE)
            DUMS = CS(IG)*CS(JG)/FAC
            DUMP = PT5*CP(IG)*CP(JG)/(EE*FAC)
            DUMD = PT75*CD(IG)*CD(JG)/(EE*EE*FAC)
            DUMF = PT187*CF(IG)*CF(JG)/(EE**3*FAC)
            IF (IG .NE. JG) THEN
               DUMS = DUMS+DUMS
               DUMP = DUMP+DUMP
               DUMD = DUMD+DUMD
               DUMF = DUMF+DUMF
            END IF
            FACS = FACS+DUMS
            FACP = FACP+DUMP
            FACD = FACD+DUMD
            FACF = FACF+DUMF
  300    CONTINUE
  320 CONTINUE
      IF (FACS .GT. TOL) FACS = ONE/SQRT(FACS*PI32)
      IF (FACP .GT. TOL) FACP = ONE/SQRT(FACP*PI32)
      IF (FACD .GT. TOL) FACD = ONE/SQRT(FACD*PI32)
      IF (FACF .GT. TOL) FACF = ONE/SQRT(FACF*PI32)
      DO 340 IG = K1,K2
         CS(IG) = CS(IG) * FACS
         CP(IG) = CP(IG) * FACP
         CD(IG) = CD(IG) * FACD
         CF(IG) = CF(IG) * FACF
  340 CONTINUE
C
C
C       --- END OF SUM OVER SHELLS
  460   CONTINUE
C     --- END OF SUM OVER FULLY CONTRACTED SHELLS
  500 CONTINUE
C
C     --- WRITE MODEL-POTENTIAL TYPE
C
      IF(MASWRK) THEN
C       WRITE(*,*) ' >>> NOFCVS ',NOFCVS
        WRITE(IW,*) "WRITE MODEL-POTENTIAL TYPE"
        WRITE(IW,9040) A(NAT),B(NAT),NUCZ,ZCORE,TYP,SHINFO,
     *     LABEL2(KTYPV(1)),CCTR(1),LABEL2(KTYPV(2)),CCTR(2)
      ENDIF
C     WRITE(*,*) ' >>> 1ST IF'
      IF (NOFCVS.EQ.3 .AND. MASWRK) WRITE(IW,9050)
     *   LABEL2(KTYPV(3)),CCTR(3)
      IF (NOFCVS.EQ.4 .AND. MASWRK) WRITE(IW,9050)
     *   LABEL2(KTYPV(3)),CCTR(3),LABEL2(KTYPV(4)),CCTR(4)
C     WRITE(*,*) ' >>> 2ND IF'
      IF (NOFCVS.GT.4 .AND. MASWRK) WRITE(IW,9060)
     *   LABEL2(KTYPV(5)),CCTR(5)
C     WRITE(*,*) ' >>> 3RD IF'
      IF(MASWRK) WRITE(IW,9090)
C
 9000 FORMAT(/5X,'MODEL-POTENTIAL ATOMS',/5X,21(1H-))
 9010 FORMAT(/1X,'ATOM',5X,'ATOMIC',2X,' CORE- ',2X,'TYPE',3X,
     *      'VALENCE-',7X,'CONTRACTION',/10X,'CHARGE',1X,
     *      'ELECTRONS',8X,'SHELLS')
 9015 FORMAT(/1X,A8,A2,I3,14X,A6,'WRONG MODEL-POTENTIAL TYPE',/)
 9020 FORMAT(/1X,A8,A2,I3,20X,'MODEL-POTENTIAL IN $MCP GROUP',/)
 9025 FORMAT(1X,'BUILT-IN BASIS-SETS FOR MODEL-POTENTIAL',
     *       ' ATOMS',/1X,'DO NOT HAVE MORE THAN FIVE',
     *       ' VALENCE-SHELLS',/)
 9040 FORMAT(/1X,A8,A2,I3,5X,F3.0,6X,A6,A15,2(A2,A20))
 9050 FORMAT(49X,2(A2,A20))
 9060 FORMAT(49X,A2,A20)
 9090 FORMAT(//)
 9100 FORMAT(/1X,A8,A2,I3,20X,'NO MODEL-POTENTIAL BUILT-IN',/)
 9120 FORMAT(/1X,A8,A2,I3,20X,'MODEL-POTENTIAL TYPE OR SPECIFIED',
     *       /34X,' VALENCE-SHELLS ARE WRONG',/)
 9140 FORMAT(/1X,A8,A2,I3,20X,'BUILT-IN VALENCE-BASIS IS SKIPPED',/)
 9160 FORMAT(/1X,A8,A2,I3,5X,F3.0,6X,A6,A15,A20,/34X,
     *       'NOT VALID CONTRACTION CODE',/)
 9200 FORMAT(/1X,A8,A2,I3,20X,'THE CONTRACTION ',A20)
 9210 FORMAT(/34X,'OF SHELL',I2,' DOES NOT MATCH WITH THE',
     *       ' NO.OF GTFS',I3)
 9220 FORMAT(/34X,'DEFAULT CONTRACTIONS ARE:')
C
      RETURN
      END
C
C*MODULE MCPINP  *DECK MMPNOR
      SUBROUTINE MMPNOR(IZSAVE,CSHELL,NORMF,NORMP,
     *                  K1,K2,EX,CS,CP,CD,CF)
C
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      INTEGER CSHELL
C
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      COMMON /IOFILE/ IR,IW,IP,IJK,IPK,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      DIMENSION EX(*),CS(*),CP(*),CD(*),CF(*)
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00, HALF=0.5D+00,
     *           PT75=0.75D+00, PT187=1.875D+00,
     *           TM6=1.0D-06, TM10=1.0D-10)
C
      PI = ACOS(-ONE)
      PI32 = PI * SQRT(PI)
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
      IF(NORMP .EQ. 1) GO TO 130
      DO 120 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)
         CS(IG) = CS(IG)/SQRT(FACS)
         CP(IG) = CP(IG)/SQRT(FACP)
         CD(IG) = CD(IG)/SQRT(FACD)
         CF(IG) = CF(IG)/SQRT(FACF)
  120 CONTINUE
C
C     IF(NORMF.NE.1) NORMALIZE THE CONTRACTED BASIS FUNCTIONS.
C
  130 CONTINUE
      IF(NORMF .EQ. 1) RETURN
      FACS = ZERO
      FACP = ZERO
      FACD = ZERO
      FACF = ZERO
      DO 170 IG = K1,K2
         DO 160 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)
            IF(IG .NE. JG) THEN
               DUMS = DUMS+DUMS
               DUMP = DUMP+DUMP
               DUMD = DUMD+DUMD
               DUMF = DUMF+DUMF
            END IF
            FACS = FACS+DUMS
            FACP = FACP+DUMP
            FACD = FACD+DUMD
            FACF = FACF+DUMF
  160    CONTINUE
  170 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) IZSAVE,CSHELL,'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) IZSAVE,CSHELL,'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) IZSAVE,CSHELL,'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) IZSAVE,CSHELL,'F',FACF
      END IF
C
      DO 190 IG = K1,K2
         CS(IG) = CS(IG) * FACS
         CP(IG) = CP(IG) * FACP
         CD(IG) = CD(IG) * FACD
         CF(IG) = CF(IG) * FACF
  190 CONTINUE
C
      RETURN
C
 9040 FORMAT(1X,'*** WARNING! THE MODEL-POTENTIAL ATOM Z=',
     *       I4,/4X,'CORE-SHELL',I5,' TYPE ',A1,
     *       ' HAS NORMALIZATION',F13.8,' ***')
C
      END
C
C*MODULE MCPINP  *DECK MMPRED
      SUBROUTINE MMPRED(ICNTR,NOCOS,KTYP,KNG,EX,C,ZCORE,
     2         NOAN0,NOAN1,AN0,ALPN0,AN1,ALPN1,BPAR)
C
C     --- READ MODEL-POTENTIAL FROM $MCP GROUP
C     --- CALLED FROM MMPCOR
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK,OUT
C
      DOUBLE PRECISION MCP_DZP, MCP_TZP, MCP_QZP
      DOUBLE PRECISION IMCP_NR1, IMCP_NR2, IMCP_SR1, IMCP_SR2
C
      PARAMETER (MXATM=2000, MXAO=8192)
      PARAMETER (MAXA=103, MAXL=7)
      DIMENSION AN0(*),ALPN0(*),AN1(*),ALPN1(*)
      DIMENSION BPAR(*),KNG(*),KTYP(*)
      DIMENSION C(*),EX(*)
C
      DIMENSION AVAL(40),ALPVAL(40)
      INTEGER   MKINT(20),GMAX,GMIN,GMINO
      CHARACTER*10 ATOMNM,ENDWRD
CCC   CHARACTER    ANAT*8, BNAT*2
C     CHARACTER TAGMCP*8
      CHARACTER*256 BASPTH
      CHARACTER*1 NULL
      CHARACTER*80 MKLINE
      CHARACTER*8  MCPFMT
C
      COMMON /BASISC/ GBASIS,AEX(MAXA,MAXL),ABASIS(MAXA,MAXL),
     *                IAGAUS(MAXA,MAXL),IRDBAS
      COMMON /INFOA / NATOMS,ICH,MUL,NBASIS,NQMT,NE,NA,NB,
     *                ZAN(MXATM),CA(3,MXATM),IAN(MXATM)
      COMMON /IOFILE/ IR,IW,IP,IJK,IPK,IDAF,NAV,IODA(950)
      COMMON /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /RUNLAB/ TITLE(10),A(MXATM),B(MXATM),BFLAB(MXAO)
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
C
      DATA ENDWRD /'$END      '/
C
      DATA DBUG,DBUGME/8HDEBUG   ,8HMMPRED  /
C
      DATA MCP_DZP, MCP_TZP, MCP_QZP/8HMCP-DZP ,8HMCP-TZP ,8HMCP-QZP /
      DATA IMCP_NR1, IMCP_NR2, IMCP_SR1, IMCP_SR2
     +   /8HIMCP-NR1, 8HIMCP-NR2, 8HIMCP-SR1, 8HIMCP-SR2/
C
      OUT = NPRINT.EQ.3  .OR.  EXETYP.EQ.DBUG  .OR.  EXETYP.EQ.DBUGME
     *      .AND. MASWRK
C
C     ----- READ IN THE BASIS FUNCTIONS ON THIS CENTER -----
C     NORMALLY A THE $MCP GROUP SHOULD BE IN THE CARD INPUT,
C     BUT WE MIGHT USE AN EXTERNAL DISK FILE, WHICH MUST BE OPENED.
C     NOTE THAT THE OPEN STATEMENT ASSUMES A UNIX FILE SYSTEM.
C
      IR0 = IR
      IF(IRDBAS.EQ.2) THEN
C        --- GENERATE PERIODIC TABLE. ---
C        CALL SETLAB(3,ATMSYM)
C
C        --- GET PATH TO BASIS SET DIRECTORY ---
C        --- REMOVE BLANKS FROM BASPTH, ADD FILE NAME COMPONENT ---
C
         IF(MASWRK) THEN
C ... FOR MCP-**** BASIS SETS GET PATH TO BASIS SET LIBRARIES
C WHICH ARE PROVIDED AS PART OF GAMESS ITSELF.
            IF(GBASIS.EQ.MCP_DZP .OR. GBASIS.EQ.MCP_TZP  .OR.
     +         GBASIS.EQ.MCP_QZP .OR. GBASIS.EQ.IMCP_NR1 .OR.
     +         GBASIS.EQ.IMCP_NR2.OR. GBASIS.EQ.IMCP_SR1 .OR.
     +         GBASIS.EQ.IMCP_SR2) THEN
                  CALL GETENV('MCPPATH',BASPTH)
            ELSE
                  CALL GETENV('EXTBAS',BASPTH)
            ENDIF
            NULL = CHAR(0)
            DO KOL = 1,256
               IF (BASPTH(KOL:KOL) .EQ. ' ' .OR.
     *             BASPTH(KOL:KOL) .EQ. NULL) GO TO 190
               KOLMAX = KOL
            END DO
  190       CONTINUE
C
C        --- OPEN EXTERNAL BASIS SET FILE IBFILE ---
C
C ... FOR MCP-**** BASIS SETS APPEND THE GBASIS FILE NAME TO BASPTH
C                  IN ORDER TO CREATE THE FULL FILE NAME TO OPEN.
C                  THERE IS SIMILAR CODE IN INPUTA.SRC, CHANGE BOTH!
C
            IF(GBASIS.EQ.MCP_DZP .OR. GBASIS.EQ.MCP_TZP  .OR.
     +         GBASIS.EQ.MCP_QZP) THEN
                  WRITE(UNIT=BASPTH(KOLMAX+1:KOLMAX+8),FMT='(1H/,A7)')
     +                  GBASIS
                  KOLMAX=KOLMAX+8
            END IF
            IF(GBASIS.EQ.IMCP_NR1 .OR.  GBASIS.EQ.IMCP_NR2  .OR.
     *         GBASIS.EQ.IMCP_SR1 .OR.  GBASIS.EQ.IMCP_SR2) THEN
                  WRITE(UNIT=BASPTH(KOLMAX+1:KOLMAX+9),FMT='(1H/,A8)')
     +               GBASIS
                  KOLMAX=KOLMAX+9
            END IF
C
            IBFILE = 3
            IR0 = IR
            IR = IBFILE
            IF(NATOMS.EQ.1) WRITE(IW,7405) BASPTH(1:KOLMAX)
            OPEN(UNIT=IBFILE,FILE=BASPTH(1:KOLMAX),STATUS='OLD',
     *           IOSTAT=IERR,ERR=192,FORM='FORMATTED')
            IERR=0
            GO TO 193
  192       CONTINUE
            WRITE(IW,*)
     *         'UNABLE TO OPEN THE REQUESTED EXTERNAL BASIS FILE'
            CALL ABRT
            STOP
  193       CONTINUE
            IF (GOPARR) CALL DDI_BCAST(300,'I',IERR,1,MASTER)
         ELSE
            IF (GOPARR) CALL DDI_BCAST(300,'I',IERR,1,MASTER)
         END IF
         IF(IERR.NE.0) THEN
            IF(MASWRK) WRITE(IW,7400) BASPTH(1:KOLMAX)
            CALL ABRT
         END IF
C
C        --- SET FREE FORMAT READER TO FIRST CARD IN FILE IBFILE ---
C
         CALL OPNCRD(IBFILE,-IW)
      END IF
C
C     --- POSITION INPUT TO $MCP
C
      CALL SEQREW(IR)
      CALL FNDGRP(IR,' $MCP   ',JEOF)
      IF (JEOF.EQ.1 .AND. MASWRK) THEN
         WRITE(IW,*) ' NO $MCP GROUP FOUND !!!'
         CALL ABRT
         STOP
      END IF
C
C     --- OBTAIN NEXT ATOM
C     --- IF IT IS NAMED "$END" THEN WE ARE DONE.
C
C     --- FIND LABEL OF THE ATOM WITH THE NUMBER ICNTR
   80 CONTINUE
      IEOF=0
      CALL RDCARD('$MCP    ',IEOF)
      ATOMNM = '          '
      LENGST = -10
      CALL GSTRNG(ATOMNM,LENGST)
C     READ(UNIT=ATOMNM,FMT='(A8,A2)') ANAT,BNAT
C     IF(OUT) WRITE(IW,'(A8,A2)') ANAT,BNAT
      READ(UNIT=ATOMNM,FMT='(A8)') ANAT
      IF(IRDBAS.EQ.2) THEN
        CALL GSTRNG(ATOMNM,LENGST)
        READ(UNIT=ATOMNM,FMT='(A8)') TAGMCP
      ENDIF
      IF(OUT) WRITE(IW,'(1X,2A8)') ANAT,TAGMCP
C
      IF(ATOMNM.EQ.ENDWRD .AND. MASWRK) THEN
         WRITE(IW,'(1X,A8,A2,A)') A(ICNTR),B(ICNTR),
     *         ' NOT FOUND IN $MCP GROUP '
         CALL ABRT
         STOP
      END IF
C     IF (A(NAT).NE.A(ICNTR)) GOTO 80
      IF (ANAT.NE.A(ICNTR)) GOTO 80
      IF(IRDBAS.EQ.2) THEN
        IF(TAGMCP.NE.GBASIS) GOTO 80
      ENDIF
C
C     --- READ CORE-SHELL BASIS AND MODEL-POTENTIAL
C
C     IF(MASWRK) WRITE(IW,'(1X,2A8)') ANAT,TAGMCP
      IF(MASWRK) WRITE(IW,'(1X,2A8)') ANAT,GBASIS
      MKLINE(1:1) = ' '
      LENGST=80
      IEOF=0
   81 CALL RDCARD('$MCP    ',IEOF)
      CALL GSTRNG(MKLINE,LENGST)
      IF(MKLINE(1:1).EQ.'*') THEN
        DO III=80,1,-1
           IF(MKLINE(III:III).NE.' ') GO TO 82
        ENDDO
        III=1
   82   CONTINUE
        IF(MASWRK) WRITE(IW,FMT='(1X,A)') MKLINE(1:III)
        GOTO 81
      ENDIF
      READ(UNIT=MKLINE,FMT='(20I3)',ERR=944) (MKINT(I),I=1,9)
      IF(OUT) WRITE(IW,'(20I3)') (MKINT(I),I=1,9)
C
      IEOF=0
      CALL RDCARD('$MCP    ',IEOF)
      CALL GSTRNG(MKLINE,LENGST)
      IF(OUT) WRITE(IW,'(A80)') MKLINE
      READ(UNIT=MKLINE,FMT='(F10.2,A8)',ERR=944) Z,MCPFMT
      IF(OUT) WRITE(IW,'(F10.2,A8)') Z,MCPFMT
      READ(UNIT=MCPFMT,FMT='(1X,I1)')   MKM
      IF(OUT) WRITE(IW,*) 'MKM =',MKM
C     READ(IR,'(F10.2)') Z
      ZCORE=ZAN(ICNTR)-Z
      NOAN=MKINT(1)
      NOS =MKINT(2)
      NOP =MKINT(4)
      NOD =MKINT(6)
      NOF =MKINT(8)
      NGS =MKINT(3)
      NGP =MKINT(5)
      NGD =MKINT(7)
      NGF =MKINT(9)
C
C     --- READ A-PARAMETERS (A,A,N)
C
      MKLINP=NOAN/MKM
      IF(NOAN - MKLINP*MKM .GT. 0) MKLINP = MKLINP + 1
      IF(OUT) WRITE(IW,*) 'MKLINP =',MKLINP
      MKOUNT=0
      DO MKJ=1,MKLINP
        IEOF=0
        CALL RDCARD('$MCP    ',IEOF)
        CALL GSTRNG(MKLINE,LENGST)
        IF(OUT) WRITE(IW,'(A80)') MKLINE
        MINCR = MIN0(MKM,NOAN-(MKJ-1)*MKM)
        READ(UNIT=MKLINE,FMT=MCPFMT,ERR=944)
     +      (AVAL(MKOUNT+I),I=1,MKM)
        MKOUNT=MKOUNT+MKM
      ENDDO
      IF(OUT) WRITE(IW,FMT=MCPFMT) (AVAL(I),I=1,NOAN)
C     READ(IR,'(4G15.8)',ERR=944) (AVAL(I),I=1,NOAN)
C
      MKOUNT=0
      DO MKJ=1,MKLINP
        IEOF=0
        CALL RDCARD('$MCP    ',IEOF)
        CALL GSTRNG(MKLINE,LENGST)
        IF(OUT) WRITE(IW,'(A80)') MKLINE
        MINCR = MIN0(MKM,NOAN-(MKJ-1)*MKM)
        READ(UNIT=MKLINE,FMT=MCPFMT,ERR=944)
     +      (ALPVAL(MKOUNT+I),I=1,MKM)
        MKOUNT=MKOUNT+MKM
      ENDDO
      IF(OUT) WRITE(IW,FMT=MCPFMT) (ALPVAL(I),I=1,NOAN)
C     READ(IR,'(4G15.8)',ERR=944) (ALPVAL(I),I=1,NOAN)
C
      IEOF=0
      CALL RDCARD('$MCP    ',IEOF)
      CALL GSTRNG(MKLINE,LENGST)
      IF(OUT) WRITE(IW,'(A80)') MKLINE
      READ(UNIT=MKLINE,FMT='(20I3)',ERR=944) (MKINT(I),I=1,NOAN)
      IF(OUT) WRITE(IW,'(20I3)') (MKINT(I),I=1,NOAN)
C     READ(IR,'(20I3)',ERR=944) (MKINT(I),I=1,NOAN)
      N0=0
      N1=0
      DO 120 I=1,NOAN
        IF (MKINT(I).EQ.0) THEN
           N0=N0+1
           AN0(N0)   = AVAL(I)
           ALPN0(N0) = ALPVAL(I)
        ELSE IF (MKINT(I).EQ.1) THEN
           N1=N1+1
           AN1(N1)   = AVAL(I)
           ALPN1(N1) = ALPVAL(I)
        ELSE
           GOTO 944
        END IF
 120  CONTINUE
C     --- NO.OF A-TERMS FOR N=0 AND N=1
      NOAN0=N0
      NOAN1=N1
C
C     --- READ S-SHELLS
C
      IF(OUT) WRITE(IW,*) '--- READ S-SHELLS'
      GMIN=1
      GMAX=NGS
C
      MKLINP=NOS/MKM
      IF(NOS - MKLINP*MKM .GT. 0) MKLINP = MKLINP + 1
      IF(OUT) WRITE(IW,*) 'MKLINP =',MKLINP
      MKOUNT_B=0
      DO MKJ=1,MKLINP
        IEOF=0
        CALL RDCARD('$MCP    ',IEOF)
        CALL GSTRNG(MKLINE,LENGST)
        IF(OUT) WRITE(IW,'(A80)') MKLINE
        MINCR = MIN0(MKM,NOS-(MKJ-1)*MKM)
        READ(UNIT=MKLINE,FMT=MCPFMT,ERR=944)
     +      (BPAR(MKOUNT_B+I),I=1,MINCR)
        MKOUNT_B=MKOUNT_B+MINCR
      ENDDO
      IF(OUT) WRITE(IW,*) 'MKOUNT_B =',MKOUNT_B
      IF(OUT) WRITE(IW,FMT=MCPFMT) (BPAR(I),I=1,NOS)
C     READ(IR,'(4G15.8)',ERR=944) (BPAR(I),I=1,NOS)
      DO 135 I=1,NOS
         KTYP(I)=1
         KNG(I) =NGS
 135  CONTINUE
C
      MKLINP=(GMAX-GMIN+1)/MKM
      IF((GMAX-GMIN+1) - MKLINP*MKM .GT. 0) MKLINP = MKLINP + 1
      IF(OUT) WRITE(IW,*) 'MKLINP =',MKLINP
      MKOUNT_X=0
      DO MKJ=1,MKLINP
        IEOF=0
        CALL RDCARD('$MCP    ',IEOF)
        CALL GSTRNG(MKLINE,LENGST)
        IF(OUT) WRITE(IW,'(A80)') MKLINE
        MINCR = MIN0(MKM, (GMAX-GMIN+1) - (MKJ-1)*MKM )
        READ(UNIT=MKLINE,FMT=MCPFMT,ERR=944) (EX(MKOUNT_X+I),I=1,MINCR)
        MKOUNT_X=MKOUNT_X+MINCR
      ENDDO
      IF(OUT) WRITE(IW,*) 'MKOUNT_X =',MKOUNT_X
      IF(OUT) WRITE(IW,FMT=MCPFMT) (EX(I),I=GMIN,GMAX)
C     READ(IR,'(4G15.8)',ERR=944) (EX(I),I=GMIN,GMAX)
C
      MKOUNT_C=0
      DO MKJ=1,MKLINP
        IEOF=0
        CALL RDCARD('$MCP    ',IEOF)
        CALL GSTRNG(MKLINE,LENGST)
        IF(OUT) WRITE(IW,'(A80)') MKLINE
        MINCR = MIN0(MKM, (GMAX-GMIN+1) - (MKJ-1)*MKM )
        READ(UNIT=MKLINE,FMT=MCPFMT,ERR=944) (C(MKOUNT_C+I),I=1,MINCR)
        MKOUNT_C=MKOUNT_C+MINCR
      ENDDO
      IF(OUT) WRITE(IW,*) 'MKOUNT_C =',MKOUNT_C
      IF(OUT) WRITE(IW,FMT=MCPFMT) (C(I),I=GMIN,GMAX)
C     READ(IR,'(4G15.8)',ERR=944) (C(I),I=GMIN,GMAX)
C
      GMINO=GMIN
      DO 140 K=2,NOS
C       IF(OUT) WRITE(IW,*) 'K  NOS =',K
        GMIN=GMAX+1
        GMAX=GMAX+NGS
C
        MKLINP=(GMAX-GMIN+1)/MKM
        IF((GMAX-GMIN+1) - MKLINP*MKM .GT. 0) MKLINP = MKLINP + 1
        IF(OUT) WRITE(IW,*) 'MKLINP =',MKLINP
        DO MKJ=1,MKLINP
          IEOF=0
          CALL RDCARD('$MCP    ',IEOF)
          CALL GSTRNG(MKLINE,LENGST)
          IF(OUT) WRITE(IW,'(A80)') MKLINE
          MINCR = MIN0(MKM, (GMAX-GMIN+1) - (MKJ-1)*MKM )
          READ(UNIT=MKLINE,FMT=MCPFMT,ERR=944)
     +        (C(MKOUNT_C+I),I=1,MINCR)
          MKOUNT_C=MKOUNT_C+MINCR
        ENDDO
        IF(OUT) WRITE(IW,*) 'MKOUNT_C =',MKOUNT_C
        IF(OUT) WRITE(IW,FMT=MCPFMT) (C(I),I=GMIN,GMAX)
C       READ(IR,'(4G15.8)',ERR=944) (C(I),I=GMIN,GMAX)
        DO 139 L=0,(NGS-1)
          EX(L+GMIN)=EX(L+GMINO)
          MKOUNT_X = MKOUNT_X + 1
 139    CONTINUE
        IF(OUT) WRITE(IW,*) 'MKOUNT_X =',MKOUNT_X
 140  CONTINUE
      IF(OUT) WRITE(IW,*) '--- END  S-SHELLS'
C
C     --- READ P-SHELLS
C
      IF(OUT) WRITE(IW,*) '--- READ P-SHELLS'
      IMIN=NOS+1
      IMAX=NOS+NOP
      GMIN=GMAX+1
      GMAX=GMAX+NGP
      IF ((IMIN.GT.IMAX).OR.(GMIN.GT.GMAX)) GOTO 151
      MKLINP = (IMAX-IMIN+1)/MKM
      IF( (IMAX-IMIN+1) - MKLINP*MKM .GT. 0) MKLINP = MKLINP + 1
      IF(OUT) WRITE(IW,*) 'MKLINP =',MKLINP
      DO MKP=1,MKLINP
        IEOF=0
        CALL RDCARD('$MCP    ',IEOF)
        CALL GSTRNG(MKLINE,LENGST)
        IF(OUT) WRITE(IW,'(A80)') MKLINE
        MINCR = MIN0(MKM,(IMAX-IMIN+1)-(MKP-1)*MKM)
C       IF(MASWRK) WRITE(IW,*) 'MINCR  =',MINCR
        READ(UNIT=MKLINE,FMT=MCPFMT,ERR=944)
     +      (BPAR(MKOUNT_B+I),I=1,MINCR)
        MKOUNT_B=MKOUNT_B+MINCR
      ENDDO
C     READ(IR,'(4G15.8)',ERR=944) (BPAR(I),I=IMIN,IMAX)
      IF(OUT) WRITE(IW,FMT=MCPFMT) (BPAR(I),I=IMIN,IMAX)
      IF(OUT) WRITE(IW,*) 'MKOUNT_B =',MKOUNT_B
      DO 145 I=IMIN,IMAX
         KTYP(I)=2
         KNG(I) =NGP
 145  CONTINUE
C
      MKLINP=(GMAX-GMIN+1)/MKM
      IF((GMAX-GMIN+1) - MKLINP*MKM .GT. 0) MKLINP = MKLINP + 1
      IF(OUT) WRITE(IW,*) 'MKLINP =',MKLINP
      DO MKP=1,MKLINP
        IEOF=0
        CALL RDCARD('$MCP    ',IEOF)
        CALL GSTRNG(MKLINE,LENGST)
        IF(OUT) WRITE(IW,'(A80)') MKLINE
        MINCR = MIN0(MKM, NGP - (MKP-1)*MKM )
        READ(UNIT=MKLINE,FMT=MCPFMT,ERR=944)
     +      (EX(MKOUNT_X+I),I=1,MINCR)
        MKOUNT_X=MKOUNT_X+MINCR
      ENDDO
C     READ(IR,'(4G15.8)',ERR=944) (EX(I),I=GMIN,GMAX)
      IF(OUT) WRITE(IW,FMT=MCPFMT) (EX(I),I=GMIN,GMAX)
      IF(OUT) WRITE(IW,*) 'MKOUNT_X =',MKOUNT_X
C ... READ 1ST C
      DO MKP=1,MKLINP
        IEOF=0
        CALL RDCARD('$MCP    ',IEOF)
        CALL GSTRNG(MKLINE,LENGST)
        IF(OUT) WRITE(IW,'(A80)') MKLINE
        MINCR = MIN0(MKM, NGP - (MKP-1)*MKM )
        READ(UNIT=MKLINE,FMT=MCPFMT,ERR=944)
     +      (C(MKOUNT_C+I),I=1,MINCR)
        MKOUNT_C=MKOUNT_C+MINCR
      ENDDO
      IF(OUT) WRITE(IW,FMT=MCPFMT) (C(I),I=GMIN,GMAX)
      IF(OUT) WRITE(IW,*) 'MKOUNT_C =',MKOUNT_C
C     READ(IR,'(4G15.8)',ERR=944) (C(I),I=GMIN,GMAX)
C
      GMINO=GMIN
      DO 150 K=IMIN+1,IMAX
C       IF(MASWRK) WRITE(IW,*) 'K  NOS =',K
        GMIN=GMAX+1
        GMAX=GMAX+NGP
        DO MKP=1,MKLINP
C         IF(MASWRK) WRITE(IW,*) 'MKP =', MKP
          IEOF=0
          CALL RDCARD('$MCP    ',IEOF)
          CALL GSTRNG(MKLINE,LENGST)
          IF(OUT) WRITE(IW,'(A80)') MKLINE
          MINCR = MIN0(MKM, NGP - (MKP-1)*MKM )
C         IF(MASWRK) WRITE(IW,*) 'MINCR =',MINCR
          READ(UNIT=MKLINE,FMT=MCPFMT,ERR=944)
     +        (C(MKOUNT_C+I),I=1,MINCR)
          MKOUNT_C=MKOUNT_C + MINCR
        ENDDO
        IF(OUT) WRITE(IW,FMT=MCPFMT) (C(I),I=GMIN,GMAX)
        IF(OUT) WRITE(IW,*) 'MKOUNT_C =',MKOUNT_C
C       READ(IR,'(4G15.8)',ERR=944) (C(I),I=GMIN,GMAX)
        DO 149 L=0,(NGP-1)
          EX(L+GMIN)=EX(L+GMINO)
          MKOUNT_X = MKOUNT_X + 1
 149    CONTINUE
        IF(OUT) WRITE(IW,*) 'MKOUNT_X =',MKOUNT_X
 150  CONTINUE
      IF(OUT) WRITE(IW,*) '--- END  P-SHELLS'
 151  CONTINUE
C
C     --- READ D-SHELLS
C
      IF(OUT) WRITE(IW,*) '--- READ D-SHELLS'
      IMIN=IMAX+1
      IMAX=IMAX+NOD
      GMIN=GMAX+1
      GMAX=GMAX+NGD
      IF ((IMIN.GT.IMAX).OR.(GMIN.GT.GMAX)) GOTO 161
      MKLINP = NOD/MKM
      IF( NOD - MKLINP*MKM .GT. 0 ) MKLINP = MKLINP + 1
      IF(OUT) WRITE(IW,*) 'MKLINP =',MKLINP
      DO MKD=1,MKLINP
        IEOF=0
        CALL RDCARD('$MCP    ',IEOF)
        CALL GSTRNG(MKLINE,LENGST)
        IF(OUT) WRITE(IW,'(A80)') MKLINE
        MINCR = MIN0(MKM, NOD - (MKD-1)*MKM)
        READ(UNIT=MKLINE,FMT=MCPFMT,ERR=944)
     +      (BPAR(MKOUNT_B + I),I=1,MINCR)
        MKOUNT_B = MKOUNT_B + MINCR
      ENDDO
      IF(OUT) WRITE(IW,FMT=MCPFMT) (BPAR(I),I=IMIN,IMAX)
      IF(OUT) WRITE(IW,*) 'MKOUNT_B =',MKOUNT_B
C     READ(IR,'(4G15.8)',ERR=944) (BPAR(I),I=IMIN,IMAX)
      DO 155 I=IMIN,IMAX
         KTYP(I)=3
         KNG(I) =NGD
 155  CONTINUE
C
      MKLINP = NGD/MKM
      IF( NGD - MKLINP*MKM .GT. 0 ) MKLINP = MKLINP + 1
      IF(OUT) WRITE(IW,*) 'MKLINP =',MKLINP
      DO MKD = 1,MKLINP
        IEOF=0
        CALL RDCARD('$MCP    ',IEOF)
        CALL GSTRNG(MKLINE,LENGST)
        IF(OUT) WRITE(IW,'(A80)') MKLINE
        MINCR = MIN0(MKM, NGD - (MKD-1)*MKM )
        READ(UNIT=MKLINE,FMT=MCPFMT,ERR=944)
     +      (EX(MKOUNT_X+I),I=1,MINCR)
        MKOUNT_X=MKOUNT_X+MINCR
      ENDDO
      IF(OUT) WRITE(IW,FMT=MCPFMT) (EX(I),I=GMIN,GMAX)
      IF(OUT) WRITE(IW,*) 'MKOUNT_X =',MKOUNT_X
C     READ(IR,'(4G15.8)',ERR=944) (EX(I),I=GMIN,GMAX)
C ... READ 1ST C
      DO MKD=1,MKLINP
        IEOF=0
        CALL RDCARD('$MCP    ',IEOF)
        CALL GSTRNG(MKLINE,LENGST)
        IF(OUT) WRITE(IW,'(A80)') MKLINE
        MINCR = MIN0(MKM, NGD - (MKD-1)*MKM )
        READ(UNIT=MKLINE,FMT=MCPFMT,ERR=944)
     +      (C(MKOUNT_C+I),I=1,MINCR)
        MKOUNT_C=MKOUNT_C+MINCR
      ENDDO
      IF(OUT) WRITE(IW,FMT=MCPFMT) (C(I),I=GMIN,GMAX)
      IF(OUT) WRITE(IW,*) 'MKOUNT_C =',MKOUNT_C
C     READ(IR,'(4G15.8)',ERR=944) (C(I),I=GMIN,GMAX)
C
      GMINO=GMIN
      DO 160 K=IMIN+1,IMAX
        GMIN=GMAX+1
        GMAX=GMAX+NGD
        DO MKD=1,MKLINP
          IEOF=0
          CALL RDCARD('$MCP    ',IEOF)
          CALL GSTRNG(MKLINE,LENGST)
          IF(OUT) WRITE(IW,'(A80)') MKLINE
          MINCR = MIN0(MKM, NGD - (MKD-1)*MKM )
          READ(UNIT=MKLINE,FMT=MCPFMT,ERR=944)
     +        (C(MKOUNT_C+I),I=1,MINCR)
          MKOUNT_C=MKOUNT_C + MINCR
        ENDDO
        IF(OUT) WRITE(IW,FMT=MCPFMT) (C(I),I=GMIN,GMAX)
        IF(OUT) WRITE(IW,*) 'MKOUNT_C =',MKOUNT_C
C       READ(IR,'(4G15.8)',ERR=944) (C(I),I=GMIN,GMAX)
        DO 159 L=0,(NGD-1)
          EX(L+GMIN)=EX(L+GMINO)
          MKOUNT_X = MKOUNT_X + 1
 159    CONTINUE
        IF(OUT) WRITE(IW,*) 'MKOUNT_X =',MKOUNT_X
 160  CONTINUE
      IF(OUT) WRITE(IW,*) '--- END  D-SHELLS'
 161  CONTINUE
C
C     --- READ F-SHELLS
C
      IF(OUT) WRITE(IW,*) '--- READ F-SHELLS'
      IMIN=IMAX+1
      IMAX=IMAX+NOF
      GMIN=GMAX+1
      GMAX=GMAX+NGF
      IF ((IMIN.GT.IMAX).OR.(GMIN.GT.GMAX)) GOTO 171
C
      MKLINP = NOF/MKM
      IF( NOF - MKLINP*MKM .GT. 0 ) MKLINP = MKLINP + 1
      IF(OUT) WRITE(IW,*) 'MKLINP =',MKLINP
      DO MKF=1,MKLINP
        IEOF=0
        CALL RDCARD('$MCP    ',IEOF)
        CALL GSTRNG(MKLINE,LENGST)
        IF(OUT) WRITE(IW,'(A80)') MKLINE
        MINCR = MIN0(MKM, NOF - (MKF-1)*MKM)
        READ(UNIT=MKLINE,FMT=MCPFMT,ERR=944)
     +      (BPAR(MKOUNT_B + I),I=1,MINCR)
        MKOUNT_B = MKOUNT_B + MINCR
      ENDDO
      IF(OUT) WRITE(IW,FMT=MCPFMT) (BPAR(I),I=IMIN,IMAX)
      IF(OUT) WRITE(IW,*) 'MKOUNT_B =',MKOUNT_B
C     READ(IR,'(4G15.8)',ERR=944) (BPAR(I),I=IMIN,IMAX)
      DO 165 I=IMIN,IMAX
         KTYP(I)=4
         KNG(I) =NGF
 165  CONTINUE
C
      MKLINP = NGF/MKM
      IF( NGF - MKLINP*MKM .GT. 0 ) MKLINP = MKLINP + 1
      IF(OUT) WRITE(IW,*) 'MKLINP =',MKLINP
      DO MKF = 1,MKLINP
        IEOF=0
        CALL RDCARD('$MCP    ',IEOF)
        CALL GSTRNG(MKLINE,LENGST)
        IF(OUT) WRITE(IW,'(A80)') MKLINE
        MINCR = MIN0(MKM, NGF - (MKF-1)*MKM )
        READ(UNIT=MKLINE,FMT=MCPFMT,ERR=944)
     +      (EX(MKOUNT_X+I),I=1,MINCR)
        MKOUNT_X=MKOUNT_X+MINCR
      ENDDO
      IF(OUT) WRITE(IW,FMT=MCPFMT) (EX(I),I=GMIN,GMAX)
      IF(OUT) WRITE(IW,*) 'MKOUNT_X =',MKOUNT_X
C     READ(IR,'(4G15.8)',ERR=944) (EX(I),I=GMIN,GMAX)
C ... READ 1ST C
      DO MKF=1,MKLINP
        IEOF=0
        CALL RDCARD('$MCP    ',IEOF)
        CALL GSTRNG(MKLINE,LENGST)
        IF(OUT) WRITE(IW,'(A80)') MKLINE
        MINCR = MIN0(MKM, NGF - (MKF-1)*MKM )
        READ(UNIT=MKLINE,FMT=MCPFMT,ERR=944)
     +      (C(MKOUNT_C+I),I=1,MINCR)
        MKOUNT_C=MKOUNT_C+MINCR
      ENDDO
      IF(OUT) WRITE(IW,FMT=MCPFMT) (C(I),I=GMIN,GMAX)
      IF(OUT) WRITE(IW,*) 'MKOUNT_C =',MKOUNT_C
C     READ(IR,'(4G15.8)',ERR=944) (C(I),I=GMIN,GMAX)
      GMINO=GMIN
      DO 170 K=IMIN+1,IMAX
        GMIN=GMAX+1
        GMAX=GMAX+NGF
        DO MKF=1,MKLINP
          IEOF=0
          CALL RDCARD('$MCP    ',IEOF)
          CALL GSTRNG(MKLINE,LENGST)
          IF(OUT) WRITE(IW,'(A80)') MKLINE
          MINCR = MIN0(MKM, NGF - (MKF-1)*MKM )
          READ(UNIT=MKLINE,FMT=MCPFMT,ERR=944)
     +        (C(MKOUNT_C+I),I=1,MINCR)
          MKOUNT_C=MKOUNT_C + MINCR
        ENDDO
        IF(OUT) WRITE(IW,FMT=MCPFMT) (C(I),I=GMIN,GMAX)
        IF(OUT) WRITE(IW,*) 'MKOUNT_C =',MKOUNT_C
C       READ(IR,'(4G15.8)',ERR=944) (C(I),I=GMIN,GMAX)
        DO 169 L=0,(NGF-1)
          EX(L+GMIN)=EX(L+GMINO)
          MKOUNT_X = MKOUNT_X + 1
 169    CONTINUE
        IF(OUT) WRITE(IW,*) 'MKOUNT_X =',MKOUNT_X
 170  CONTINUE
 171  CONTINUE
      IF(OUT) WRITE(IW,*) '--- END  F-SHELLS'
C
C     --- NO.OF CORE-SHELLS:
      NOCOS=IMAX
C
      IF(IRDBAS.EQ.2) THEN
        IF(MASWRK) CLOSE(UNIT=IBFILE)
        IR = IR0
        CALL OPNCRD(IR,-IW)
      ENDIF
      RETURN
C
 7400 FORMAT(1X,'*** EXTERNAL BASIS SET FILE NOT FOUND ***'/
     *       1X,'FILE NAME SOUGHT WAS'/1X,A)
 7405 FORMAT(/1X,'THE EXTERNAL BASIS SET FILE BEING READ IS'/
     *        5X,'"',A,'"')
C
 944  CONTINUE
      IF(MASWRK) WRITE(6,'(A)')
     +  ' *** ERROR IN READING THE $MCP GROUP ***'
      CALL ABRT
      STOP
      END
