C  6 NOV 06 - MWS - ADJUST WAVEFUNCTION COMMON BLOCK
C  7 SEP 06 - DMC - IMPLEMENT FULL SVPE METHOD
C 12 JAN 06 - DMC - NVLPL KEYWORD FOR EXPLICIT VOLUME POLARIZATION
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  1 JUN 05 - DMC - SVPTOO: CHANGE FILE NO; SVPOUT: FINAL TOUCHES
C 30 APR 05 - DMC - FINISHING TOUCHES FOR THE INITIAL IMPLEMENTATION
C 13 FEB 05 - DMC - NEW MODULE IMPLEMENTING SVP SOLVATION MODEL
C
C    ----- SURFACE AND VOLUME POLARIZATION FOR ELECTROSTATICS -----
C    CODE WAS ADAPTED FROM THE HONDO IMPLEMENTATION.
C
C    EXTERNAL FILES 17 AND 18 ARE USED FOR SCRATCH SPACE IN CASES
C    WHERE THE LARGE NCAV*NCAV SYSTEM MATRIX DOES NOT FIT IN CORE.
C    IDAF RECORDS 260 AND 261 ARE RESERVED FOR USE BY THIS CODE.
C
C*MODULE SVPCHG  *DECK SVPCHG
      SUBROUTINE SVPCHG(DA,DB,H0,HSVP,IADDR,ILAST,L2,L1,ESVP,ITER,
     1                  CVGDN,CVGDN1,CVGNR,IUPRXN,CHGDIF,CVGSVP)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C     ----- DETERMINE SVP REACTION FIELD CHARGES AND FREE ENERGY -----
C
      PARAMETER   (MXATM=2000)
      PARAMETER   (MXCAV=5810)
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00)
      PARAMETER (TOANGS=0.52917724924D+00)
      PARAMETER (TOKCAL=627.509451D+00)
      LOGICAL     SOME
      LOGICAL     OUT
      LOGICAL     MORE
      LOGICAL     DBUG
      LOGICAL     CVGDN,CVGDN1,CVGNR,CVGSVP
      LOGICAL     CAVPOT,CAVFLD
      COMMON /FMCOM / X(1)
      COMMON /IOFILE/ IR,IW,IP,IJK,IJKT,IDAF,NAV,IODA(950)
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /WFNOPT/ SCFTYP,VBTYP,DFTYPE,TDDFTYP,CITYP,CCTYP,
     *                MPLEVL,MPCTYP
      COMMON/SVPFLT/RHOISO,TOLCAV,RSTART,RSPACE,RADSPH,RADSLV,TOLCHG,
     1              DIELST,DIELOP,ZIONP,ZIONM,TKELVN,ROTCAV(3),
     2              TRNCAV(3),CSDIAG,CVGLIN
      COMMON/SVPTGR/NVLPL,MTHSVP,IQORP,NSTAGE,IOPPRD,IRENRM,ISHAPE,
     1              ITRCAV,NDRCAV,ICVICK,IFRQUP,IRDRF,IONSTR,
     2              INTCAV,NPTLEB,NPTTHE,NPTPHI,IROTGR,ITRNGR,
     3              ICRD,LINEQ,IPNRF,IPRRF,IPNDN,IPRDN,IEX
      COMMON/SVPPAR/CAVC(3,MXCAV),CAVW(MXCAV),CAVQ(MXCAV),
     1              CAVN(3,MXCAV),SPHW(MXCAV),CAVP(MXCAV),
     2              CENCAV(3),RNTCAV(3),NCAV,IQP
      COMMON/SVPPR0/CAVC0(3,MXCAV),CAVW0(MXCAV),CAVQ0(MXCAV),
     1              CAVN0(3,MXCAV),SPHW0(MXCAV),CAVP0(MXCAV),
     2              CENCV0(3),RNTCV0(3),NCAV0,IQP0,NVLPL0
      COMMON/SVPNRG/ATMSVP,ELCSVP,SVPSVP,SURSVP,VOLPLM,VOLSVP,RXNSVP
      COMMON/SVPPRP/SURF,VOL,RHOEXT,CHGBAR,CHGRUL,CHGDEV,BTABAR
      COMMON/SVPDBG/IDBG
      COMMON/SVPCVG/CHGDF
C
      DIMENSION DA(*),DB(*)
      DIMENSION H0(*),HSVP(*)
C
      CHARACTER*4 KEYBLK,KEYFST,IFIRST
C
      DATA NFT17 /26/
      DATA NFT18 /27/
      DATA UHF,ROHF/8HUHF     ,8HROHF    /
      DATA RNONE/8HNONE    /
      DATA KEYBLK  /'    '/
      DATA KEYFST  /'FRST'/
      DATA IFIRST  /'FRST'/
      SAVE IFIRST
C
      DBUG=.FALSE.
      DBUG=DBUG.OR.IDBG.EQ.4
      MORE=.FALSE.
      MORE=MORE.OR.DBUG.OR.IDBG.EQ.3
      OUT =.FALSE.
      OUT =OUT.OR.MORE.OR.IDBG.EQ.2
      SOME=.FALSE.
      SOME=SOME.OR.OUT.OR.IDBG.EQ.1
C
      IF(OUT) THEN
         IF(IQORP.EQ.0) WRITE(IW,9999)
         IF(IQORP.EQ.1) WRITE(IW,9998)
         WRITE(IW,9996) SCFTYP
         CALL FLSHBF(IW)
      ENDIF
C
      IF(NCAV.LE.0) THEN
         WRITE(IW,*) 'NO -SVP- SURFACE POINTS. STOP.'
         CALL ABRT
      ELSE
         IF(OUT) THEN
            WRITE(IW,*) '-NCAV- = ',NCAV
            WRITE(IW,*) 'IADDR  = ',IADDR
            WRITE(IW,*) 'ILAST  = ',ILAST
            WRITE(IW,*) 'IUPRXN = ',IUPRXN
            WRITE(IW,*) 'IFRQUP = ',IFRQUP
            WRITE(IW,*) 'IRDRF  = ',IRDRF
            CALL FLSHBF(IW)
         ENDIF
      ENDIF
C
      CALL SEQOPN(NFT17,'SVPWRK1','UNKNOWN',.FALSE.,'UNFORMATTED')
      CALL SEQOPN(NFT18,'SVPWRK2','UNKNOWN',.FALSE.,'UNFORMATTED')
C
C     ----- DETERMINE UPDATE PARAMETER AND LOCATION OF REACTION FIELD --
C
C     IUPRXN = 0: DO NOT UPDATE RXN FIELD, USE CAVQ0 ETC FOR ENERGY
C     IUPRXN = 1: DO NOT UPDATE RXN FIELD, USE CAVQ  ETC FOR ENERGY
C     IUPRXN = 2: DO     UPDATE RXN FIELD, USE CAVQ  ETC FOR ENERGY
C
      IF(IFRQUP.EQ.0) THEN
         IF(IRDRF.EQ.0) THEN
                                                                IUPRXN=2
         ELSEIF(IRDRF.EQ.1) THEN
            IF(ITER.EQ.0)                                       IUPRXN=0
            IF(ITER.GT.0)                                       IUPRXN=2
         ENDIF
      ELSEIF(IFRQUP.EQ.1) THEN
         IF(IRDRF.EQ.0) THEN
                                                                IUPRXN=2
            IF(MOD(ITER,2).NE.0.AND..NOT.CVGNR)                 IUPRXN=1
         ELSEIF(IRDRF.EQ.1) THEN
            IF(ITER.LT.2) THEN
                                                                IUPRXN=0
            ELSEIF(ITER.GE.2) THEN
                                                                IUPRXN=2
               IF(MOD(ITER,2).NE.0.AND..NOT.CVGNR)              IUPRXN=1
            ENDIF
         ENDIF
      ELSEIF(IFRQUP.EQ.2) THEN
         IF(IRDRF.EQ.0) THEN
                                                                IUPRXN=2
            IF(MOD(ITER,4).NE.0.AND..NOT.CVGNR)                 IUPRXN=1
         ELSEIF(IRDRF.EQ.1) THEN
            IF(ITER.LT.4) THEN
                                                                IUPRXN=0
            ELSEIF(ITER.GE.4) THEN
                                                                IUPRXN=2
               IF(MOD(ITER,4).NE.0.AND..NOT.CVGNR)              IUPRXN=1
            ENDIF
         ENDIF
      ELSEIF(IFRQUP.EQ.3) THEN
         IF(IRDRF.EQ.0) THEN
                                                                IUPRXN=2
            IF(ITER.EQ.1)                                       IUPRXN=1
            IF(ITER.GT.1.AND..NOT.CVGDN)                        IUPRXN=1
         ELSEIF(IRDRF.EQ.1) THEN
                                                                IUPRXN=2
            IF(ITER.GT.0.AND..NOT.CVGDN)                        IUPRXN=1
            IF(.NOT.CVGDN1)                                     IUPRXN=0
         ENDIF
      ELSEIF(IFRQUP.EQ.4) THEN
         IF(IRDRF.EQ.0) THEN
                                                                IUPRXN=2
            IF(ITER.GT.0)                                       IUPRXN=1
         ELSEIF(IRDRF.EQ.1) THEN
                                                                IUPRXN=0
         ENDIF
      ENDIF
C
      IF(OUT) THEN
         WRITE(IW,*) '-IUPRXN- = ',IUPRXN
      ENDIF
C
      SURSVP=ZERO
      VOLSVP=ZERO
      RXNSVP=ZERO
      ESVP=ZERO
C
C     ----- DENSITY MATRIX -----
C
      IF(MPLEVL.EQ.0  .AND.  CITYP.EQ.RNONE  .AND.  CCTYP.EQ.RNONE) THEN
         IF(SCFTYP.EQ.UHF  .OR.  SCFTYP.EQ.ROHF) THEN
            IF(OUT) THEN
               WRITE(IW,*) 'ALPHA DENSITY'
               IF(DBUG) THEN
                  CALL PRTRI(DA,L1)
               ENDIF
               WRITE(IW,*) 'BETA  DENSITY'
               IF(DBUG) THEN
                  CALL PRTRI(DB,L1)
               ENDIF
               CALL FLSHBF(IW)
            ENDIF
            DO I=1,L2
               DA(I)=DA(I)+DB(I)
            ENDDO
         ENDIF
         IF(OUT) THEN
            WRITE(IW,*) 'TOTAL DENSITY'
            IF(DBUG) THEN
               CALL PRTRI(DA,L2)
            ENDIF
            CALL FLSHBF(IW)
         ENDIF
      ELSE
         WRITE(IW,*) 'SVP MODEL: THIS IS NOT AN SCF CASE?'
         CALL ABRT
      ENDIF
C
C     ----- SET POINTERS FOR PARTITIONING OF CORE TO UPDATE CAVITY -----
C
C     -FGAM- AT X(I10) (NCAV)
C     -RHO-  AT X(I20) (NCAV)
C     -DRHO- AT X(I30) (3*NCAV)
C     -CAVR- AT X(I40) (3*NCAV+3)
C
      I10=IADDR
      I20=I10+NCAV
      IF(IUPRXN.EQ.2) THEN
         DO I=1,NCAV
            X(I10+I-1)=CSDIAG
         ENDDO
C
C     ----- UPDATE CAVITY -----
C
         IF(ISHAPE.EQ.0) THEN
            I30=I20+   NCAV
            I40=I30+3* NCAV
            I50=I40+3*(NCAV+1)
            LAST=I50-1
            IF(LAST.GT.ILAST) THEN
               NEED=LAST-ILAST
               WRITE(IW,*) 'NOT ENOUGH MEMORY TO UPDATE CAVITY. STOP'
               WRITE(IW,*) 'ADDITIONAL WORDS NEEDED =',NEED
               WRITE(IW,*) 'IADDR = ',IADDR
               WRITE(IW,*) 'ILAST = ',ILAST
               WRITE(IW,*) 'I10   = ',I10
               WRITE(IW,*) 'LAST  = ',LAST
               CALL ABRT
            ENDIF
C
            CALL SVPISO(CENCAV,SPHW,CAVC,CAVW,CAVN,NCAV,RHOISO,
     1           ITRCAV,TOLCAV,NDRCAV,DA,X(I10),X(I20),X(I30))
C           UPON RETURN FROM SVPISO, SURFACE PROPERTIES ARE STORED AS:
C           X(I10) HOLDS FGAM, X(I20) HOLDS RHO,
C           FIRST  NCAV LOCATIONS OF X(I30) HOLD ZETA
C           (BUT CURRENTLY THE I20,I30 SPACES ARE RELEASED BELOW ANYWAY)
C          LAST 2*NCAV LOCATIONS OF X(I30) CAN BE USED FOR RHO IN SVPICK
C
            IF (ICVICK.GT.0) THEN
               CALL SVPICK(CENCAV,CAVC,X(I40),NCAV,RHOISO,DA,
     1                     X(I30+NCAV),RSTART,RSPACE)
            ENDIF
C
         ENDIF
C
      ENDIF
C
C     - RESET POINTERS FOR PARTITIONING OF CORE TO GET ELP,ELF,Q OR P -
C
C     -ELP-      AT X(I20) (0 OR NCAV)
C     -ELF-      AT X(I30) (0 OR NCAV)
C     -Q- OR -P- AT X(I40) (NCAV)
C     -Q- COPY   AT X(I50) (NCAV)
C
      IF(OUT) THEN
         WRITE(IW,*) '-IQORP-  = ',IQORP
         WRITE(IW,*) '-IUPRXN- = ',IUPRXN
         WRITE(IW,*) '-MTHSVP- = ',MTHSVP
         CALL FLSHBF(IW)
      ENDIF
C
      CAVPOT=.FALSE.
      CAVFLD=.FALSE.
      IF(IQORP.EQ.0) CAVPOT=.TRUE.
      IF(IQORP.EQ.1) CAVFLD=.TRUE.
C
      IF(IUPRXN.EQ.2) THEN
         IF(IQORP.EQ.1) THEN
            IF(MTHSVP.EQ.0.OR.MTHSVP.EQ.1.OR.MTHSVP.EQ.3) CAVPOT=.TRUE.
         ENDIF
         IF(IQORP.EQ.0) THEN
            IF(MTHSVP.EQ.2.OR.MTHSVP.EQ.3) CAVFLD=.TRUE.
         ENDIF
         IF(NVLPL.GT.0) CAVPOT=.TRUE.
         IF(NVLPL.GT.0) CAVFLD=.TRUE.
      ENDIF
C
      IF(CAVPOT) THEN
         I30=I20+NCAV
      ELSE
         I30=I20
      ENDIF
C
      IF(CAVFLD) THEN
         I40=I30+NCAV
      ELSE
         I40=I30
      ENDIF
C
      I50=I40+NCAV
      LAST=I50-1
      IF(NVLPL.GT.0) THEN
         I60=I50+NCAV
         LAST=I60-1
      ENDIF
      IF(LAST.GT.ILAST) THEN
         WRITE(IW,*) 'NOT ENOUGH MEMORY FOR FGAM,ELP,ELF,Q. STOP'
         WRITE(IW,*) 'IADDR = ',IADDR
         WRITE(IW,*) 'ILAST = ',ILAST
         WRITE(IW,*) 'I10   = ',I10
         WRITE(IW,*) 'LAST  = ',LAST
         CALL ABRT
      ENDIF
C
C     --- GET ELECTROSTATIC POTENTIAL AND/OR NORMAL ELECTRIC FIELD ---
C
      IADDL=I40
      IF(IUPRXN.EQ.0) THEN
         IF(OUT) THEN
            WRITE(IW,*) 'CALL -SVPEPF- ...'
            CALL FLSHBF(IW)
         ENDIF
         CALL SVPEPF(DA,IADDL,ILAST,NCAV0,CAVC0,CAVN0,
     1               CAVPOT,X(I20),CAVFLD,X(I30))
      ENDIF
      IF(IUPRXN.GT.0) THEN
         IF(OUT) THEN
            WRITE(IW,*) 'CALL -SVPEPF- ...'
            CALL FLSHBF(IW)
         ENDIF
         CALL SVPEPF(DA,IADDL,ILAST,NCAV,CAVC,CAVN,
     1               CAVPOT,X(I20),CAVFLD,X(I30))
      ENDIF
C
      IF(MORE) THEN
         IF(CAVPOT) THEN
            WRITE(IW,*) '-ELP-'
            CALL PRSQ(X(I20),1,NCAV,NCAV)
            CALL FLSHBF(IW)
         ENDIF
         IF(CAVFLD) THEN
            WRITE(IW,*) '-ELF-'
            CALL PRSQ(X(I30),1,NCAV,NCAV)
            CALL FLSHBF(IW)
         ENDIF
      ENDIF
C
C     ----- DIELECTRIC CONSTANT FOR SCRF CALCULATION -----
C
      DIEL=DIELST
      IF(IRDRF.EQ.2) DIEL=DIELOP
C
C     ----- REACTION FIELD CHARGES OR DIPOLES ON CAVITY SURFACE -----
C
      IADDL=I50
      IF(IUPRXN.EQ.2.AND.IQORP.EQ.0.AND.MTHSVP.EQ.0) THEN
C
C     ----- SS(V)PE POINT CHARGES -----
C
         IF(OUT) THEN
            WRITE(IW,*) 'CALL -SVPQ0- ...'
            CALL FLSHBF(IW)
         ENDIF
         CALL SVPQ0(IADDL,ILAST,DIEL,NCAV,IOPPRD,CAVC,CAVW,CAVN,
     1              NSTAGE,X(I10),LINEQ,CVGLIN,X(I20),       X(I40))
         IF(NVLPL.GT.0) THEN
C
C     ----- SVPE POINT CHARGES -----
C
            IF(OUT) THEN
               WRITE(IW,*) 'CALL -SVPQV- ...'
               CALL FLSHBF(IW)
            ENDIF
C           SAVE SS(V)PE CHARGES IN X(I50), FORM SVPE CHARGES IN X(I40)
            DO I=1,NCAV
               X(I+I50-1)=X(I+I40-1)
            ENDDO
            CALL SVPQV(NCAV,CAVC,CAVW,CAVN,DIEL,X(I30),X(I50),X(I40))
         ENDIF
      ENDIF
      IF(IUPRXN.EQ.2.AND.IQORP.EQ.0.AND.MTHSVP.EQ.1) THEN
C
C     ----- COSMO POINT CHARGES -----
C
         IF(OUT) THEN
            WRITE(IW,*) 'CALL -SVPQ1- ...'
            CALL FLSHBF(IW)
         ENDIF
         CALL SVPQ1(IADDL,ILAST,DIEL,NCAV,       CAVC,CAVW,
     1                     X(I10),LINEQ,CVGLIN,X(I20),       X(I40))
      ENDIF
      IF(IUPRXN.EQ.2.AND.IQORP.EQ.0.AND.MTHSVP.EQ.2) THEN
C
C     ----- SPE POINT CHARGES -----
C
         IF(OUT) THEN
            WRITE(IW,*) 'CALL -SVPQ2- ...'
            CALL FLSHBF(IW)
         ENDIF
         CALL SVPQ2(IADDL,ILAST,DIEL,NCAV,       CAVC,CAVW,CAVN,
     1              IRENRM,X(I10),LINEQ,CVGLIN,       X(I30),X(I40))
      ENDIF
      IF(IUPRXN.EQ.2.AND.IQORP.EQ.0.AND.MTHSVP.EQ.3) THEN
C
C     ----- IEF POINT CHARGES -----
C
         IF(OUT) THEN
            WRITE(IW,*) 'CALL -SVPQ3- ...'
            CALL FLSHBF(IW)
         ENDIF
         CALL SVPQ3(IADDL,ILAST,DIEL,NCAV,IOPPRD,CAVC,CAVW,CAVN,
     1              NSTAGE,X(I10),LINEQ,CVGLIN,X(I20),X(I30),X(I40))
      ENDIF
      IF(IUPRXN.EQ.2.AND.IQORP.EQ.1.AND.MTHSVP.EQ.0) THEN
C
C     ----- SS(V)PE POINT DIPOLES -----
C
         IF(OUT) THEN
            WRITE(IW,*) 'CALL -SVPP0- ...'
            CALL FLSHBF(IW)
         ENDIF
         CALL SVPP0(IADDL,ILAST,DIEL,NCAV,       CAVC,CAVW,CAVN,
     1                            LINEQ,CVGLIN,X(I20),       X(I40))
      ENDIF
      IF(IUPRXN.EQ.2.AND.IQORP.EQ.1.AND.MTHSVP.EQ.1) THEN
C
C     ----- COSMO POINT DIPOLES -----
C
         IF(OUT) THEN
            WRITE(IW,*) 'CALL -SVPP1- ...'
            CALL FLSHBF(IW)
         ENDIF
         CALL SVPP1(IADDL,ILAST,DIEL,NCAV,       CAVC,CAVW,CAVN,
     1                            LINEQ,CVGLIN,X(I20),       X(I40))
      ENDIF
      IF(IUPRXN.EQ.2.AND.IQORP.EQ.1.AND.MTHSVP.EQ.2) THEN
C
C     ----- SPE POINT DIPOLES -----
C
         IF(OUT) THEN
            WRITE(IW,*) 'CALL -SVPP2- ...'
            CALL FLSHBF(IW)
         ENDIF
         CALL SVPP2(IADDL,ILAST,DIEL,NCAV,IOPPRD,CAVC,CAVW,CAVN,
     1              NSTAGE,X(I10),LINEQ,CVGLIN,       X(I30),X(I40))
      ENDIF
      IF(IUPRXN.EQ.2.AND.IQORP.EQ.1.AND.MTHSVP.EQ.3) THEN
C
C     ----- IEF POINT DIPOLES -----
C
         IF(OUT) THEN
            WRITE(IW,*) 'CALL -SVPP3- ...'
            CALL FLSHBF(IW)
         ENDIF
         CALL SVPP3(IADDL,ILAST,DIEL,NCAV,IOPPRD,CAVC,CAVW,CAVN,
     1              NSTAGE,X(I10),LINEQ,CVGLIN,X(I20),X(I30),X(I40))
      ENDIF
C
C     ----- TOTAL CHARGE ON SURFACE -----
C
      IF(IQORP.EQ.0) THEN
         CHGBAR=ZERO
         DO I=1,NCAV
            IF(IUPRXN.EQ.0) CHGBAR=CHGBAR+CAVQ0(I)
            IF(IUPRXN.EQ.1) CHGBAR=CHGBAR+CAVQ(I)
            IF(IUPRXN.EQ.2) CHGBAR=CHGBAR+X(I+I40-1)
         ENDDO
         CHGRUL=-CHGBAR*DIEL/(DIEL-ONE)
         CHGDEV=ICH-CHGRUL
      ENDIF
C
C     -- UPDATE SURFACE CHARGES OR DIPOLES AND CHECK FOR CONVERGENCE --
C
      CVGSVP=.FALSE.
      IF(IFRQUP.EQ.4) CVGSVP=.TRUE.
      IF(IUPRXN.EQ.2) THEN
         CHGDIF=ZERO
         DO I=1,NCAV
            IF(IFIRST.EQ.KEYFST)                OLDI=ZERO
            IF(IFIRST.NE.KEYFST.AND.IQORP.EQ.0) OLDI=CAVQ(I)
            IF(IFIRST.NE.KEYFST.AND.IQORP.EQ.1) OLDI=CAVP(I)
            CHGI=X(I+I40-1)
            DIFCHG=ABS(CHGI-OLDI)
            IF(DIFCHG.GT.CHGDIF) THEN
               CHGDIF=DIFCHG
            ENDIF
            IF(IQORP.EQ.0) CAVQ(I)=CHGI
            IF(IQORP.EQ.1) CAVP(I)=CHGI
         ENDDO
         IFIRST=KEYBLK
         IF(OUT) THEN
            IF(IQORP.EQ.0) WRITE(IW,9992) CHGDIF
            IF(IQORP.EQ.1) WRITE(IW,9991) CHGDIF
         ENDIF
         IF(CHGDIF.LE.TOLCHG) CVGSVP=.TRUE.
         CHGDF=CHGDIF
      ENDIF
C
C     ----- ENERGY TERMS FROM SURFACE CHARGES AND/OR DIPOLES -----
C
      IF(IUPRXN.EQ.0) THEN
         CALL SVPENR(NCAV0,IQP0,CAVC0,CAVQ0,CAVN0,CAVP0,
     1               X(I20),X(I30),ATMSVP,ELCSVP,SVPSVP,SURSVP)
      ELSEIF(IUPRXN.GT.0) THEN
         CALL SVPENR(NCAV ,IQP ,CAVC ,CAVQ ,CAVN ,CAVP ,
     1               X(I20),X(I30),ATMSVP,ELCSVP,SVPSVP,SURSVP)
      ENDIF
      RXNSVP = SURSVP
      ESVP   = RXNSVP
C
C     ----- HAMILTONIAN AND ENERGY TERMS FROM VOLUME CHARGES -----
C
C     RELEASE SPACE USED BY FGAM, CAVPOT, CAVFLD, Q, P
      IADDL=I10
      CALL DAREAD(IDAF,IODA,H0,L2,87,0)
      IF(IUPRXN.EQ.0) THEN
         CALL SVPHAM(DA,IADDL,ILAST,L2,NCAV0,CENCAV,CAVC0,CAVQ0,
     1      CAVN0,CAVP0,IQP0,H0,HSVP,IUPRXN,NVLPL0,SPHW0,DIEL,
     2      BTABAR,ATMVOL,ELCVOL,VOLPLM,VOLSVP)
      ELSEIF(IUPRXN.GT.0) THEN
         CALL SVPHAM(DA,IADDL,ILAST,L2,NCAV ,CENCAV,CAVC ,CAVQ ,
     1      CAVN ,CAVP ,IQP ,H0,HSVP,IUPRXN,NVLPL ,SPHW ,DIEL,
     2      BTABAR,ATMVOL,ELCVOL,VOLPLM,VOLSVP)
      ENDIF
      IF(NVLPL.GT.0) THEN
         ATMSVP = ATMSVP+ATMVOL
         ELCSVP = ELCSVP+ELCVOL
         RXNSVP = RXNSVP+VOLSVP
         ESVP   = ESVP  +VOLSVP
      ENDIF
C
      IF(OUT) THEN
         WRITE(IW,8769)
         WRITE(IW,8768) ATMSVP,ELCSVP,SVPSVP
         IF(NVLPL.GT.0) WRITE(IW,8767) VOLSVP
         WRITE(IW,8766) RXNSVP,(RXNSVP*TOKCAL)
         WRITE(IW,8757)
         WRITE(IW,8756) SURF,SURF*TOANGS**2,VOL,VOL*TOANGS**3,RHOEXT
         IF(IQORP.EQ.0) THEN
            WRITE(IW,8755) CHGBAR,CHGRUL,CHGDEV
         ENDIF
      ENDIF
C
C     ----- RESET DENSITY MATRIX IF -UHF- BEFORE RETURNING -----
C
      IF(MPLEVL.EQ.0  .AND.  CITYP.EQ.RNONE  .AND.  CCTYP.EQ.RNONE) THEN
         IF(SCFTYP.EQ.UHF  .OR.  SCFTYP.EQ.ROHF) THEN
            DO I=1,L2
               DA(I)=DA(I)-DB(I)
            ENDDO
         ENDIF
      ENDIF
C
C     ----- EXIT -----
C
      IF(OUT) THEN
         WRITE(IW,9982)
      ENDIF
      RETURN
C
 9999 FORMAT(/,10X,20('-'),
     1       /,10X,'-SVP- POINT CHARGES',
     2       /,10X,20('-'))
 9998 FORMAT(/,10X,20('-'),
     1       /,10X,'-SVP- POINT DIPOLES',
     2       /,10X,20('-'))
 9996 FORMAT(' -SCFTYP- = ',A8)
 9992 FORMAT(' -SVP- CHARGES CONVERGENCE = ',F10.6)
 9991 FORMAT(' -SVP- DIPOLES CONVERGENCE = ',F10.6)
 9982 FORMAT(' ...... END OF -SVPCHG- ......')
 8769 FORMAT(/,1X,'-SVP-  ENERGIES',/,1X,15('-'))
 8768 FORMAT(' ATM / SURF ENERGY      = ',F16.6,/,
     1       ' ELC / SURF ENERGY      = ',F16.6,/,
     2       ' SURF/ SURF ENERGY      = ',F16.6)
 8767 FORMAT(' VOLUME POL ENERGY      = ',F16.6)
 8766 FORMAT(' RXN FIELD FREE ENERGY  = ',F16.6,
     1       ' ( ',F10.3,' KCAL/MOL ) ')
 8757 FORMAT(/,1X,'-SVP-  PROPERTIES',/,1X,17('-'))
 8756 FORMAT(' CAVITY SURFACE AREA    = ',F16.3,
     1       ' ( ',F12.3,' ANG**2 ) ',/,
     2       ' CAVITY VOLUME          = ',F16.3,
     3       ' ( ',F12.3,' ANG**3 ) ',/,
     4       ' CHG PENET FROM EXP FIT = ',F16.6)
 8755 FORMAT(' TOTAL SURFACE CHARGE Q = ',F16.6/
     1       ' CHGRUL= -Q*EPS/(EPS-1) = ',F16.6/
     2       ' SOLUTE CHARGE - CHGRUL = ',F16.6)
      END
C
C*MODULE SVPCHG  *DECK SVPISO
      SUBROUTINE SVPISO(CENCAV,SPHW,CAVC,CAVW,CAVN,NCAV,RHOISO,
     1                  ITRCAV,TOLCAV,NDRCAV,DENS,FGAM,RHO,DRHO)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C     ----- UPDATE ISODENSITY CAVITY SURFACE HAVING SINGLE FIXED CENTER
C
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00, TWO=2.0D+00, THREE=3.0D+00,
     *           FOUR=4.0D+00, ONE80=180.0D+00)
      PARAMETER (TOANGS=0.52917724924D+00)
      LOGICAL    CVGD
      LOGICAL    SOME
      LOGICAL    OUT
      LOGICAL    MORE
      LOGICAL    DBUG
      COMMON /IOFILE/ IR,IW,IP,IJK,IJKT,IDAF,NAV,IODA(950)
      COMMON/SVPPRP/SURF,VOL,RHOEXT,CHGBAR,CHGRUL,CHGDEV,BTABAR
      COMMON/SVPDBG/IDBG
      DIMENSION CENCAV(3),SPHW(*)
      DIMENSION CAVC(3,*),CAVW(*),CAVN(3,*)
      DIMENSION DENS(*)
      DIMENSION FGAM(*),RHO(*),DRHO(3,*)
C
C     FOR NDRCAV=0, HOLD ROLD(I) IN DRHO(1,I) AND RHOOLD(I) IN DRHO(2,I)
C
      PI=FOUR*ATAN(ONE)
      TODEG=ONE80/PI
C
C     GENERIC EXPONENTIAL PARAMETER FOR USE IN FIRST ITERATION WHEN NDRC
C
      ZETA=2.4D+00
C
      DBUG=.FALSE.
      DBUG=DBUG.OR.IDBG.EQ.4
      MORE=.FALSE.
      MORE=MORE.OR.DBUG.OR.IDBG.EQ.3
      OUT =.FALSE.
      OUT =OUT.OR.MORE.OR.IDBG.EQ.2
      SOME=.FALSE.
      SOME=SOME.OR.OUT.OR.IDBG.EQ.1
C
C     ----- ITERATIVELY UPDATE CURRENT SURFACE TO ISODENSITY SURFACE ---
C
      NDER=0
      IF(NDRCAV.GT.0) NDER=1
      DAMP=0.2D+00
      CONV=TOLCAV
      MAXIT=ITRCAV
      DELMAX=ZERO
      ITER=0
  100 ITER=ITER+1
      IF(ITER.GT.MAXIT) THEN
         WRITE(IW,*) 'MAXIT EXCEEDED FINDING ISODENSITY CONTOUR. STOP'
         WRITE(IW,*) 'MAXIT, FINAL DELMAX =',MAXIT,DELMAX
         CALL ABRT
      ENDIF
C
C     GET DENSITY, AND PERHAPS ALSO ITS GRADIENT, AT ALL CURRENT GRID PO
C
      CALL SVP_ELDEND(NCAV,CAVC,RHO,DRHO,DDRHO,DENS,NDER)
C
C     MAKE IMPROVED GUESS TO ISODENSITY CONTOUR
C
      CVGD=.TRUE.
      DELMAX=ZERO
      NMNEGA=0
      DO I=1,NCAV
C
C     GET DENSITY AT CURRENT POINT AND CHECK FOR CONVERGENCE
C
         RHOI=RHO(I)
         DELRHO=RHOI-RHOISO
         IF(ABS(DELRHO).GT.DELMAX) DELMAX=ABS(DELRHO)
         IF(ABS(DELRHO).GT.CONV) THEN
C
C     UPDATE CAVITY AT THIS UNCONVERGED POINT
C
            CVGD=.FALSE.
            XI=CAVC(1,I)-CENCAV(1)
            YI=CAVC(2,I)-CENCAV(2)
            ZI=CAVC(3,I)-CENCAV(3)
            RI=SQRT(XI**2+YI**2+ZI**2)
C
C     ESTIMATE STEP LENGTH TOWARD DESIRED ISODENSITY POINT
C
            IF (RHOI.LT.RHOISO*1.0D-04) THEN
C
C     SPECIAL STEP FOR VERY SMALL DENSITY
C
               ZETAI=ZETA
               DELR=-DAMP*RI
            ELSEIF(RHOI.GE.RHOISO*1.0D-04) THEN
C
C     DETERMINE EFFECTIVE EXPONENTIAL PARAMETER
C
               IF(NDER.EQ.0) THEN
                  IF(ITER.EQ.1) THEN
                     ZETAI=ZETA
                  ELSEIF(ITER.GT.1) THEN
                     DRHOI=(RHOI-DRHO(2,I))/(RI-DRHO(1,I))
                     ZETAI=-DRHOI/RHOI
                  ENDIF
               ELSEIF(NDER.EQ.1) THEN
                  DRHOI=(DRHO(1,I)*XI+DRHO(2,I)*YI+DRHO(3,I)*ZI)/RI
                  ZETAI=-DRHOI/RHOI
               ENDIF
               IF(ZETAI.EQ.ZERO) THEN
                  WRITE(IW,*) 'EFFECTIVE EXPONENTIAL ZETA = ZERO. STOP'
                  WRITE(IW,*) 'ITER,I,X,Y,Z,R,RHO,DRHO =',
     1                         ITER,I,XI,YI,ZI,RI,RHOI,DRHOI
                  CALL ABRT
               ELSEIF(ZETAI.LT.ZERO) THEN
                  NMNEGA=NMNEGA+1
               ENDIF
C
C     ASSUME EXPONENTIAL RADIAL DENSITY TO PREDICT ISODENSITY P
C
               IF(ZETAI.GT.ZERO.OR.
     1           (ZETAI.LT.ZERO.AND.RHOI.GT.RHOISO)) THEN
                  DELR=(ONE/ZETAI)*LOG(RHOI/RHOISO)
C
C     EMPIRICALLY DAMP LARGE CHANGES
C
                  IF(ABS(DELR).GT.DAMP*RI) DELR=SIGN(DAMP*RI,DELR)
               ENDIF
C
C     BUT DON'T BELIEVE NEGATIVE ZETA AT SMALL RHO
C
               IF(ZETAI.LT.ZERO.AND.RHOI.LE.RHOISO) THEN
                  DELR=-DAMP*RI
               ENDIF
            ENDIF
C
C     ADD THE PREDICTED CHANGES
C
            RATIO=DELR/RI
            CAVC(1,I)=CAVC(1,I)+RATIO*XI
            CAVC(2,I)=CAVC(2,I)+RATIO*YI
            CAVC(3,I)=CAVC(3,I)+RATIO*ZI
C
C     REMEMBER PREVIOUS VALUES IF NDER=0
C
            IF(NDER.EQ.0) THEN
               DRHO(1,I)=RI
               DRHO(2,I)=RHOI
            ENDIF
         ENDIF
      ENDDO
C
C     CHECK FOR OVERALL CONVERGENCE
C
      IF(.NOT.CVGD) GOTO 100
C
C     ----- REJECT APPARENT CONVERGENCE IF ANY NEGATIVE ZETA'S -----
C
      IF(NMNEGA.GT.0) THEN
         WRITE(IW,*) 'APPARENTLY CONVERGED ISODENSITY SURFACE REJECTED'
         WRITE(IW,*) 'DUE TO NEGATIVE EXPONENTIAL ZETA: NMNEGA=',NMNEGA
         CALL ABRT
      ENDIF
C
C     - NORMALS, WEIGHTS, DENSITIES, AREA, VOLUME, CHARGE PENETRATION -
C
      NDER=1
      CALL SVP_ELDEND(NCAV,CAVC,RHO,DRHO,DDRHO,DENS,NDER)
C
        SURF=ZERO
        VOL =ZERO
      RHOEXT=ZERO
        NBAD=0
        IBAD=0
      COSBAD=ONE
       NWARN=0
       IWARN=0
      COSWRN=ONE
      COSTST=0.05D+00
      DO I=1,NCAV
C
C     FIND RADIAL DISTANCE OF CURRENT POINT FROM CENTER
C
         XI=CAVC(1,I)-CENCAV(1)
         YI=CAVC(2,I)-CENCAV(2)
         ZI=CAVC(3,I)-CENCAV(3)
         RI=SQRT(XI**2+YI**2+ZI**2)
C
C     FOR ISODENSITY SURFACE, NORMAL LIES ALONG NEGATIVE GRADIENT OF
C
         CAVNXI=-DRHO(1,I)
         CAVNYI=-DRHO(2,I)
         CAVNZI=-DRHO(3,I)
         ANORMI=ONE/SQRT(CAVNXI**2+CAVNYI**2+CAVNZI**2)
         CAVNXI=ANORMI*CAVNXI
         CAVNYI=ANORMI*CAVNYI
         CAVNZI=ANORMI*CAVNZI
         CAVN(1,I)=CAVNXI
         CAVN(2,I)=CAVNYI
         CAVN(3,I)=CAVNZI
C
C     DETERMINE WEIGHTS
C
         DOTI=XI*CAVNXI+YI*CAVNYI+ZI*CAVNZI
         COSI=DOTI/RI
         IF(COSI.LE.ZERO) THEN
            NBAD=NBAD+1
            IF(COSI.LT.COSBAD) THEN
               IBAD=I
               COSBAD=COSI
            ENDIF
         ENDIF
         IF(COSI.GT.ZERO.AND.COSI.LE.COSTST) THEN
            NWARN=NWARN+1
            IF(COSI.LT.COSWRN) THEN
               IWARN=I
               COSWRN=COSI
            ENDIF
         ENDIF
         IF(COSI.GT.ZERO) CAVWI=SPHW(I)*RI**2/COSI
         CAVW(I)=CAVWI
C
C     DETERMINE CORRECTION FACTORS FOR DIAGONAL ELEMENTS OF S MATRIX
C     NOTE THAT THE CSDIAG FACTOR IS ALREADY PRESENT AT THIS POINT
C
         SIN2I=ONE-COSI*COSI
         CALL ELLIPK(SIN2I,EKI)
         FGAM(I)=FGAM(I)*SQRT(COSI)*(TWO/PI)*EKI
C
C     ACCUMULATE SURFACE AREA AND VOLUME
C
         SURF=SURF+CAVWI
         VOL =VOL+SPHW(I)*RI**3/THREE
C
C     ACCUMULATE CHARGE PENETRATION AS ESTIMATED FROM EXPONENTIAL FIT
C
         RHOI=RHO(I)
         DRHOI=(DRHO(1,I)*XI+DRHO(2,I)*YI+DRHO(3,I)*ZI)/RI
         ZETAI=-DRHOI/RHOI
C
C     NEGATIVE HERE BECAUSE CHARGE IS DUE TO ELECTRONS
C
         RHOEXI=-(RI**2/ZETAI+TWO*RI/ZETAI**2+TWO/ZETAI**3)*RHOI
         RHOEXT=RHOEXT+RHOEXI*SPHW(I)
C
C     SAVE EXPONENTIAL PARAMETERS ZETAI IN FIRST NCAV LOCATIONS
C     OF THE SPACE PREVIOUSLY USED BY DRHO
C
         ILOC=1+(I-1)/3
         KLOC=MOD(I,3)
         IF(KLOC.EQ.0) KLOC=3
         DRHO(KLOC,ILOC)=ZETAI
      ENDDO
C
      IF(NBAD.GT.0) THEN
         WRITE(IW,8999) NBAD,ACOS(COSBAD)*TODEG,
     1                  CAVC(1,IBAD),CAVC(2,IBAD),CAVC(3,IBAD)
         CALL ABRT
      ENDIF
C
      IF(NWARN.GT.0) THEN
         WRITE(IW,8989) NWARN,ACOS(COSWRN)*TODEG,
     1                  CAVC(1,IWARN),CAVC(2,IWARN),CAVC(3,IWARN)
         CALL FLSHBF(IW)
      ENDIF
C
      IF(SOME) THEN
         WRITE(IW,9999) ITER
         IF(OUT) THEN
            WRITE(IW,9998)
            DO I=1,NCAV
               WRITE(IW,9997) I,CAVC(1,I),CAVC(2,I),CAVC(3,I),RHO(I),
     1                          CAVN(1,I),CAVN(2,I),CAVN(3,I),CAVW(I)
            ENDDO
         ENDIF
         WRITE(IW,9996) SURF,SURF*TOANGS**2,VOL,VOL*TOANGS**3,RHOEXT
         CALL FLSHBF(IW)
      ENDIF
C
 8999 FORMAT(' ERROR: SINGLE CENTER CAVITY TREATMENT FAILS DUE TO ',I4,
     1       ' ILLEGAL NORMAL(S) OF >= 90 DEG FROM RADIAL RAY',/,
     2       ' LARGEST >= 90 DEG NORMAL = ',F8.3,' DEG AT X,Y,Z (AU) =',
     3       3F12.7)
 8989 FORMAT(' WARNING: SINGLE CENTER CAVITY TREATMENT POOR DUE TO ',I4,
     1       ' LARGE NORMAL(S) OF 87 TO 90 DEG FROM RADIAL RAY',/,
     2       ' LARGEST 87-90 DEG NORMAL = ',F8.3,' DEG AT X,Y,Z (AU) =',
     3       3F12.7)
 9999 FORMAT(/,' ISODENSITY CAVITY REACHED IN ',I3,' ITERATIONS')
 9998 FORMAT(  ' FINAL SURFACE X,Y,Z,RHO,NX,NY,NZ,WT:')
 9997 FORMAT(I4,8F16.12)
 9996 FORMAT(/,' CAVITY SURFACE AREA    =',F11.5,' A0**2 ',
     1                                  5X,F11.5,' ANG**2',/,
     2         ' CAVITY VOLUME          =',F11.5,' A0**3 ',
     3                                  5X,F11.5,' ANG**3',/,
     4         ' CHG PENET FROM EXP FIT =',F11.5)
      RETURN
      END
C*MODULE SVPCHG  *DECK ELLIPK
      SUBROUTINE ELLIPK(X,EK)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
C     EVALUATE COMPLETE ELLIPTIC INTEGRAL OF THE FIRST KIND
C     USING POLYNOMIAL APPROXIMATION GIVEN IN HASTINGS
C
      Y1=1.0D+00 - X
      Y2=Y1*Y1
      Y3=Y2*Y1
      Y4=Y2*Y2
      EK=1.38629436112D+00   +0.09666344259D+00*Y1+0.03590092383D+00*Y2+
     1   0.03742563713D+00*Y3+0.01451196212D+00*Y4-
     2  (0.5D+00             +0.12498593597D+00*Y1+0.06880248576D+00*Y2
     3  +0.03328355346D+00*Y3+0.00441787012D+00*Y4)*LOG(Y1)
C
      RETURN
      END
C*MODULE SVPCHG  *DECK SVPICK
      SUBROUTINE SVPICK(CENCAV,CAVC,CAVR,NCAV,RHOISO,DENS,
     1                  RHO,RSTART,RSPACE)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C     --- CHECK VALIDITY OF SINGLE CENTER ISODENSITY CAVITY SURFACE   --
C     --- BY WORKING OUTWARD FROM SMALL R ON AN EVENLY SPACED GRID    --
C     --- TO LOCATE INNERMOST ISODENSITY POINTS, AND COMPARING THESE  --
C     --- TO THE PREVIOUSLY DETERMINED OUTERMOST ISODENSITY POSITIONS --
C
      PARAMETER (ZERO=0.0D+00)
      LOGICAL    SOME
      LOGICAL    OUT
      LOGICAL    MORE
      LOGICAL    DBUG
      COMMON /IOFILE/ IR,IW,IP,IJK,IJKT,IDAF,NAV,IODA(950)
      DIMENSION CENCAV(3)
      DIMENSION CAVC(3,*)
      DIMENSION CAVR(3,*)
      DIMENSION DENS(*)
      DIMENSION RHO(NCAV,2)
C
      DBUG=.FALSE.
      MORE=.FALSE.
      MORE=MORE.OR.DBUG
      OUT =.FALSE.
      OUT =OUT.OR.MORE
      SOME=.FALSE.
      SOME=SOME.OR.OUT
C
C     ----- FIND RMAX = OUTERMOST PREVIOUS ISODENSITY POINT  -----
C     ----- AND  RMIN = INNERMOST PREVIOUS ISODENSITY POINT  -----
C     ----- AND NSHELL = NO. OF SPHERICAL SHELLS INSIDE RMAX -----
C
      RMAX=ZERO
      RMIN=1.0D+06
      CENX=CENCAV(1)
      CENY=CENCAV(2)
      CENZ=CENCAV(3)
      DO I=1,NCAV
         RI = SQRT((CAVC(1,I)-CENX)**2+(CAVC(2,I)-CENY)**2
     1            +(CAVC(3,I)-CENZ)**2)
         IF(RI.GT.RMAX) RMAX=RI
         IF(RI.LT.RMIN) RMIN=RI
      ENDDO
C
C     ISSUE WARNING IF FIRST SHELL APPEARS TO BE TOO LARGE
C
      IF(RSTART.GT.RMIN) THEN
         WRITE(IW,9999) RMIN
         CALL FLSHBF(IW)
      ENDIF
C
C     SET UP SHELLS AT RADII RSTART+(NS-1)*RSPACE, NS=1...NSHELL
C
      NSHELL=INT(1+(RMAX-RSTART)/RSPACE)
C
C     ----- EVALUATE DENSITIES ON INNERMOST SHELL -----
C           AND POSSIBLY ALSO AT ORIGIN
C
      RSHELL=RSTART
      DO I=1,NCAV
         DELXI = CAVC(1,I)-CENX
         DELYI = CAVC(2,I)-CENY
         DELZI = CAVC(3,I)-CENZ
         DELRI = SQRT(DELXI**2+DELYI**2+DELZI**2)
         RATIO = RSHELL/DELRI
         CAVR(1,I) = CENX+RATIO*DELXI
         CAVR(2,I) = CENY+RATIO*DELYI
         CAVR(3,I) = CENZ+RATIO*DELZI
      ENDDO
      NPTS=NCAV
      IF(RSTART.GT.RMIN) THEN
         NPTS=NCAV+1
         CAVR(1,NCAV+1) = CENX
         CAVR(2,NCAV+1) = CENY
         CAVR(3,NCAV+1) = CENZ
      ENDIF
      CALL SVP_ELDENC(NPTS,CAVR,RHO(1,1),DENS)
C
C     ----- SEE IF DENSITY AT ORIGIN IS BELOW RHOISO -----
C
      IF(RSTART.GT.RMIN) THEN
         RHOORG=RHO(1,2)
         IF(ABS(RHOORG).LT.RHOISO) THEN
            WRITE(IW,9998)
            WRITE(IW,9997) RHOORG
            CALL ABRT
         ENDIF
      ENDIF
C
C     ----- SEE IF ANY ISODENSITY POINTS LIE INSIDE 1ST SHELL -----
C
      NBAD=0
      IBAD=0
      NSBAD=0
      XBAD=0.0D+00
      YBAD=0.0D+00
      ZBAD=0.0D+00
      RBAD=0.0D+00
      RHOBAD=0.0D+00
      NS=1
      DO I=1,NCAV
         RHONEW=ABS(RHO(I,1))
         IF(RHONEW.LT.RHOISO) THEN
C
C     GET RADIUS OF PREVIOUSLY DETERMINED OUTERMOST ISODENSITY POINT
C
            RPRV=SQRT((CAVC(1,I)-CENX)**2+(CAVC(2,I)-CENY)**2
     1               +(CAVC(3,I)-CENZ)**2)
C
C     CHECK WHETHER CURRENT AND PREVIOUS ISODENSITY POINTS ARE CLOSE
C
            IF(ABS(RSHELL-RPRV).GT.RSPACE) THEN
               NBAD=NBAD+1
               IF(ABS(RSHELL-RPRV).GT.RBAD) THEN
                  IBAD=I
                  NSBAD=NS
                  XBAD=CAVR(1,IBAD)
                  YBAD=CAVR(2,IBAD)
                  ZBAD=CAVR(3,IBAD)
                  RBAD=ABS(RSHELL-RPRV)
                  RHOBAD=RHO(IBAD,1)
               ENDIF
            ENDIF
         ENDIF
      ENDDO
C
C     ----- EVALUATE DENSITIES ON REMAINING SHELLS -----
C
      DO NS=2,NSHELL
         INDNEW=2-MOD(NS,2)
         INDOLD=1+MOD(NS,2)
         RSHELL = RSTART+(NS-1)*RSPACE
         DO I=1,NCAV
            DELXI = CAVC(1,I)-CENX
            DELYI = CAVC(2,I)-CENY
            DELZI = CAVC(3,I)-CENZ
            DELRI = SQRT(DELXI**2+DELYI**2+DELZI**2)
            RATIO = RSHELL/DELRI
            CAVR(1,I) = CENX+RATIO*DELXI
            CAVR(2,I) = CENY+RATIO*DELYI
            CAVR(3,I) = CENZ+RATIO*DELZI
         ENDDO
         CALL SVP_ELDENC(NCAV,CAVR,RHO(1,INDNEW),DENS)
C
C    ----- SEE IF ANY ISODENSITY POINTS LIE BETWEEN -----
C          SHELLS NS-1 AND NS
C
         DO I=1,NCAV
            RHOOLD=ABS(RHO(I,INDOLD))
            RHONEW=ABS(RHO(I,INDNEW))
            IF( (RHOOLD.GE.RHOISO. AND. RHONEW.LT.RHOISO) .OR .
     1          (RHOOLD.LT.RHOISO. AND. RHONEW.GE.RHOISO) ) THEN
C
C     GET RADIUS OF PREVIOUSLY DETERMINED OUTERMOST ISODENSITY
C
               RPRV=SQRT((CAVC(1,I)-CENX)**2+(CAVC(2,I)-CENY)**2
     1                  +(CAVC(3,I)-CENZ)**2)
C
C     CHECK WHETHER CURRENT AND PREVIOUS ISODENSITY POINTS ARE
C
               IF(ABS(RSHELL-RPRV).GT.RSPACE) THEN
                  NBAD=NBAD+1
                  IF(ABS(RSHELL-RPRV).GT.RBAD) THEN
                     IBAD=I
                     NSBAD=NS
                     XBAD=CAVR(1,IBAD)
                     YBAD=CAVR(2,IBAD)
                     ZBAD=CAVR(3,IBAD)
                     RBAD=ABS(RSHELL-RPRV)
                     RHOBAD=RHO(IBAD,INDNEW)
                  ENDIF
               ENDIF
            ENDIF
         RHO(I,INDOLD)=RHO(I,INDNEW)
         ENDDO
      ENDDO
C
C     ----- EXIT IF ANY BAD POINTS FOUND -----
C
      IF(NBAD.GT.0) THEN
         I=IBAD
         WRITE(IW,9996) NBAD
         WRITE(IW,9995) NSBAD,I,RBAD,XBAD,YBAD,ZBAD,RHOBAD,
     1                  CAVC(1,I),CAVC(2,I),CAVC(3,I),RHOISO
         CALL ABRT
      ENDIF
C
 9999 FORMAT(' SINGLE CENTER EXPANSION VALIDITY CHECK WARNING:',
     1       ' 1ST SHELL IS .GT. RMIN=',F13.7)
 9998 FORMAT(' SINGLE CENTER EXPANSION VALIDITY CHECK',
     1       ' INDICATES FAILURE AT ORIGIN. STOP.')
 9997 FORMAT(' POINT AT ORIGIN HAS SMALL RHO=',D13.5)
 9996 FORMAT(' SINGLE CENTER EXPANSION VALIDITY CHECK',
     1         ' INDICATES FAILURE AT ',I5,' POINTS. STOP.')
 9995 FORMAT(' LARGEST FAILURE WAS FOUND FOR SHELL',I5,
     1       ' ON RAY',I5,':',/,' INNER ISODENSITY POINT IS MORE THAN',
     2         F13.7,' AU FROM OUTER ISODENSITY POINT',/,
     3       ' APPROX INNER ISODENSITY POINT AT',3F13.7,
     4       ' AU HAS RHO=',D13.5,/,
     5       ' ACTUAL OUTER ISODENSITY POINT AT',3F13.7,
     6       ' AU HAS RHO=',D13.5)
C
      RETURN
      END
C*MODULE SVPCHG  *DECK SVPQ0
      SUBROUTINE SVPQ0(IADDL,ILAST,DIEL,NCAV,IOPPRD,CAVC,CAVW,CAVN,
     1                 NSTAGE,FGAM,  LINEQ,CVGLIN,ELP,    Q)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C     ----- SET UP AND SOLVE EQUATIONS FOR SS(V)PE SURFACE CHARGES -----
C
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00, TWO=2.0D+00, FOUR=4.0D+00)
      LOGICAL     DBUG
      LOGICAL     MORE
      LOGICAL     OUT
      LOGICAL     SOME
      LOGICAL     SYMMA,INCORA,INCORT
C
      COMMON /FMCOM / X(1)
      COMMON /IOFILE/ IR,IW,IP,IJK,IJKT,IDAF,NAV,IODA(950)
      COMMON/SVPDBG/IDBG
      DIMENSION   CAVC(3,*),CAVW(*),CAVN(3,*)
      DIMENSION   FGAM(*),ELP(*),Q(*)
      DATA KEYBLK /4H    /
      DATA KEYFST /4HFRST/
      DATA IFIRST /4HFRST/
      SAVE IFIRST
C
      PI=FOUR*ATAN(ONE)
      TWOPI=TWO*PI
      TWOPIM=ONE/TWOPI
      FAC1=(DIEL-ONE)/(DIEL+ONE)
C
      DBUG=.FALSE.
      DBUG=DBUG.OR.IDBG.GE.4
      MORE=.FALSE.
      MORE=MORE.OR.DBUG.OR.IDBG.GE.3
      OUT =.FALSE.
      OUT =OUT.OR.MORE.OR.IDBG.GE.2
      SOME=.FALSE.
      SOME=SOME.OR.OUT.OR.IDBG.GE.1
C
C     ----- DETERMINE SYMMETRY OF SVP MATRIX A -----
C
      IF(IOPPRD.EQ.0) SYMMA=.TRUE.
      IF(IOPPRD.NE.0) SYMMA=.FALSE.
C
C     ----- SET POINTERS FOR PARTITIONING OF CORE -----
C
C     -B-   AT X(I10) (NCAV)
C     -A-   AT X(I20) (NCAV**2 OR NCAV)
C     -T-   AT X(I30) (NCAV**2 OR NCAV) (T IS A+ OR SCR OR BOTH)
C     -SCR- AT X(I40) (NCAV)
C
      INCORA=.TRUE.
      INCORT=.TRUE.
      IF(INCORA.AND.INCORT) THEN
         I10=IADDL
         I20=I10+NCAV
         I30=I20+NCAV**2
         I40=I30+NCAV**2
         I50=I40+NCAV
C
C     ----- ADD ENOUGH FOR SVPEQU USE AS WELL -----
C
         I60=I50+4*NCAV
         LAST=I60-1
         IF(LAST.LE.ILAST) THEN
            IF(NSTAGE.EQ.0) THEN
               IF(IOPPRD.LE.0.OR.IOPPRD.GE.3) THEN
                  NSTAGE=1
               ELSEIF(IOPPRD.EQ.1.OR.IOPPRD.EQ.2) THEN
                  NSTAGE=2
                  IF(IFIRST.EQ.KEYFST)
     1               WRITE(IW,*) 'USE NSTAGE=2 STRATEGY IN SVPQ0'
               ENDIF
            ENDIF
         ENDIF
         IF(LAST.GT.ILAST) THEN
            INCORT=.FALSE.
            IF(NSTAGE.EQ.0) THEN
               IF(IOPPRD.LE.0.OR.IOPPRD.GE.3) THEN
                  NSTAGE=1
               ELSEIF(IOPPRD.EQ.1.OR.IOPPRD.EQ.2) THEN
                  NSTAGE=2
                  IF(IFIRST.EQ.KEYFST)
     1               WRITE(IW,*) 'USE NSTAGE=2 STRATEGY IN SVPQ0'
               ENDIF
            ENDIF
            IF(NSTAGE.EQ.1.AND.IFIRST.EQ.KEYFST) THEN
               NEED=LAST-ILAST
               WRITE(IW,9999) NEED
            ENDIF
         ENDIF
      ENDIF
      IF(INCORA.AND..NOT.INCORT) THEN
         I10=IADDL
         I20=I10+NCAV
         I30=I20+NCAV**2
         I40=I30+NCAV
         I50=I40+NCAV
C
C     ----- ADD ENOUGH FOR SVPEQU USE AS WELL -----
C
         I60=I50+4*NCAV
         LAST=I60-1
         IF(LAST.GT.ILAST) THEN
            INCORA=.FALSE.
            IF(IFIRST.EQ.KEYFST.AND.LINEQ.LT.2) THEN
               LINEQ=2
               NEED=LAST-ILAST
               WRITE(IW,9998) NEED
               WRITE(IW,*) 'FORCE OUT OF CORE SOLUTION WITH LINEQ=2'
               IF(NSTAGE.EQ.0) THEN
                  WRITE(IW,*) 'AND ALSO CHANGE TO NSTAGE=2 STRATEGY'
               ENDIF
            ENDIF
            IF(NSTAGE.EQ.0) NSTAGE=2
         ENDIF
      ENDIF
      IF(.NOT.INCORA.AND..NOT.INCORT) THEN
         I10=IADDL
         I20=I10+NCAV
         I30=I20+NCAV
         I40=I30+NCAV
         I50=I40+NCAV
C
C     ----- ADD ENOUGH FOR SVPEQU USE AS WELL -----
C
         I60=I50+4*NCAV
         LAST=I60-1
         IF(LAST.GT.ILAST) THEN
            NEED=LAST-ILAST
            WRITE(IW,*) 'NOT ENOUGH MEMORY TO DO SVP CALCULATION.'
            WRITE(IW,*) 'ADDITIONAL WORDS NEEDED =',NEED
            CALL ABRT
         ENDIF
      ENDIF
C
C     ----- FORM INHOMOGENEITY B -----
C
      DO I=1,NCAV
         XI=CAVC(1,I)
         YI=CAVC(2,I)
         ZI=CAVC(3,I)
         DWPI=ZERO
         DIIWI=ZERO
         DO J=1,NCAV
            IF(I.NE.J) THEN
               XIJ=XI-CAVC(1,J)
               YIJ=YI-CAVC(2,J)
               ZIJ=ZI-CAVC(3,J)
               WJ=CAVW(J)
               RRIJ=XIJ**2+YIJ**2+ZIJ**2
               RRIJ32=ONE/(RRIJ*SQRT(RRIJ))
               DOTJ=CAVN(1,J)*XIJ+CAVN(2,J)*YIJ+CAVN(3,J)*ZIJ
               DIJ=DOTJ*RRIJ32
               DIJWJ=DIJ*WJ
               DIIWI=DIIWI+DIJWJ
               DWPI=DWPI+DIJWJ*ELP(J)
            ENDIF
         ENDDO
         DIIWI=-(TWOPI+DIIWI)
         DWPI=DWPI+DIIWI*ELP(I)
         X(I+I10-1)=-FAC1*(ELP(I)-TWOPIM*DWPI)
      ENDDO
C
      IF(NSTAGE.LE.1) THEN
C
C     ----- FORM SYSTEM MATRIX A FOR SINGLE STAGE SOLUTION -----
C
         IF(INCORA.AND.INCORT) THEN
            CALL SVPTII(DIEL,NCAV,IOPPRD,CAVC,CAVW,CAVN,FGAM,
     1                  X(I20),X(I30),X(I40))
            IF(IOPPRD.GT.0.AND.LINEQ.EQ.1) THEN
               DO I=1,NCAV
                  DO J=1,NCAV
                     X(J+(I-1)*NCAV+I30-1)=X(I+(J-1)*NCAV+I20-1)
                  ENDDO
               ENDDO
            ENDIF
         ELSEIF(INCORA.AND..NOT.INCORT) THEN
            CALL SVPTIO(DIEL,NCAV,IOPPRD,CAVC,CAVW,CAVN,FGAM,
     1                  X(I20),X(I30))
         ELSEIF(.NOT.INCORA.AND..NOT.INCORT) THEN
            CALL SVPTOO(DIEL,NCAV,IOPPRD,CAVC,CAVW,CAVN,FGAM,
     1                  X(I20),X(I30),X(I40),X(I50))
         ENDIF
C
C     ----- SOLVE SYSTEM EQUATION AND RETURN -----
C
         IADDL=I50
         IF(IOPPRD.EQ.0) SYMMA=.TRUE.
         IF(IOPPRD.NE.0) SYMMA=.FALSE.
         CALL SVPEQU(IADDL,ILAST,LINEQ,CVGLIN,NCAV,SYMMA,INCORA,INCORT,
     1               X(I10),X(I20),X(I30),Q)
         IFIRST=KEYBLK
         RETURN
C
      ELSEIF(NSTAGE.EQ.2) THEN
C
C     --- FORM SYSTEM MATRIX A FOR FIRST STAGE OF TWO STAGE SOLUTION:
C     --- IF IOPPRD=1 THEN APPLY DIELECTRIC-INDEPENDENT OPERATOR FIRST
C     --- IF IOPPRD=2 THEN APPLY DIELECTRIC-DEPENDENT OPERATOR FIRST
C
         IF(IOPPRD.EQ.1) THEN
            SYMMA=.TRUE.
            IF(INCORA) THEN
               CALL SVPSI(NCAV,CAVC,CAVW,FGAM,X(I20))
            ELSEIF(.NOT.INCORA) THEN
               CALL SVPSO(NCAV,CAVC,CAVW,FGAM,X(I20))
            ENDIF
         ELSEIF(IOPPRD.EQ.2) THEN
            SYMMA=.FALSE.
            IF(INCORA) THEN
               CALL SVPGI(DIEL,NCAV,CAVC,CAVW,CAVN,X(I20))
               IF(INCORT.AND.LINEQ.EQ.1) THEN
                  DO I=1,NCAV
                     DO J=1,NCAV
                        X(J+(I-1)*NCAV+I30-1)=X(I+(J-1)*NCAV+I20-1)
                     ENDDO
                  ENDDO
               ENDIF
            ELSEIF(.NOT.INCORA) THEN
               CALL SVPGO(DIEL,NCAV,CAVC,CAVW,CAVN,X(I20),X(I30))
            ENDIF
         ENDIF
C
C     ----- SOLVE FIRST STAGE -----
C
         IADDL=I50
         CALL SVPEQU(IADDL,ILAST,LINEQ,CVGLIN,NCAV,SYMMA,INCORA,INCORT,
     1          X(I10),X(I20),X(I30),X(I40))
         DO I=1,NCAV
            X(I+I40-1)=X(I+I40-1)/CAVW(I)
         ENDDO
C
C     --- FORM SYSTEM MATRIX A FOR SECOND STAGE OF TWO STAGE SOLUTION:
C     --- IF IOPPRD=1 THEN APPLY DIELECTRIC-DEPENDENT OPERATOR SECOND
C     --- IF IOPPRD=2 THEN APPLY DIELECTRIC-INDEPENDENT OPERATOR SECOND
C
         IF(IOPPRD.EQ.1) THEN
            SYMMA=.FALSE.
            IF(INCORA) THEN
               CALL SVPFI(DIEL,NCAV,CAVC,CAVW,CAVN,X(I20))
               IF(INCORT.AND.LINEQ.EQ.1) THEN
                  DO I=1,NCAV
                     DO J=1,NCAV
                        X(J+(I-1)*NCAV+I30-1)=X(I+(J-1)*NCAV+I20-1)
                     ENDDO
                  ENDDO
               ENDIF
            ELSEIF(.NOT.INCORA) THEN
               CALL SVPFO(DIEL,NCAV,CAVC,CAVW,CAVN,X(I20),X(I30))
            ENDIF
         ELSEIF(IOPPRD.EQ.2) THEN
            SYMMA=.TRUE.
            IF(INCORA) THEN
               CALL SVPSI(NCAV,CAVC,CAVW,FGAM,X(I20))
            ELSEIF(.NOT.INCORA) THEN
               CALL SVPSO(NCAV,CAVC,CAVW,FGAM,X(I20))
            ENDIF
         ENDIF
C
C     ----- SOLVE SECOND STAGE AND RETURN -----
C
         IADDL=I50
         CALL SVPEQU(IADDL,ILAST,LINEQ,CVGLIN,NCAV,SYMMA,INCORA,INCORT,
     1               X(I40),X(I20),X(I30),Q)
         IFIRST=KEYBLK
         RETURN
      ENDIF
C
      IFIRST=KEYBLK
      RETURN
 9999 FORMAT(' HINT: SVPQ0 EFFICIENCY WOULD IMPROVE BY PROVIDING ',I10/
     1       ' MORE WORDS OF MEMORY TO HOLD A SECOND NCAV*NCAV MATRIX',
     2       ' IN CORE')
 9998 FORMAT(' HINT: SVPQ0 EFFICIENCY WOULD IMPROVE BY PROVIDING ',I10/
     1       ' MORE WORDS OF MEMORY TO HOLD NCAV*NCAV SYSTEM MATRIX',
     2       ' IN CORE')
      END
C
C*MODULE SVPCHG  *DECK SVPQV
      SUBROUTINE SVPQV(NCAV,CAVC,CAVW,CAVN,DIEL,ELF,QSSVPE,QSVPE)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C     ----- GET SVPE SURFACE CHARGES FROM SS(V)PE SURFACE CHARGES -----
C
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00, TWO=2.0D+00, FOUR=4.0D+00)
      LOGICAL     DBUG
      LOGICAL     MORE
      LOGICAL     OUT
      LOGICAL     SOME
C
      COMMON/SVPDBG/IDBG
      DIMENSION   CAVC(3,*),CAVW(*),CAVN(3,*)
      DIMENSION   ELF(*),QSSVPE(*),QSVPE(*)
C
      PI=FOUR*ATAN(ONE)
      TWOPI=TWO*PI
      TWOPIM=ONE/TWOPI
      FAC1=(DIEL-ONE)/(TWO*DIEL)
C
      DBUG=.FALSE.
      DBUG=DBUG.OR.IDBG.GE.4
      MORE=.FALSE.
      MORE=MORE.OR.DBUG.OR.IDBG.GE.3
      OUT =.FALSE.
      OUT =OUT.OR.MORE.OR.IDBG.GE.2
      SOME=.FALSE.
      SOME=SOME.OR.OUT.OR.IDBG.GE.1
C
      DO I=1,NCAV
         QSSVPE(I)=QSSVPE(I)/CAVW(I)
      ENDDO
C
      DO I=1,NCAV
         XI=CAVC(1,I)
         YI=CAVC(2,I)
         ZI=CAVC(3,I)
         CAVNXI=CAVN(1,I)
         CAVNYI=CAVN(2,I)
         CAVNZI=CAVN(3,I)
         DSWQI=ZERO
         DSIIWI=ZERO
         DO J=1,NCAV
            IF(I.NE.J) THEN
               XJI=CAVC(1,J)-XI
               YJI=CAVC(2,J)-YI
               ZJI=CAVC(3,J)-ZI
               CAVNXJ=CAVN(1,J)
               CAVNYJ=CAVN(2,J)
               CAVNZJ=CAVN(3,J)
               WJ=CAVW(J)
               RRJI=XJI**2+YJI**2+ZJI**2
               RRJI32=ONE/(RRJI*SQRT(RRJI))
               DOTI=-(CAVNXJ*XJI+CAVNYJ*YJI+CAVNZJ*ZJI)
               DOTJ=  CAVNXI*XJI+CAVNYI*YJI+CAVNZI*ZJI
               DSIJWJ=DOTJ*RRJI32*WJ
               DSIIWI=DOTI*RRJI32*WJ+DSIIWI
               DSWQI=DSWQI+DSIJWJ*QSSVPE(J)
            ENDIF
         ENDDO
         DSIIWI=-(TWOPI+DSIIWI)
         DSWQI=DSWQI+DSIIWI*QSSVPE(I)
         QSVPE(I)=FAC1*(QSSVPE(I)+TWOPIM*DSWQI-TWOPIM*ELF(I))
      ENDDO
C
      DO I=1,NCAV
         QSSVPE(I)=QSSVPE(I)*CAVW(I)
         QSVPE(I) = QSVPE(I)*CAVW(I)
      ENDDO
C
      RETURN
      END
C
C*MODULE SVPCHG  *DECK SVPS1
      SUBROUTINE SVPQ1(IADDL,ILAST,DIEL,NCAV,       CAVC,CAVW,
     1                       FGAM,  LINEQ,CVGLIN,ELP,    Q)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C     ----- SET UP AND SOLVE EQUATIONS FOR COSMO SURFACE CHARGES -----
C
      PARAMETER (ONE=1.0D+00)
      LOGICAL     DBUG
      LOGICAL     MORE
      LOGICAL     OUT
      LOGICAL     SOME
      LOGICAL     SYMMA,INCORA,INCORT
C
      COMMON /FMCOM / X(1)
      COMMON /IOFILE/ IR,IW,IP,IJK,IJKT,IDAF,NAV,IODA(950)
      COMMON/SVPDBG/IDBG
      DIMENSION   CAVC(3,*),CAVW(*)
      DIMENSION   FGAM(*),ELP(*),Q(*)
      DATA KEYBLK /4H    /
      DATA KEYFST /4HFRST/
      DATA IFIRST /4HFRST/
      SAVE IFIRST
C
      FAC4  = (DIEL-ONE)/DIEL
C
      DBUG=.FALSE.
      DBUG=DBUG.OR.IDBG.GE.4
      MORE=.FALSE.
      MORE=MORE.OR.DBUG.OR.IDBG.GE.3
      OUT =.FALSE.
      OUT =OUT.OR.MORE.OR.IDBG.GE.2
      SOME=.FALSE.
      SOME=SOME.OR.OUT.OR.IDBG.GE.1
C
C     ----- DETERMINE SYMMETRY OF MATRIX A -----
C
      SYMMA=.TRUE.
C
C     ----- SET POINTERS FOR PARTITIONING OF CORE -----
C
C     -B-   AT X(I10) (NCAV)
C     -A-   AT X(I20) (NCAV**2 OR NCAV)
C
      INCORA=.TRUE.
      INCORT=.FALSE.
      IF(INCORA) THEN
         I10=IADDL
         I20=I10+NCAV
         I30=I20+NCAV**2
C
C     ADD ENOUGH FOR SVPEQU USE AS WELL
C
         I40=I30+4*NCAV
         LAST=I40-1
         IF(LAST.GT.ILAST) THEN
            INCORA=.FALSE.
            IF(IFIRST.EQ.KEYFST.AND.LINEQ.LT.2) THEN
               LINEQ=2
               NEED=LAST-ILAST
               WRITE(IW,9999) NEED
            ENDIF
         ENDIF
      ENDIF
      IF(.NOT.INCORA) THEN
         I10=IADDL
         I20=I10+NCAV
         I30=I20+NCAV
C
C     ADD ENOUGH FOR SVPEQU USE AS WELL
C
         I40=I30+4*NCAV
         LAST=I40-1
         IF(LAST.GT.ILAST) THEN
            NEED=LAST-ILAST
            WRITE(IW,*) 'NOT ENOUGH MEMORY TO DO SVP CALCULATION.'
            WRITE(IW,*) 'ADDITIONAL WORDS NEEDED =',NEED
            CALL ABRT
         ENDIF
      ENDIF
C
      IF(OUT) THEN
         WRITE(IW,*) 'IN -SVPQ1- FOR -COSMO- TYPE ... '
         WRITE(IW,*) '-INCORA- AND -INCORT- = ',INCORA,INCORT
         WRITE(IW,*) '-SYMMA-               = ',SYMMA
         WRITE(IW,*) '-NCAV-                = ',NCAV
         WRITE(IW,*) '-CAVC-'
         DO ICAV=1,NCAV
            WRITE(IW,9998) ICAV,(CAVC(I,ICAV),I=1,3)
         ENDDO
         WRITE(IW,*) '-CAVW-'
         DO ICAV=1,NCAV
            WRITE(IW,9998) ICAV, CAVW(  ICAV)
         ENDDO
         WRITE(IW,*) '-FGAM-'
         DO ICAV=1,NCAV
            WRITE(IW,9998) ICAV, FGAM(  ICAV)
         ENDDO
      ENDIF
C
C     ----- FORM INHOMOGENEITY B -----
C
      DO I=1,NCAV
         X(I+I10-1)=-FAC4*ELP(I)
      ENDDO
C
C     ----- FORM SYSTEM MATRIX A -----
C
      IF(INCORA) THEN
         CALL SVPSI(NCAV,CAVC,CAVW,FGAM,X(I20))
      ELSEIF(.NOT.INCORA) THEN
         CALL SVPSO(NCAV,CAVC,CAVW,FGAM,X(I20))
      ENDIF
C
C     ----- SOLVE SYSTEM EQUATION AND RETURN -----
C
      IADDL=I30
      CALL SVPEQU(IADDL,ILAST,LINEQ,CVGLIN,NCAV,SYMMA,INCORA,INCORT,
     1            X(I10),X(I20),X(I20),Q)
C
      IFIRST=KEYBLK
      RETURN
 9999 FORMAT('NOT ENOUGH MEMORY IN SVPQ1 TO HOLD SYSTEM MATRIX. ',/,
     1       'ADDITIONAL WORDS NEEDED =',I12,'. FORCE OUT OF CORE ',
     2       'SOLUTION WITH LINEQ=2')
 9998 FORMAT(I10,3F15.10)
      END
C*MODULE SVPCHG  *DECK SVPQ2
      SUBROUTINE SVPQ2(IADDL,ILAST,DIEL,NCAV,       CAVC,CAVW,CAVN,
     1                 IRENRM,FGAM,  LINEQ,CVGLIN,    ELF,Q)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C     ----- SET UP AND SOLVE EQUATIONS FOR SPE SURFACE CHARGES -----
C
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00, TWO=2.0D+00, FOUR=4.0D+00)
      PARAMETER  (MXATM=2000)
      LOGICAL     DBUG
      LOGICAL     MORE
      LOGICAL     OUT
      LOGICAL     SOME
      LOGICAL     SYMMA,INCORA,INCORT
C
      COMMON /FMCOM / X(1)
      COMMON /IOFILE/ IR,IW,IP,IJK,IJKT,IDAF,NAV,IODA(950)
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON/SVPDBG/IDBG
      DIMENSION   CAVC(3,*),CAVW(*),CAVN(3,*)
      DIMENSION   FGAM(*),ELF(*),Q(*)
      DATA KEYBLK /4H    /
      DATA KEYFST /4HFRST/
      DATA IFIRST /4HFRST/
      SAVE IFIRST
C
      PI=FOUR*ATAN(ONE)
      TWOPI=TWO*PI
      TWOPIM=ONE/TWOPI
      FAC1=(DIEL-ONE)/(DIEL+ONE)
      FAC2=FAC1*TWOPIM
C
      DBUG=.FALSE.
      DBUG=DBUG.OR.IDBG.GE.4
      MORE=.FALSE.
      MORE=MORE.OR.DBUG.OR.IDBG.GE.3
      OUT =.FALSE.
      OUT =OUT.OR.MORE.OR.IDBG.GE.2
      SOME=.FALSE.
      SOME=SOME.OR.OUT.OR.IDBG.GE.1
C
C     ----- DETERMINE SYMMETRY OF MATRIX A -----
C
      SYMMA=.FALSE.
C
C     ----- SET POINTERS FOR PARTITIONING OF CORE -----
C
C     -B-   AT X(I10) (NCAV)
C     -A-   AT X(I20) (NCAV**2 OR NCAV)
C     -AT-  AT X(I30) (NCAV**2 OR NCAV)
C
      INCORA=.TRUE.
      INCORT=.TRUE.
      IF(INCORA.AND.INCORT) THEN
         I10=IADDL
         I20=I10+NCAV
         I30=I20+NCAV**2
         I40=I30+NCAV**2
C
C     ADD ENOUGH FOR SVPEQU USE AS WELL
C
         I50=I40+4*NCAV
         LAST=I50-1
         IF(LAST.GT.ILAST) THEN
            INCORT=.FALSE.
            IF(LINEQ.EQ.1.AND.IFIRST.EQ.KEYFST) THEN
               NEED=LAST-ILAST
               WRITE(IW,9999) NEED
            ENDIF
         ENDIF
      ENDIF
      IF(INCORA.AND..NOT.INCORT) THEN
         I10=IADDL
         I20=I10+NCAV
         I30=I20+NCAV**2
         I40=I30+NCAV
C
C     ADD ENOUGH FOR SVPEQU USE AS WELL
C
         I50=I40+4*NCAV
         LAST=I50-1
         IF(LAST.GT.ILAST) THEN
            INCORA=.FALSE.
            IF(IFIRST.EQ.KEYFST.AND.LINEQ.LT.2) THEN
               LINEQ=2
               NEED=LAST-ILAST
               WRITE(IW,9998) NEED
               WRITE(IW,*) 'FORCE OUT OF CORE SOLUTION WITH LINEQ=2'
            ENDIF
         ENDIF
      ENDIF
      IF(.NOT.INCORA.AND..NOT.INCORT) THEN
         I10=IADDL
         I20=I10+NCAV
         I30=I20+NCAV
         I40=I30+NCAV
C
C     ADD ENOUGH FOR SVPEQU USE AS WELL
C
         I50=I40+4*NCAV
         LAST=I50-1
         IF(LAST.GT.ILAST) THEN
            NEED=LAST-ILAST
            WRITE(IW,*) 'NOT ENOUGH MEMORY TO DO SVP CALCULATION.'
            WRITE(IW,*) 'ADDITIONAL WORDS NEEDED =',NEED
            CALL ABRT
         ENDIF
      ENDIF
C
C     ----- FORM INHOMOGENEITY B AND ITS AVERAGE VALUE -----
C
      AREA=ZERO
      FLDAVG=ZERO
      DO I=1,NCAV
         X(I+I10-1)=-FAC2*ELF(I)
         AREA=AREA+CAVW(I)
         FLDAVG=FLDAVG+X(I+I10-1)*CAVW(I)
      ENDDO
      FLDAVG=FLDAVG/AREA
C
C        ----- FORM SYSTEM MATRIX A -----
C
      IF(INCORA) THEN
         CALL SVPFI(DIEL,NCAV,CAVC,CAVW,CAVN,X(I20))
         IF(INCORT.AND.LINEQ.EQ.1) THEN
            DO I=1,NCAV
               DO J=1,NCAV
                  X(I+(J-1)*NCAV+I30-1)=X(J+(I-1)*NCAV+I20-1)
               ENDDO
            ENDDO
         ENDIF
      ELSEIF(.NOT.INCORA) THEN
         CALL SVPFO(DIEL,NCAV,CAVC,CAVW,CAVN,X(I20),X(I30))
      ENDIF
C
C     ----- SOLVE SYSTEM EQUATION AND DETERMINE CHARGE PENETRATION -----
C
      IADDL=I40
      CALL SVPEQU(IADDL,ILAST,LINEQ,CVGLIN,NCAV,SYMMA,INCORA,INCORT,
     1            X(I10),X(I20),X(I30),Q)
      CHGBAR=ZERO
      DO I=1,NCAV
         CHGBAR=CHGBAR+Q(I)
      ENDDO
C
      IF(IRENRM.EQ.1) THEN
C
C        ----- CHARGE RENORMALIZATION BY EQUIPOTENTIAL METHOD -----
C
         DO I=1,NCAV
            X(I+I10-1)=FLDAVG
         ENDDO
         SYMMA=.TRUE.
         IF(INCORA) THEN
            CALL SVPSI(NCAV,CAVC,CAVW,FGAM,X(I20))
         ELSEIF(.NOT.INCORA) THEN
            CALL SVPSO(NCAV,CAVC,CAVW,FGAM,X(I20))
         ENDIF
C
C        EQUIPOTENTIAL MATRIX IS SYMMETRIC, SO X(I30) IS NOT NEEDED FOR
C        AND IS AVAILABLE TO HOLD THE RENORMALIZATION CHARGES
C
         IADDL=I40
         CALL SVPEQU(IADDL,ILAST,LINEQ,CVGLIN,NCAV,SYMMA,INCORA,INCORT,
     1               X(I10),X(I20),X(I30),X(I30))
         RENBAR=ZERO
         DO I=1,NCAV
            RENBAR=RENBAR+X(I+I30-1)
         ENDDO
         SCALQ=-(ICH*(DIEL-ONE))/DIEL
         RENORM=(SCALQ-CHGBAR)/RENBAR
         DO I=1,NCAV
            Q(I)=Q(I)+RENORM*X(I+I30-1)
         ENDDO
      ENDIF
C
      IFIRST=KEYBLK
      RETURN
 9999 FORMAT(' HINT: SVPQ2 EFFICIENCY WOULD IMPROVE BY PROVIDING ',I10/
     1       ' MORE WORDS OF MEMORY TO HOLD A SECOND NCAV*NCAV MATRIX',
     2       ' IN CORE')
 9998 FORMAT(' HINT: SVPQ2 EFFICIENCY WOULD IMPROVE BY PROVIDING ',I10/
     1       ' MORE WORDS OF MEMORY TO HOLD NCAV*NCAV SYSTEM MATRIX',
     2       ' IN CORE')
      END
C*MODULE SVPCHG  *DECK SVPQ3
      SUBROUTINE SVPQ3(IADDL,ILAST,DIEL,NCAV,IOPPRD,CAVC,CAVW,CAVN,
     1                 NSTAGE,FGAM,  LINEQ,CVGLIN,ELP,ELF,Q)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C     ----- SET UP AND SOLVE EQUATIONS FOR IEF SURFACE CHARGES -----
C
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00, TWO=2.0D+00, FOUR=4.0D+00)
      LOGICAL     DBUG
      LOGICAL     MORE
      LOGICAL     OUT
      LOGICAL     SOME
      LOGICAL     SYMMA,INCORA,INCORT
C
      COMMON /FMCOM / X(1)
      COMMON /IOFILE/ IR,IW,IP,IJK,IJKT,IDAF,NAV,IODA(950)
      COMMON/SVPDBG/IDBG
      DIMENSION   CAVC(3,*),CAVW(*),CAVN(3,*)
      DIMENSION   FGAM(*),ELP(*),ELF(*),Q(*)
      DATA KEYBLK /4H    /
      DATA KEYFST /4HFRST/
      DATA IFIRST /4HFRST/
      SAVE IFIRST
C
      PI=FOUR*ATAN(ONE)
      TWOPI=TWO*PI
      TWOPIM=ONE/TWOPI
      TRTPI=TWO*SQRT(PI)
      FAC7=DIEL/(DIEL+ONE)
      FAC9=(ONE/(DIEL+ONE))*TWOPIM
C
      DBUG=.FALSE.
      DBUG=DBUG.OR.IDBG.GE.4
      MORE=.FALSE.
      MORE=MORE.OR.DBUG.OR.IDBG.GE.3
      OUT =.FALSE.
      OUT =OUT.OR.MORE.OR.IDBG.GE.2
      SOME=.FALSE.
      SOME=SOME.OR.OUT.OR.IDBG.GE.1
C
C     ----- DETERMINE SYMMETRY OF SVP MATRIX A -----
C
      IF(IOPPRD.EQ.0) SYMMA=.TRUE.
      IF(IOPPRD.NE.0) SYMMA=.FALSE.
C
C     ----- SET POINTERS FOR PARTITIONING OF CORE -----
C
C     -B-   AT X(I10) (NCAV)
C     -A-   AT X(I20) (NCAV**2 OR NCAV)
C     -T-   AT X(I30) (NCAV**2 OR NCAV) (T IS A+ OR SCR OR BOTH)
C     -SCR- AT X(I40) (NCAV)
C
      INCORA=.TRUE.
      INCORT=.TRUE.
      IF(INCORA.AND.INCORT) THEN
         I10=IADDL
         I20=I10+NCAV
         I30=I20+NCAV**2
         I40=I30+NCAV**2
         I50=I40+NCAV
C
C     ADD ENOUGH FOR SVPEQU USE AS WELL
C
         I60=I50+4*NCAV
         LAST=I60-1
         IF(LAST.LE.ILAST) THEN
            IF(NSTAGE.EQ.0) THEN
               IF(IOPPRD.LE.0.OR.IOPPRD.GE.3) THEN
                  NSTAGE=1
               ELSEIF(IOPPRD.EQ.1.OR.IOPPRD.EQ.2) THEN
                  NSTAGE=2
                  IF(IFIRST.EQ.KEYFST)
     1               WRITE(IW,*) 'USE NSTAGE=2 STRATEGY IN SVPQ3'
               ENDIF
            ENDIF
         ENDIF
         IF(LAST.GT.ILAST) THEN
            INCORT=.FALSE.
            IF(NSTAGE.EQ.0) THEN
               IF(IOPPRD.LE.0.OR.IOPPRD.GE.3) THEN
                  NSTAGE=1
               ELSEIF(IOPPRD.EQ.1.OR.IOPPRD.EQ.2) THEN
                  NSTAGE=2
                  IF(IFIRST.EQ.KEYFST)
     1               WRITE(IW,*) 'USE NSTAGE=2 STRATEGY IN SVPQ3'
               ENDIF
            ENDIF
            IF(NSTAGE.EQ.1.AND.IFIRST.EQ.KEYFST) THEN
               NEED=LAST-ILAST
               WRITE(IW,9999) NEED
            ENDIF
         ENDIF
      ENDIF
      IF(INCORA.AND..NOT.INCORT) THEN
         I10=IADDL
         I20=I10+NCAV
         I30=I20+NCAV**2
         I40=I30+NCAV
         I50=I40+NCAV
C
C     ADD ENOUGH FOR SVPEQU USE AS WELL
C
         I60=I50+4*NCAV
         LAST=I60-1
         IF(LAST.GT.ILAST) THEN
            INCORA=.FALSE.
            IF(IFIRST.EQ.KEYFST.AND.LINEQ.LT.2) THEN
               LINEQ=2
               NEED=LAST-ILAST
               WRITE(IW,9998) NEED
               WRITE(IW,*) 'FORCE OUT OF CORE SOLUTION WITH LINEQ=2'
               IF(NSTAGE.EQ.0) THEN
                  WRITE(IW,*) 'AND ALSO CHANGE TO NSTAGE=2 STRATEGY'
               ENDIF
            ENDIF
            IF(NSTAGE.EQ.0) NSTAGE=2
         ENDIF
      ENDIF
      IF(.NOT.INCORA.AND..NOT.INCORT) THEN
         I10=IADDL
         I20=I10+NCAV
         I30=I20+NCAV
         I40=I30+NCAV
         I50=I40+NCAV
C
C     ADD ENOUGH FOR SVPEQU USE AS WELL
C
         I60=I50+4*NCAV
         LAST=I60-1
         IF(LAST.GT.ILAST) THEN
            NEED=LAST-ILAST
            WRITE(IW,*) 'NOT ENOUGH MEMORY TO DO SVP CALCULATION.'
            WRITE(IW,*) 'ADDITIONAL WORDS NEEDED =',NEED
            CALL ABRT
         ENDIF
      ENDIF
C
C     ----- FORM INHOMOGENEITY B -----
C
      DO I=1,NCAV
         XI=CAVC(1,I)
         YI=CAVC(2,I)
         ZI=CAVC(3,I)
         WI=CAVW(I)
         DWPI=ZERO
         SWFI=ZERO
         DIIWI=ZERO
         DO J=1,NCAV
            IF(I.NE.J) THEN
               XIJ=XI-CAVC(1,J)
               YIJ=YI-CAVC(2,J)
               ZIJ=ZI-CAVC(3,J)
               WJ=CAVW(J)
               RRIJ=XIJ**2+YIJ**2+ZIJ**2
               SIJ=ONE/SQRT(RRIJ)
               SWFI=SWFI+SIJ*WJ*ELF(J)
               DOTJ=CAVN(1,J)*XIJ+CAVN(2,J)*YIJ+CAVN(3,J)*ZIJ
               DIJ=DOTJ*SIJ**3
               DIJWJ=DIJ*WJ
               DIIWI=DIIWI+DIJWJ
               DWPI=DWPI+DIJWJ*ELP(J)
            ENDIF
         ENDDO
         SII=TRTPI*FGAM(I)/SQRT(WI)
         SWFI=SWFI+SII*WI*ELF(I)
         DIIWI=-(TWOPI+DIIWI)
         DWPI=DWPI+DIIWI*ELP(I)
         X(I+I10-1)=-FAC7*(ELP(I)-TWOPIM*DWPI)+FAC9*SWFI
      ENDDO
C
      IF(NSTAGE.LE.1) THEN
C
C     ----- FORM SYSTEM MATRIX A FOR SINGLE STAGE SOLUTION -----
C
         IF(INCORA.AND.INCORT) THEN
            CALL SVPTII(DIEL,NCAV,IOPPRD,CAVC,CAVW,CAVN,FGAM,
     1                  X(I20),X(I30),X(I40))
            IF(IOPPRD.GT.0.AND.LINEQ.EQ.1) THEN
               DO I=1,NCAV
                  DO J=1,NCAV
                     X(J+(I-1)*NCAV+I30-1)=X(I+(J-1)*NCAV+I20-1)
                  ENDDO
               ENDDO
            ENDIF
         ELSEIF(INCORA.AND..NOT.INCORT) THEN
            CALL SVPTIO(DIEL,NCAV,IOPPRD,CAVC,CAVW,CAVN,FGAM,
     1                  X(I20),X(I30))
         ELSEIF(.NOT.INCORA.AND..NOT.INCORT) THEN
            CALL SVPTOO(DIEL,NCAV,IOPPRD,CAVC,CAVW,CAVN,FGAM,
     1                  X(I20),X(I30),X(I40),X(I50))
         ENDIF
C
C     ----- SOLVE SYSTEM EQUATION AND RETURN -----
C
         IADDL=I50
         IF(IOPPRD.EQ.0) SYMMA=.TRUE.
         IF(IOPPRD.NE.0) SYMMA=.FALSE.
         CALL SVPEQU(IADDL,ILAST,LINEQ,CVGLIN,NCAV,SYMMA,INCORA,INCORT,
     1               X(I10),X(I20),X(I30),Q)
         IFIRST=KEYBLK
         RETURN
C
      ELSEIF(NSTAGE.EQ.2) THEN
C
C     --- FORM SYSTEM MATRIX A FOR FIRST STAGE OF TWO STAGE SOLUTION:
C     --- IF IOPPRD=1 THEN APPLY DIELECTRIC-INDEPENDENT OPERATOR FIRST
C     --- IF IOPPRD=2 THEN APPLY DIELECTRIC-DEPENDENT OPERATOR FIRST
C
         IF(IOPPRD.EQ.1) THEN
            SYMMA=.TRUE.
            IF(INCORA) THEN
               CALL SVPSI(NCAV,CAVC,CAVW,FGAM,X(I20))
            ELSEIF(.NOT.INCORA) THEN
               CALL SVPSO(NCAV,CAVC,CAVW,FGAM,X(I20))
            ENDIF
         ELSEIF(IOPPRD.EQ.2) THEN
            SYMMA=.FALSE.
            IF(INCORA) THEN
               CALL SVPGI(DIEL,NCAV,CAVC,CAVW,CAVN,X(I20))
               IF(INCORT.AND.LINEQ.EQ.1) THEN
                  DO I=1,NCAV
                     DO J=1,NCAV
                        X(J+(I-1)*NCAV+I30-1)=X(I+(J-1)*NCAV+I20-1)
                     ENDDO
                  ENDDO
               ENDIF
            ELSEIF(.NOT.INCORA) THEN
               CALL SVPGO(DIEL,NCAV,CAVC,CAVW,CAVN,X(I20),X(I30))
            ENDIF
         ENDIF
C
C     ----- SOLVE FIRST STAGE -----
C
         IADDL=I50
         CALL SVPEQU(IADDL,ILAST,LINEQ,CVGLIN,NCAV,SYMMA,INCORA,INCORT,
     1          X(I10),X(I20),X(I30),X(I40))
         DO I=1,NCAV
            X(I+I40-1)=X(I+I40-1)/CAVW(I)
         ENDDO
C
C     --- FORM SYSTEM MATRIX A FOR SECOND STAGE OF TWO STAGE SOLUTION:
C     --- IF IOPPRD=1 THEN APPLY DIELECTRIC-DEPENDENT OPERATOR SECOND
C     --- IF IOPPRD=2 THEN APPLY DIELECTRIC-INDEPENDENT OPERATOR SECOND
C
         IF(IOPPRD.EQ.1) THEN
            SYMMA=.FALSE.
            IF(INCORA) THEN
               CALL SVPFI(DIEL,NCAV,CAVC,CAVW,CAVN,X(I20))
               IF(INCORT.AND.LINEQ.EQ.1) THEN
                  DO I=1,NCAV
                     DO J=1,NCAV
                        X(J+(I-1)*NCAV+I30-1)=X(I+(J-1)*NCAV+I20-1)
                     ENDDO
                  ENDDO
               ENDIF
            ELSEIF(.NOT.INCORA) THEN
               CALL SVPFO(DIEL,NCAV,CAVC,CAVW,CAVN,X(I20),X(I30))
            ENDIF
         ELSEIF(IOPPRD.EQ.2) THEN
            SYMMA=.TRUE.
            IF(INCORA) THEN
               CALL SVPSI(NCAV,CAVC,CAVW,FGAM,X(I20))
            ELSEIF(.NOT.INCORA) THEN
               CALL SVPSO(NCAV,CAVC,CAVW,FGAM,X(I20))
            ENDIF
         ENDIF
C
C     ----- SOLVE SECOND STAGE AND RETURN -----
C
         IADDL=I50
         CALL SVPEQU(IADDL,ILAST,LINEQ,CVGLIN,NCAV,SYMMA,INCORA,INCORT,
     1               X(I40),X(I20),X(I30),Q)
         IFIRST=KEYBLK
         RETURN
      ENDIF
C
      IFIRST=KEYBLK
      RETURN
 9999 FORMAT(' HINT: SVPQ3 EFFICIENCY WOULD IMPROVE BY PROVIDING ',I10/
     1       ' MORE WORDS OF MEMORY TO HOLD A SECOND NCAV*NCAV MATRIX',
     2       ' IN CORE')
 9998 FORMAT(' HINT: SVPQ3 EFFICIENCY WOULD IMPROVE BY PROVIDING ',I10/
     1       ' MORE WORDS OF MEMORY TO HOLD NCAV*NCAV SYSTEM MATRIX',
     2       ' IN CORE')
      END
C*MODULE SVPCHG  *DECK SVPP0
      SUBROUTINE SVPP0(IADDL,ILAST,DIEL,NCAV,       CAVC,CAVW,CAVN,
     1                              LINEQ,CVGLIN,ELP,    P)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C     ----- SET UP AND SOLVE EQUATIONS FOR SS(V)PE SURFACE DIPOLES -----
C
      PARAMETER (ONE=1.0D+00, TWO=2.0D+00, FOUR=4.0D+00)
      LOGICAL     DBUG
      LOGICAL     MORE
      LOGICAL     OUT
      LOGICAL     SOME
      LOGICAL     SYMMA,INCORA,INCORT
C
      COMMON /FMCOM / X(1)
      COMMON /IOFILE/ IR,IW,IP,IJK,IJKT,IDAF,NAV,IODA(950)
      COMMON/SVPDBG/IDBG
      DIMENSION   CAVC(3,*),CAVW(*)
      DIMENSION   ELP(*),P(*)
      DATA KEYBLK /4H    /
      DATA KEYFST /4HFRST/
      DATA IFIRST /4HFRST/
      SAVE IFIRST
C
      PI=FOUR*ATAN(ONE)
      TWOPI=TWO*PI
      TWOPIM=ONE/TWOPI
      FAC1=(DIEL-ONE)/(DIEL+ONE)
      FAC2=FAC1*TWOPIM
C
      DBUG=.FALSE.
      DBUG=DBUG.OR.IDBG.GE.4
      MORE=.FALSE.
      MORE=MORE.OR.DBUG.OR.IDBG.GE.3
      OUT =.FALSE.
      OUT =OUT.OR.MORE.OR.IDBG.GE.2
      SOME=.FALSE.
      SOME=SOME.OR.OUT.OR.IDBG.GE.1
C
C     ----- DETERMINE SYMMETRY OF MATRIX A -----
C
      SYMMA=.FALSE.
C
C     ----- SET POINTERS FOR PARTITIONING OF CORE -----
C
C     -B-   AT X(I10) (NCAV)
C     -A-   AT X(I20) (NCAV**2 OR NCAV)
C     -AT-  AT X(I30) (NCAV**2 OR NCAV)
C
      INCORA=.TRUE.
      INCORT=.TRUE.
      IF(INCORA.AND.INCORT) THEN
         I10=IADDL
         I20=I10+NCAV
         I30=I20+NCAV**2
         I40=I30+NCAV**2
C
C     ADD ENOUGH FOR SVPEQU USE AS WELL
C
         I50=I40+4*NCAV
         LAST=I50-1
         IF(LAST.GT.ILAST) THEN
            INCORT=.FALSE.
            IF(LINEQ.EQ.1.AND.IFIRST.EQ.KEYFST) THEN
               NEED=LAST-ILAST
               WRITE(IW,9999) NEED
            ENDIF
         ENDIF
      ENDIF
      IF(INCORA.AND..NOT.INCORT) THEN
         I10=IADDL
         I20=I10+NCAV
         I30=I20+NCAV**2
         I40=I30+NCAV
C
C     ADD ENOUGH FOR SVPEQU USE AS WELL
C
         I50=I40+4*NCAV
         LAST=I50-1
         IF(LAST.GT.ILAST) THEN
            INCORA=.FALSE.
            IF(IFIRST.EQ.KEYFST.AND.LINEQ.LT.2) THEN
               LINEQ=2
               NEED=LAST-ILAST
               WRITE(IW,9998) NEED
               WRITE(IW,*) 'FORCE OUT OF CORE SOLUTION WITH LINEQ=2'
            ENDIF
         ENDIF
      ENDIF
      IF(.NOT.INCORA.AND..NOT.INCORT) THEN
         I10=IADDL
         I20=I10+NCAV
         I30=I20+NCAV
         I40=I30+NCAV
C
C     ADD ENOUGH FOR SVPEQU USE AS WELL
C
         I50=I40+4*NCAV
         LAST=I50-1
         IF(LAST.GT.ILAST) THEN
            NEED=LAST-ILAST
            WRITE(IW,*) 'NOT ENOUGH MEMORY TO DO SVP CALCULATION.'
            WRITE(IW,*) 'ADDITIONAL WORDS NEEDED =',NEED
            CALL ABRT
         ENDIF
      ENDIF
C
C     ----- FORM INHOMOGENEITY B -----
C
      DO I=1,NCAV
         X(I+I10-1)=FAC2*ELP(I)
      ENDDO
C
C     ----- FORM SYSTEM MATRIX A -----
C
      IF(INCORA) THEN
         CALL SVPGI(DIEL,NCAV,CAVC,CAVW,CAVN,X(I20))
         IF(INCORT.AND.LINEQ.EQ.1) THEN
            DO I=1,NCAV
               DO J=1,NCAV
                  X(I+(J-1)*NCAV+I30-1)=X(J+(I-1)*NCAV+I20-1)
               ENDDO
            ENDDO
         ENDIF
      ELSEIF(.NOT.INCORA) THEN
         CALL SVPGO(DIEL,NCAV,CAVC,CAVW,CAVN,X(I20),X(I30))
      ENDIF
C
C     ----- SOLVE SYSTEM EQUATION AND RETURN -----
C
         IADDL=I40
         CALL SVPEQU(IADDL,ILAST,LINEQ,CVGLIN,NCAV,SYMMA,INCORA,INCORT,
     1               X(I10),X(I20),X(I30),P)
C
      IFIRST=KEYBLK
      RETURN
 9999 FORMAT(' HINT: SVPP0 EFFICIENCY WOULD IMPROVE BY PROVIDING ',I10/
     1       ' MORE WORDS OF MEMORY TO HOLD A SECOND NCAV*NCAV MATRIX',
     2       ' IN CORE')
 9998 FORMAT(' HINT: SVPP0 EFFICIENCY WOULD IMPROVE BY PROVIDING ',I10/
     1       ' MORE WORDS OF MEMORY TO HOLD NCAV*NCAV SYSTEM MATRIX',
     2       ' IN CORE')
      END
C*MODULE SVPCHG  *DECK SVPP1
      SUBROUTINE SVPP1(IADDL,ILAST,DIEL,NCAV,       CAVC,CAVW,CAVN,
     1                              LINEQ,CVGLIN,ELP,    P)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C     ----- SET UP AND SOLVE EQUATIONS FOR COSMO SURFACE DIPOLES -----
C
      PARAMETER (ONE=1.0D+00, TWO=2.0D+00, FOUR=4.0D+00)
      LOGICAL     DBUG
      LOGICAL     MORE
      LOGICAL     OUT
      LOGICAL     SOME
      LOGICAL     SYMMA,INCORA,INCORT
C
      COMMON /FMCOM / X(1)
      COMMON /IOFILE/ IR,IW,IP,IJK,IJKT,IDAF,NAV,IODA(950)
      COMMON/SVPDBG/IDBG
      DIMENSION   CAVC(3,*),CAVW(*),CAVN(3,*)
      DIMENSION   ELP(*),P(*)
      DATA KEYBLK /4H    /
      DATA KEYFST /4HFRST/
      DATA IFIRST /4HFRST/
      SAVE IFIRST
C
      PI=FOUR*ATAN(ONE)
      TWOPI=TWO*PI
      TWOPIM=ONE/TWOPI
      FAC4  = (DIEL-ONE)/DIEL
      FAC5   = FAC4*TWOPIM
C
      DBUG=.FALSE.
      DBUG=DBUG.OR.IDBG.GE.4
      MORE=.FALSE.
      MORE=MORE.OR.DBUG.OR.IDBG.GE.3
      OUT =.FALSE.
      OUT =OUT.OR.MORE.OR.IDBG.GE.2
      SOME=.FALSE.
      SOME=SOME.OR.OUT.OR.IDBG.GE.1
C
C     ----- DETERMINE SYMMETRY OF MATRIX A -----
C
      SYMMA=.FALSE.
C
C     ----- SET POINTERS FOR PARTITIONING OF CORE -----
C
C     -B-   AT X(I10) (NCAV)
C     -A-   AT X(I20) (NCAV**2 OR NCAV)
C     -AT-  AT X(I30) (NCAV**2 OR NCAV)
C
      INCORA=.TRUE.
      INCORT=.TRUE.
      IF(INCORA.AND.INCORT) THEN
         I10=IADDL
         I20=I10+NCAV
         I30=I20+NCAV**2
         I40=I30+NCAV**2
C
C     ADD ENOUGH FOR SVPEQU USE AS WELL
C
         I50=I40+4*NCAV
         LAST=I50-1
         IF(LAST.GT.ILAST) THEN
            INCORT=.FALSE.
            IF(LINEQ.EQ.1.AND.IFIRST.EQ.KEYFST) THEN
               NEED=LAST-ILAST
               WRITE(IW,9999) NEED
            ENDIF
         ENDIF
      ENDIF
      IF(INCORA.AND..NOT.INCORT) THEN
         I10=IADDL
         I20=I10+NCAV
         I30=I20+NCAV**2
         I40=I30+NCAV
C
C     ADD ENOUGH FOR SVPEQU USE AS WELL
C
         I50=I40+4*NCAV
         LAST=I50-1
         IF(LAST.GT.ILAST) THEN
            INCORA=.FALSE.
            IF(IFIRST.EQ.KEYFST.AND.LINEQ.LT.2) THEN
               LINEQ=2
               NEED=LAST-ILAST
               WRITE(IW,9998) NEED
               WRITE(IW,*) 'FORCE OUT OF CORE SOLUTION WITH LINEQ=2'
            ENDIF
         ENDIF
      ENDIF
      IF(.NOT.INCORA.AND..NOT.INCORT) THEN
         I10=IADDL
         I20=I10+NCAV
         I30=I20+NCAV
         I40=I30+NCAV
C
C     ADD ENOUGH FOR SVPEQU USE AS WELL
C
         I50=I40+4*NCAV
         LAST=I50-1
         IF(LAST.GT.ILAST) THEN
            NEED=LAST-ILAST
            WRITE(IW,*) 'NOT ENOUGH MEMORY TO DO SVP CALCULATION.'
            WRITE(IW,*) 'ADDITIONAL WORDS NEEDED =',NEED
            CALL ABRT
         ENDIF
      ENDIF
C
C     ----- FORM INHOMOGENEITY B -----
C
      DO I=1,NCAV
         X(I+I10-1)=FAC5*ELP(I)
      ENDDO
C
C     ----- FORM SYSTEM MATRIX A -----
C
      IF(INCORA) THEN
         CALL SVPMI(NCAV,CAVC,CAVW,CAVN,X(I20))
         IF(INCORT.AND.LINEQ.EQ.1) THEN
            DO I=1,NCAV
               DO J=1,NCAV
                  X(I+(J-1)*NCAV+I30-1)=X(J+(I-1)*NCAV+I20-1)
               ENDDO
            ENDDO
         ENDIF
      ELSEIF(.NOT.INCORA) THEN
         CALL SVPMO(NCAV,CAVC,CAVW,CAVN,X(I20),X(I30))
      ENDIF
C
C     ----- SOLVE SYSTEM EQUATION AND RETURN -----
C
      IADDL=I40
      CALL SVPEQU(IADDL,ILAST,LINEQ,CVGLIN,NCAV,SYMMA,INCORA,INCORT,
     1            X(I10),X(I20),X(I30),P)
C
      IFIRST=KEYBLK
      RETURN
 9999 FORMAT(' HINT: SVPP1 EFFICIENCY WOULD IMPROVE BY PROVIDING ',I10/
     1       ' MORE WORDS OF MEMORY TO HOLD A SECOND NCAV*NCAV MATRIX',
     2       ' IN CORE')
 9998 FORMAT(' HINT: SVPP1 EFFICIENCY WOULD IMPROVE BY PROVIDING ',I10/
     1       ' MORE WORDS OF MEMORY TO HOLD NCAV*NCAV SYSTEM MATRIX',
     2       ' IN CORE')
      END
C*MODULE SVPCHG  *DECK SVPP2
      SUBROUTINE SVPP2(IADDL,ILAST,DIEL,NCAV,IOPPRD,CAVC,CAVW,CAVN,
     1                 NSTAGE,FGAM,  LINEQ,CVGLIN,    ELF,P)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C     ----- SET UP AND SOLVE EQUATIONS FOR SPE SURFACE DIPOLES -----
C
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00, TWO=2.0D+00, FOUR=4.0D+00)
      LOGICAL     DBUG
      LOGICAL     MORE
      LOGICAL     OUT
      LOGICAL     SOME
      LOGICAL     SYMMA,INCORA,INCORT
C
      COMMON /FMCOM / X(1)
      COMMON /IOFILE/ IR,IW,IP,IJK,IJKT,IDAF,NAV,IODA(950)
      COMMON/SVPDBG/IDBG
      DIMENSION   CAVC(3,*),CAVW(*),CAVN(3,*)
      DIMENSION   FGAM(*),ELF(*),P(*)
      DATA KEYBLK /4H    /
      DATA KEYFST /4HFRST/
      DATA IFIRST /4HFRST/
      SAVE IFIRST
C
      PI=FOUR*ATAN(ONE)
      TWOPI=TWO*PI
      TWOPIM=ONE/TWOPI
      TRTPI=TWO*SQRT(PI)
      FAC1=(DIEL-ONE)/(DIEL+ONE)
      FAC3=FAC1*TWOPIM**2
C
      DBUG=.FALSE.
      DBUG=DBUG.OR.IDBG.GE.4
      MORE=.FALSE.
      MORE=MORE.OR.DBUG.OR.IDBG.GE.3
      OUT =.FALSE.
      OUT =OUT.OR.MORE.OR.IDBG.GE.2
      SOME=.FALSE.
      SOME=SOME.OR.OUT.OR.IDBG.GE.1
C
C     ----- DETERMINE SYMMETRY OF SVP MATRIX A -----
C
      SYMMA=.FALSE.
C
C     ----- SET POINTERS FOR PARTITIONING OF CORE -----
C
C     -B-   AT X(I10) (NCAV)
C     -A-   AT X(I20) (NCAV**2 OR NCAV)
C     -T-   AT X(I30) (NCAV**2 OR NCAV) (T IS A+ OR SCR OR BOTH)
C     -SCR- AT X(I40) (NCAV)
C
      INCORA=.TRUE.
      INCORT=.TRUE.
      IF(INCORA.AND.INCORT) THEN
         I10=IADDL
         I20=I10+NCAV
         I30=I20+NCAV**2
         I40=I30+NCAV**2
         I50=I40+NCAV
C
C     ADD ENOUGH FOR SVPEQU USE AS WELL
C
         I60=I50+4*NCAV
         LAST=I60-1
         IF(LAST.LE.ILAST) THEN
            IF(NSTAGE.EQ.0) THEN
               IF(IOPPRD.LE.0.OR.IOPPRD.GE.3) THEN
                  NSTAGE=1
               ELSEIF(IOPPRD.EQ.1.OR.IOPPRD.EQ.2) THEN
                  NSTAGE=2
                  IF(IFIRST.EQ.KEYFST)
     1               WRITE(IW,*) 'USE NSTAGE=2 STRATEGY IN SVPP2'
               ENDIF
            ENDIF
         ENDIF
         IF(LAST.GT.ILAST) THEN
            INCORT=.FALSE.
            IF(NSTAGE.EQ.0) THEN
               IF(IOPPRD.LE.0.OR.IOPPRD.GE.3) THEN
                  NSTAGE=1
               ELSEIF(IOPPRD.EQ.1.OR.IOPPRD.EQ.2) THEN
                  NSTAGE=2
                  IF(IFIRST.EQ.KEYFST)
     1               WRITE(IW,*) 'USE NSTAGE=2 STRATEGY IN SVPP2'
               ENDIF
            ENDIF
            IF(NSTAGE.EQ.1.AND.IFIRST.EQ.KEYFST) THEN
               NEED=LAST-ILAST
               WRITE(IW,9999) NEED
            ENDIF
         ENDIF
      ENDIF
      IF(INCORA.AND..NOT.INCORT) THEN
         I10=IADDL
         I20=I10+NCAV
         I30=I20+NCAV**2
         I40=I30+NCAV
         I50=I40+NCAV
C
C     ADD ENOUGH FOR SVPEQU USE AS WELL
C
         I60=I50+4*NCAV
         LAST=I60-1
         IF(LAST.GT.ILAST) THEN
            INCORA=.FALSE.
            IF(IFIRST.EQ.KEYFST.AND.LINEQ.LT.2) THEN
               LINEQ=2
               NEED=LAST-ILAST
               WRITE(IW,9998) NEED
               WRITE(IW,*) 'FORCE OUT OF CORE SOLUTION WITH LINEQ=2'
               IF(NSTAGE.EQ.0) THEN
                  WRITE(IW,*) 'AND ALSO CHANGE TO NSTAGE=2 STRATEGY'
               ENDIF
            ENDIF
            IF(NSTAGE.EQ.0) NSTAGE=2
         ENDIF
      ENDIF
      IF(.NOT.INCORA.AND..NOT.INCORT) THEN
         I10=IADDL
         I20=I10+NCAV
         I30=I20+NCAV
         I40=I30+NCAV
         I50=I40+NCAV
C
C     ADD ENOUGH FOR SVPEQU USE AS WELL
C
         I60=I50+4*NCAV
         LAST=I60-1
         IF(LAST.GT.ILAST) THEN
            NEED=LAST-ILAST
            WRITE(IW,*) 'NOT ENOUGH MEMORY TO DO SVP CALCULATION.'
            WRITE(IW,*) 'ADDITIONAL WORDS NEEDED =',NEED
            CALL ABRT
         ENDIF
      ENDIF
C
C     ----- FORM INHOMOGENEITY B -----
C
      DO I=1,NCAV
         XI=CAVC(1,I)
         YI=CAVC(2,I)
         ZI=CAVC(3,I)
         WI=CAVW(I)
         SWFI=ZERO
         DO J=1,NCAV
            IF(I.NE.J) THEN
               XIJ=XI-CAVC(1,J)
               YIJ=YI-CAVC(2,J)
               ZIJ=ZI-CAVC(3,J)
               WJ=CAVW(J)
               RRIJ=XIJ**2+YIJ**2+ZIJ**2
               SIJ=ONE/SQRT(RRIJ)
               SWFI=SWFI+SIJ*WJ*ELF(J)
            ENDIF
         ENDDO
         SII=TRTPI*FGAM(I)/SQRT(WI)
         SWFI=SWFI+SII*WI*ELF(I)
         X(I+I10-1)=FAC3*SWFI
      ENDDO
C
      IF(NSTAGE.LE.1) THEN
C
C        ----- FORM SYSTEM MATRIX A FOR SINGLE STAGE SOLUTION -----
C
         IF(INCORA.AND.INCORT) THEN
            CALL SVPDII(DIEL,NCAV,     CAVC,CAVW,CAVN,
     1                  X(I20),X(I30),X(I40))
            IF(LINEQ.EQ.1) THEN
               DO I=1,NCAV
                  DO J=1,NCAV
                     X(J+(I-1)*NCAV+I30-1)=X(I+(J-1)*NCAV+I20-1)
                  ENDDO
               ENDDO
            ENDIF
         ELSEIF(INCORA.AND..NOT.INCORT) THEN
            CALL SVPDIO(DIEL,NCAV,     CAVC,CAVW,CAVN,
     1                  X(I20),X(I30),X(I40))
         ELSEIF(.NOT.INCORA.AND..NOT.INCORT) THEN
            CALL SVPDOO(DIEL,NCAV,     CAVC,CAVW,CAVN,
     1                  X(I20),X(I30),X(I40),X(I50))
         ENDIF
C
C        ----- SOLVE SYSTEM EQUATION AND RETURN -----
C
         IADDL=I50
         SYMMA=.FALSE.
         CALL SVPEQU(IADDL,ILAST,LINEQ,CVGLIN,NCAV,SYMMA,INCORA,INCORT,
     1               X(I10),X(I20),X(I30),P)
         IFIRST=KEYBLK
         RETURN
C
      ELSEIF(NSTAGE.EQ.2) THEN
C
C     --- FORM SYSTEM MATRIX A FOR FIRST STAGE OF TWO STAGE SOLUTION:
C     --- IF IOPPRD=1 THEN APPLY DIELECTRIC-INDEPENDENT OPERATOR FIRST
C     --- IF IOPPRD=2 THEN APPLY DIELECTRIC-DEPENDENT OPERATOR FIRST
C
         IF(IOPPRD.EQ.1) THEN
            SYMMA=.FALSE.
            IF(INCORA) THEN
               CALL SVPMI(NCAV,CAVC,CAVW,CAVN,X(I20))
               IF(INCORT.AND.LINEQ.EQ.1) THEN
                  DO I=1,NCAV
                     DO J=1,NCAV
                        X(J+(I-1)*NCAV+I30-1)=X(I+(J-1)*NCAV+I20-1)
                     ENDDO
                  ENDDO
               ENDIF
            ELSEIF(.NOT.INCORA) THEN
               CALL SVPMO(NCAV,CAVC,CAVW,CAVN,X(I20),X(I30))
            ENDIF
         ELSEIF(IOPPRD.EQ.2) THEN
            SYMMA=.FALSE.
            IF(INCORA) THEN
               CALL SVPGI(DIEL,NCAV,CAVC,CAVW,CAVN,X(I20))
               IF(INCORT.AND.LINEQ.EQ.1) THEN
                  DO I=1,NCAV
                     DO J=1,NCAV
                        X(J+(I-1)*NCAV+I30-1)=X(I+(J-1)*NCAV+I20-1)
                     ENDDO
                  ENDDO
               ENDIF
            ELSEIF(.NOT.INCORA) THEN
               CALL SVPGO(DIEL,NCAV,CAVC,CAVW,CAVN,X(I20),X(I30))
            ENDIF
         ENDIF
C
C     ----- SOLVE FIRST STAGE -----
C
         IADDL=I50
         CALL SVPEQU(IADDL,ILAST,LINEQ,CVGLIN,NCAV,SYMMA,INCORA,INCORT,
     1          X(I10),X(I20),X(I30),X(I40))
         DO I=1,NCAV
            X(I+I40-1)=X(I+I40-1)/CAVW(I)
         ENDDO
C
C     --- FORM SYSTEM MATRIX A FOR SECOND STAGE OF TWO STAGE SOLUTION:
C     --- IF IOPPRD=1 THEN APPLY DIELECTRIC-DEPENDENT OPERATOR SECOND
C     --- IF IOPPRD=2 THEN APPLY DIELECTRIC-INDEPENDENT OPERATOR SECOND
C
         IF(IOPPRD.EQ.1) THEN
            SYMMA=.FALSE.
            IF(INCORA) THEN
               CALL SVPGI(DIEL,NCAV,CAVC,CAVW,CAVN,X(I20))
               IF(INCORT.AND.LINEQ.EQ.1) THEN
                  DO I=1,NCAV
                     DO J=1,NCAV
                        X(J+(I-1)*NCAV+I30-1)=X(I+(J-1)*NCAV+I20-1)
                     ENDDO
                  ENDDO
               ENDIF
            ELSEIF(.NOT.INCORA) THEN
               CALL SVPGO(DIEL,NCAV,CAVC,CAVW,CAVN,X(I20),X(I30))
            ENDIF
         ELSEIF(IOPPRD.EQ.2) THEN
            SYMMA=.FALSE.
            IF(INCORA) THEN
               CALL SVPMI(NCAV,CAVC,CAVW,CAVN,X(I20))
               IF(INCORT.AND.LINEQ.EQ.1) THEN
                  DO I=1,NCAV
                     DO J=1,NCAV
                        X(J+(I-1)*NCAV+I30-1)=X(I+(J-1)*NCAV+I20-1)
                     ENDDO
                  ENDDO
               ENDIF
            ELSEIF(.NOT.INCORA) THEN
               CALL SVPMO(NCAV,CAVC,CAVW,CAVN,X(I20),X(I30))
            ENDIF
         ENDIF
C
C     ----- SOLVE SECOND STAGE AND RETURN -----
C
         IADDL=I50
         CALL SVPEQU(IADDL,ILAST,LINEQ,CVGLIN,NCAV,SYMMA,INCORA,INCORT,
     1               X(I40),X(I20),X(I30),P)
         IFIRST=KEYBLK
         RETURN
      ENDIF
C
      IFIRST=KEYBLK
      RETURN
 9999 FORMAT(' HINT: SVPP2 EFFICIENCY WOULD IMPROVE BY PROVIDING ',I10/
     1       ' MORE WORDS OF MEMORY TO HOLD A SECOND NCAV*NCAV MATRIX',
     2       ' IN CORE')
 9998 FORMAT(' HINT: SVPP2 EFFICIENCY WOULD IMPROVE BY PROVIDING ',I10/
     1       ' MORE WORDS OF MEMORY TO HOLD NCAV*NCAV SYSTEM MATRIX',
     2       ' IN CORE')
      END
C*MODULE SVPCHG  *DECK SVPP3
      SUBROUTINE SVPP3(IADDL,ILAST,DIEL,NCAV,IOPPRD,CAVC,CAVW,CAVN,
     1                 NSTAGE,FGAM,  LINEQ,CVGLIN,ELP,ELF,P)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C     ----- SET UP AND SOLVE EQUATIONS FOR IEF SURFACE DIPOLES -----
C
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00, TWO=2.0D+00, FOUR=4.0D+00)
      LOGICAL     DBUG
      LOGICAL     MORE
      LOGICAL     OUT
      LOGICAL     SOME
      LOGICAL     SYMMA,INCORA,INCORT
C
      COMMON /FMCOM / X(1)
      COMMON /IOFILE/ IR,IW,IP,IJK,IJKT,IDAF,NAV,IODA(950)
      COMMON/SVPDBG/IDBG
      DIMENSION   CAVC(3,*),CAVW(*),CAVN(3,*)
      DIMENSION   FGAM(*),ELP(*),ELF(*),P(*)
      DATA KEYBLK /4H    /
      DATA KEYFST /4HFRST/
      DATA IFIRST /4HFRST/
      SAVE IFIRST
C
      PI=FOUR*ATAN(ONE)
      TWOPI=TWO*PI
      TWOPIM=ONE/TWOPI
      TRTPI=TWO*SQRT(PI)
      FAC8=(DIEL/(DIEL+ONE))*TWOPIM
      FAC10=(ONE/(DIEL+ONE))*TWOPIM**2
C
      DBUG=.FALSE.
      DBUG=DBUG.OR.IDBG.GE.4
      MORE=.FALSE.
      MORE=MORE.OR.DBUG.OR.IDBG.GE.3
      OUT =.FALSE.
      OUT =OUT.OR.MORE.OR.IDBG.GE.2
      SOME=.FALSE.
      SOME=SOME.OR.OUT.OR.IDBG.GE.1
C
C     ----- DETERMINE SYMMETRY OF SVP MATRIX A -----
C
      SYMMA=.FALSE.
C
C     ----- SET POINTERS FOR PARTITIONING OF CORE -----
C
C     -B-   AT X(I10) (NCAV)
C     -A-   AT X(I20) (NCAV**2 OR NCAV)
C     -T-   AT X(I30) (NCAV**2 OR NCAV) (T IS A+ OR SCR OR BOTH)
C     -SCR- AT X(I40) (NCAV)
C
      INCORA=.TRUE.
      INCORT=.TRUE.
      IF(INCORA.AND.INCORT) THEN
         I10=IADDL
         I20=I10+NCAV
         I30=I20+NCAV**2
         I40=I30+NCAV**2
         I50=I40+NCAV
C
C     ADD ENOUGH FOR SVPEQU USE AS WELL
C
         I60=I50+4*NCAV
         LAST=I60-1
         IF(LAST.LE.ILAST) THEN
            IF(NSTAGE.EQ.0) THEN
               IF(IOPPRD.LE.0.OR.IOPPRD.GE.3) THEN
                  NSTAGE=1
               ELSEIF(IOPPRD.EQ.1.OR.IOPPRD.EQ.2) THEN
                  NSTAGE=2
                  IF(IFIRST.EQ.KEYFST)
     1               WRITE(IW,*) 'USE NSTAGE=2 STRATEGY IN SVPP3'
               ENDIF
            ENDIF
         ENDIF
         IF(LAST.GT.ILAST) THEN
            INCORT=.FALSE.
            IF(NSTAGE.EQ.0) THEN
               IF(IOPPRD.LE.0.OR.IOPPRD.GE.3) THEN
                  NSTAGE=1
               ELSEIF(IOPPRD.EQ.1.OR.IOPPRD.EQ.2) THEN
                  NSTAGE=2
                  IF(IFIRST.EQ.KEYFST)
     1               WRITE(IW,*) 'USE NSTAGE=2 STRATEGY IN SVPP3'
               ENDIF
            ENDIF
            IF(NSTAGE.EQ.1.AND.IFIRST.EQ.KEYFST) THEN
               NEED=LAST-ILAST
               WRITE(IW,9999) NEED
            ENDIF
         ENDIF
      ENDIF
      IF(INCORA.AND..NOT.INCORT) THEN
         I10=IADDL
         I20=I10+NCAV
         I30=I20+NCAV**2
         I40=I30+NCAV
         I50=I40+NCAV
C
C     ADD ENOUGH FOR SVPEQU USE AS WELL
C
         I60=I50+4*NCAV
         LAST=I60-1
         IF(LAST.GT.ILAST) THEN
            INCORA=.FALSE.
            IF(IFIRST.EQ.KEYFST.AND.LINEQ.LT.2) THEN
               LINEQ=2
               NEED=LAST-ILAST
               WRITE(IW,9998) NEED
               WRITE(IW,*) 'FORCE OUT OF CORE SOLUTION WITH LINEQ=2'
               IF(NSTAGE.EQ.0) THEN
                  WRITE(IW,*) 'AND ALSO CHANGE TO NSTAGE=2 STRATEGY'
               ENDIF
            ENDIF
            IF(NSTAGE.EQ.0) NSTAGE=2
         ENDIF
      ENDIF
      IF(.NOT.INCORA.AND..NOT.INCORT) THEN
         I10=IADDL
         I20=I10+NCAV
         I30=I20+NCAV
         I40=I30+NCAV
         I50=I40+NCAV
C
C     ADD ENOUGH FOR SVPEQU USE AS WELL
C
         I60=I50+4*NCAV
         LAST=I60-1
         IF(LAST.GT.ILAST) THEN
            NEED=LAST-ILAST
            WRITE(IW,*) 'NOT ENOUGH MEMORY TO DO SVP CALCULATION.'
            WRITE(IW,*) 'ADDITIONAL WORDS NEEDED =',NEED
            CALL ABRT
         ENDIF
      ENDIF
C
C     ----- FORM INHOMOGENEITY B -----
C
      DO I=1,NCAV
         XI=CAVC(1,I)
         YI=CAVC(2,I)
         ZI=CAVC(3,I)
         WI=CAVW(I)
         DWPI=ZERO
         SWFI=ZERO
         DIIWI=ZERO
         DO J=1,NCAV
            IF(I.NE.J) THEN
               XIJ=XI-CAVC(1,J)
               YIJ=YI-CAVC(2,J)
               ZIJ=ZI-CAVC(3,J)
               WJ=CAVW(J)
               RRIJ=XIJ**2+YIJ**2+ZIJ**2
               SIJ=ONE/SQRT(RRIJ)
               SWFI=SWFI+SIJ*WJ*ELF(J)
               DOTJ=CAVN(1,J)*XIJ+CAVN(2,J)*YIJ+CAVN(3,J)*ZIJ
               DIJ=DOTJ*SIJ**3
               DIJWJ=DIJ*WJ
               DIIWI=DIIWI+DIJWJ
               DWPI=DWPI+DIJWJ*ELP(J)
            ENDIF
         ENDDO
         SII=TRTPI*FGAM(I)/SQRT(WI)
         SWFI=SWFI+SII*WI*ELF(I)
         DIIWI=-(TWOPI+DIIWI)
         ELPI=ELP(I)
         DWPI=DWPI+DIIWI*ELPI
         X(I+I10-1)=FAC8*(ELPI-TWOPIM*DWPI)-FAC10*SWFI
      ENDDO
C
      IF(NSTAGE.LE.1) THEN
C
C     ----- FORM SYSTEM MATRIX A FOR SINGLE STAGE SOLUTION -----
C
         IF(INCORA.AND.INCORT) THEN
            CALL SVPDII(DIEL,NCAV,     CAVC,CAVW,CAVN,
     1                  X(I20),X(I30),X(I40))
            IF(LINEQ.EQ.1) THEN
               DO I=1,NCAV
                  DO J=1,NCAV
                     X(J+(I-1)*NCAV+I30-1)=X(I+(J-1)*NCAV+I20-1)
                  ENDDO
               ENDDO
            ENDIF
         ELSEIF(INCORA.AND..NOT.INCORT) THEN
            CALL SVPDIO(DIEL,NCAV,     CAVC,CAVW,CAVN,
     1                  X(I20),X(I30),X(I40))
         ELSEIF(.NOT.INCORA.AND..NOT.INCORT) THEN
            CALL SVPDOO(DIEL,NCAV,     CAVC,CAVW,CAVN,
     1                  X(I20),X(I30),X(I40),X(I50))
         ENDIF
C
C     ----- SOLVE SYSTEM EQUATION AND RETURN -----
C
         IADDL=I50
         SYMMA=.FALSE.
         CALL SVPEQU(IADDL,ILAST,LINEQ,CVGLIN,NCAV,SYMMA,INCORA,INCORT,
     1               X(I10),X(I20),X(I30),P)
         IFIRST=KEYBLK
         RETURN
C
      ELSEIF(NSTAGE.EQ.2) THEN
C
C     --- FORM SYSTEM MATRIX A FOR FIRST STAGE OF TWO STAGE SOLUTION:
C     --- IF IOPPRD=1 THEN APPLY DIELECTRIC-INDEPENDENT OPERATOR FIRST
C     --- IF IOPPRD=2 THEN APPLY DIELECTRIC-DEPENDENT OPERATOR FIRST
C
         IF(IOPPRD.EQ.1) THEN
            SYMMA=.FALSE.
            IF(INCORA) THEN
               CALL SVPMI(NCAV,CAVC,CAVW,CAVN,X(I20))
               IF(INCORT.AND.LINEQ.EQ.1) THEN
                  DO I=1,NCAV
                     DO J=1,NCAV
                        X(J+(I-1)*NCAV+I30-1)=X(I+(J-1)*NCAV+I20-1)
                     ENDDO
                  ENDDO
               ENDIF
            ELSEIF(.NOT.INCORA) THEN
               CALL SVPMO(NCAV,CAVC,CAVW,CAVN,X(I20),X(I30))
            ENDIF
         ELSEIF(IOPPRD.EQ.2) THEN
            SYMMA=.FALSE.
            IF(INCORA) THEN
               CALL SVPGI(DIEL,NCAV,CAVC,CAVW,CAVN,X(I20))
               IF(INCORT.AND.LINEQ.EQ.1) THEN
                  DO I=1,NCAV
                     DO J=1,NCAV
                        X(J+(I-1)*NCAV+I30-1)=X(I+(J-1)*NCAV+I20-1)
                     ENDDO
                  ENDDO
               ENDIF
            ELSEIF(.NOT.INCORA) THEN
               CALL SVPGO(DIEL,NCAV,CAVC,CAVW,CAVN,X(I20),X(I30))
            ENDIF
         ENDIF
C
C     ----- SOLVE FIRST STAGE -----
C
         IADDL=I50
         CALL SVPEQU(IADDL,ILAST,LINEQ,CVGLIN,NCAV,SYMMA,INCORA,INCORT,
     1          X(I10),X(I20),X(I30),X(I40))
         DO I=1,NCAV
            X(I+I40-1)=X(I+I40-1)/CAVW(I)
         ENDDO
C
C     --- FORM SYSTEM MATRIX A FOR SECOND STAGE OF TWO STAGE SOLUTION:
C     --- IF IOPPRD=1 THEN APPLY DIELECTRIC-DEPENDENT OPERATOR SECOND
C     --- IF IOPPRD=2 THEN APPLY DIELECTRIC-INDEPENDENT OPERATOR SECOND
C
         IF(IOPPRD.EQ.1) THEN
            SYMMA=.FALSE.
            IF(INCORA) THEN
               CALL SVPGI(DIEL,NCAV,CAVC,CAVW,CAVN,X(I20))
               IF(INCORT.AND.LINEQ.EQ.1) THEN
                  DO I=1,NCAV
                     DO J=1,NCAV
                        X(J+(I-1)*NCAV+I30-1)=X(I+(J-1)*NCAV+I20-1)
                     ENDDO
                  ENDDO
               ENDIF
            ELSEIF(.NOT.INCORA) THEN
               CALL SVPGO(DIEL,NCAV,CAVC,CAVW,CAVN,X(I20),X(I30))
            ENDIF
         ELSEIF(IOPPRD.EQ.2) THEN
            SYMMA=.FALSE.
            IF(INCORA) THEN
               CALL SVPMI(NCAV,CAVC,CAVW,CAVN,X(I20))
               IF(INCORT.AND.LINEQ.EQ.1) THEN
                  DO I=1,NCAV
                     DO J=1,NCAV
                        X(J+(I-1)*NCAV+I30-1)=X(I+(J-1)*NCAV+I20-1)
                     ENDDO
                  ENDDO
               ENDIF
            ELSEIF(.NOT.INCORA) THEN
               CALL SVPMO(NCAV,CAVC,CAVW,CAVN,X(I20),X(I30))
            ENDIF
         ENDIF
C
C     ----- SOLVE SECOND STAGE AND RETURN -----
C
         IADDL=I50
         CALL SVPEQU(IADDL,ILAST,LINEQ,CVGLIN,NCAV,SYMMA,INCORA,INCORT,
     1               X(I40),X(I20),X(I30),P)
         IFIRST=KEYBLK
         RETURN
      ENDIF
C
      IFIRST=KEYBLK
      RETURN
 9999 FORMAT(' HINT: SVPP3 EFFICIENCY WOULD IMPROVE BY PROVIDING ',I10/
     1       ' MORE WORDS OF MEMORY TO HOLD A SECOND NCAV*NCAV MATRIX',
     2       ' IN CORE')
 9998 FORMAT(' HINT: SVPP3 EFFICIENCY WOULD IMPROVE BY PROVIDING ',I10/
     1       ' MORE WORDS OF MEMORY TO HOLD NCAV*NCAV SYSTEM MATRIX',
     2       ' IN CORE')
      END
C*MODULE SVPCHG  *DECK SVPTII
      SUBROUTINE SVPTII(DIEL,NCAV,IOPPRD,CAVC,CAVW,CAVN,FGAM,A,S,F)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C     ----- SS(V)PE SIGMA SYSTEM MATRIX A DONE ENTIRELY IN CORE -----
C
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00, TWO=2.0D+00, FOUR=4.0D+00)
      DIMENSION CAVC(3,*),CAVW(*),CAVN(3,*)
      DIMENSION FGAM(*),A(NCAV,*),S(NCAV,*),F(*)
C
      PI=FOUR*ATAN(ONE)
      TWOPI=TWO*PI
      TWOPIM=ONE/TWOPI
      TRTPI=TWO*SQRT(PI)
      FAC1=(DIEL-ONE)/(DIEL+ONE)
      FAC2=FAC1*TWOPIM
      FAC11=ONE/(DIEL-ONE)
C
C     FORM DSTAR IN A, S
C
      DO J=1,NCAV
         XJ=CAVC(1,J)
         YJ=CAVC(2,J)
         ZJ=CAVC(3,J)
         WJ=CAVW(J)
         SUMWD=ZERO
         DO I=1,NCAV
            IF(I.NE.J) THEN
               XIJ=CAVC(1,I)-XJ
               YIJ=CAVC(2,I)-YJ
               ZIJ=CAVC(3,I)-ZJ
               RRIJ=XIJ**2+YIJ**2+ZIJ**2
               SIJ=ONE/SQRT(RRIJ)
               S(I,J)=SIJ
               DOTI=CAVN(1,I)*XIJ+CAVN(2,I)*YIJ+CAVN(3,I)*ZIJ
               DSTRIJ=-DOTI*SIJ**3
               A(I,J)=DSTRIJ
               SUMWD=SUMWD+CAVW(I)*DSTRIJ
            ENDIF
         ENDDO
         SJJ=TRTPI*FGAM(J)/SQRT(WJ)
         S(J,J)=SJJ
         DSTRJJ=-(TWOPI+SUMWD)/WJ
         A(J,J)=DSTRJJ
      ENDDO
C
C     REPLACE A BY I-FAC2*W*DSTAR
C
      DO I=1,NCAV
         DO J=1,NCAV
            A(J,I)=-FAC2*CAVW(J)*A(J,I)
         ENDDO
         A(I,I)=A(I,I)+ONE
      ENDDO
C
C     REPLACE A BY (S-FAC2*S*W*DSTAR)
C
      DO K=1,NCAV
         DO J=1,NCAV
            F(J)=A(J,K)
         ENDDO
         DO I=1,NCAV
            AIK=ZERO
            DO J=1,NCAV
               AIK=AIK+S(J,I)*F(J)
            ENDDO
            A(I,K)=AIK
         ENDDO
      ENDDO
C
C     FORM DESIRED COMBINATION OF (S-FAC2*S*W*DSTAR) AND ITS TRANSPOSE
C
      IF(IOPPRD.EQ.0) THEN
         DO I=2,NCAV
            DO J=1,I-1
               TMP=(A(I,J)+A(J,I))/TWO
               A(I,J)=TMP
               A(J,I)=TMP
            ENDDO
         ENDDO
      ELSEIF(IOPPRD.EQ.1) THEN
         CONTINUE
      ELSEIF(IOPPRD.EQ.2) THEN
         DO I=2,NCAV
            DO J=1,I-1
               TMPJI=A(J,I)
               A(J,I)=A(I,J)
               A(I,J)=TMPJI
            ENDDO
         ENDDO
      ELSEIF(IOPPRD.EQ.3) THEN
         DO I=2,NCAV
            DO J=1,I-1
               TMPIJ=A(I,J)
               TMPJI=A(J,I)
               A(I,J)=FAC11*(-TMPIJ+DIEL*TMPJI)
               A(J,I)=FAC11*(-TMPJI+DIEL*TMPIJ)
            ENDDO
         ENDDO
      ENDIF
C
      RETURN
      END
C*MODULE SVPCHG  *DECK SVPTIO
      SUBROUTINE SVPTIO(DIEL,NCAV,IOPPRD,CAVC,CAVW,CAVN,FGAM,A,F)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C     ----- SS(V)PE SIGMA SYSTEM MATRIX A DONE PARTIALLY IN CORE -----
C
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00, TWO=2.0D+00, FOUR=4.0D+00)
      DIMENSION CAVC(3,*),CAVW(*),CAVN(3,*)
      DIMENSION FGAM(*),A(NCAV,*),F(*)
C
      PI=FOUR*ATAN(ONE)
      TWOPI=TWO*PI
      TWOPIM=ONE/TWOPI
      TRTPI=TWO*SQRT(PI)
      FAC1=(DIEL-ONE)/(DIEL+ONE)
      FAC2=FAC1*TWOPIM
      FAC11=ONE/(DIEL-ONE)
C
C     FORM DSTAR IN A
C
      DO J=1,NCAV
         XJ=CAVC(1,J)
         YJ=CAVC(2,J)
         ZJ=CAVC(3,J)
         WJ=CAVW(J)
         SUMWD=ZERO
         DO I=1,NCAV
            IF(I.NE.J) THEN
               XIJ=CAVC(1,I)-XJ
               YIJ=CAVC(2,I)-YJ
               ZIJ=CAVC(3,I)-ZJ
               RRIJ=XIJ**2+YIJ**2+ZIJ**2
               DOTI=CAVN(1,I)*XIJ+CAVN(2,I)*YIJ+CAVN(3,I)*ZIJ
               DSTRIJ=-DOTI/(RRIJ*SQRT(RRIJ))
               A(I,J)=DSTRIJ
               SUMWD=SUMWD+CAVW(I)*DSTRIJ
            ENDIF
         ENDDO
         DSTRJJ=-(TWOPI+SUMWD)/WJ
         A(J,J)=DSTRJJ
      ENDDO
C
C     REPLACE A BY I-FAC2*W*DSTAR
C
      DO I=1,NCAV
         DO J=1,NCAV
            A(J,I)=-FAC2*CAVW(J)*A(J,I)
         ENDDO
         A(I,I)=A(I,I)+ONE
      ENDDO
C
C     REPLACE A BY (S-FAC2*S*W*DSTAR)
C
      DO K=1,NCAV
         DO J=1,NCAV
            F(J)=A(J,K)
         ENDDO
         DO I=1,NCAV
            XI=CAVC(1,I)
            YI=CAVC(2,I)
            ZI=CAVC(3,I)
            AIK=ZERO
            DO J=1,NCAV
               IF(J.NE.I) THEN
                  XIJ=XI-CAVC(1,J)
                  YIJ=YI-CAVC(2,J)
                  ZIJ=ZI-CAVC(3,J)
                  RRIJ=XIJ**2+YIJ**2+ZIJ**2
                  SIJ=ONE/SQRT(RRIJ)
                  AIK=AIK+SIJ*F(J)
               ENDIF
            ENDDO
            SII=TRTPI*FGAM(I)/SQRT(CAVW(I))
            AIK=AIK+SII*F(I)
            A(I,K)=AIK
         ENDDO
      ENDDO
C
C     FORM DESIRED COMBINATION OF (S-FAC2*S*W*DSTAR) AND ITS TRANSPOSE
C
      IF(IOPPRD.EQ.0) THEN
         DO I=2,NCAV
            DO J=1,I-1
               TMP=(A(I,J)+A(J,I))/TWO
               A(I,J)=TMP
               A(J,I)=TMP
            ENDDO
         ENDDO
      ELSEIF(IOPPRD.EQ.1) THEN
         CONTINUE
      ELSEIF(IOPPRD.EQ.2) THEN
         DO I=2,NCAV
            DO J=1,I-1
               TMPJI=A(J,I)
               A(J,I)=A(I,J)
               A(I,J)=TMPJI
            ENDDO
         ENDDO
      ELSEIF(IOPPRD.EQ.3) THEN
         DO I=2,NCAV
            DO J=1,I-1
               TMPIJ=A(I,J)
               TMPJI=A(J,I)
               A(I,J)=FAC11*(-TMPIJ+DIEL*TMPJI)
               A(J,I)=FAC11*(-TMPJI+DIEL*TMPIJ)
            ENDDO
         ENDDO
      ENDIF
C
      RETURN
      END
C*MODULE SVPCHG  *DECK SVPTOO
      SUBROUTINE SVPTOO(DIEL,NCAV,IOPPRD,CAVC,CAVW,CAVN,FGAM,
     1                  A,AT,D,S)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C     ----- SS(V)PE SYSTEM MATRIX A DONE OUT OF CORE -----
C
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00, TWO=2.0D+00, FOUR=4.0D+00)
      DIMENSION CAVC(3,*),CAVW(*),CAVN(3,*)
      DIMENSION FGAM(*),A(NCAV),AT(NCAV),D(*),S(*)
      DATA NFT17 /26/
      DATA NFT18 /27/
C
      PI=FOUR*ATAN(ONE)
      TWOPI=TWO*PI
      TWOPIM=ONE/TWOPI
      TRTPI=TWO*SQRT(PI)
      FAC1=(DIEL-ONE)/(DIEL+ONE)
      FAC2=FAC1*TWOPIM
C
      IF(IOPPRD.LT.0.OR.IOPPRD.GT.3) THEN
         CDWS= ZERO
         CSWD= ZERO
      ELSEIF(IOPPRD.EQ.0) THEN
         CDWS=-FAC2/TWO
         CSWD=-FAC2/TWO
      ELSEIF(IOPPRD.EQ.1) THEN
         CDWS= ZERO
         CSWD=-FAC2
      ELSEIF(IOPPRD.EQ.2) THEN
         CDWS=-FAC2
         CSWD= ZERO
      ELSEIF(IOPPRD.EQ.3) THEN
         CDWS=-TWOPIM*DIEL/(DIEL+ONE)
         CSWD= TWOPIM*ONE /(DIEL+ONE)
      ENDIF
C
      CALL SEQREW(NFT17)
      IF(IOPPRD.GT.0) CALL SEQREW(NFT18)
      DO I=1,NCAV
         XI=CAVC(1,I)
         YI=CAVC(2,I)
         ZI=CAVC(3,I)
         WI=CAVW(I)
C
C        FORM S*W IN S, D*W IN D
C
         SUMDW=ZERO
         DO J=1,NCAV
            IF(J.NE.I) THEN
               XJI=CAVC(1,J)-XI
               YJI=CAVC(2,J)-YI
               ZJI=CAVC(3,J)-ZI
               WJ=CAVW(J)
               RRIJ=XJI**2+YJI**2+ZJI**2
               SIJ=ONE/SQRT(RRIJ)
               S(J)=SIJ*WJ
               DOTIJ=CAVN(1,J)*XJI+CAVN(2,J)*YJI+CAVN(3,J)*ZJI
               DWIJ=-DOTIJ*SIJ**3*WJ
               D(J)=DWIJ
               SUMDW=SUMDW+DWIJ
            ENDIF
         ENDDO
         S(I)=TRTPI*FGAM(I)*SQRT(WI)
         D(I)=-(TWOPI+SUMDW)
C
C        FORM D*W*S, S*W*DSTAR, A, AT
C
         DO K=1,NCAV
            XK=CAVC(1,K)
            YK=CAVC(2,K)
            ZK=CAVC(3,K)
            WK=CAVW(K)
            DWSIK=ZERO
            SWDIK=ZERO
            SUMDW=ZERO
            DO J=1,NCAV
               IF(J.NE.K) THEN
                  XJK=CAVC(1,J)-XK
                  YJK=CAVC(2,J)-YK
                  ZJK=CAVC(3,J)-ZK
                  RRJK=XJK**2+YJK**2+ZJK**2
                  SJK=ONE/SQRT(RRJK)
                  DWSIK=DWSIK+D(J)*SJK
                  DOTKJ=CAVN(1,J)*XJK+CAVN(2,J)*YJK+CAVN(3,J)*ZJK
                  DKJ=-DOTKJ*SJK**3
                  SWDIK=SWDIK+S(J)*DKJ
                  SUMDW=SUMDW+DKJ*CAVW(J)
               ENDIF
            ENDDO
            SKK=TRTPI*FGAM(K)/SQRT(WK)
            DKK=-(TWOPI+SUMDW)/WK
            DWSIK=DWSIK+D(K)*SKK
            SWDIK=SWDIK+S(K)*DKK
            TMP=S(K)/WK
            A(K) =TMP+CDWS*DWSIK+CSWD*SWDIK
            AT(K)=TMP+CDWS*SWDIK+CSWD*DWSIK
         ENDDO
         WRITE(NFT17) A
         IF(IOPPRD.GT.0) WRITE(NFT18) AT
      ENDDO
      CALL SEQREW(NFT17)
      IF(IOPPRD.GT.0) CALL SEQREW(NFT18)
C
      RETURN
      END
C*MODULE SVPCHG  *DECK SVPSI
      SUBROUTINE SVPSI(NCAV,CAVC,CAVW,FGAM,A)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C     ----- COSMO SIGMA SYSTEM MATRIX A FORMED IN CORE -----
C
      PARAMETER (ONE=1.0D+00, TWO=2.0D+00, FOUR=4.0D+00)
      DIMENSION CAVC(3,*),CAVW(*)
      DIMENSION FGAM(*),A(NCAV,*)
C
      PI    = FOUR*ATAN(ONE)
      TRTPI = TWO*SQRT(PI)
C
      DO I=1,NCAV
         XI=CAVC(1,I)
         YI=CAVC(2,I)
         ZI=CAVC(3,I)
         IF(I.GT.1) THEN
            DO J=1,I-1
               XIJ =XI-CAVC(1,J)
               YIJ =YI-CAVC(2,J)
               ZIJ =ZI-CAVC(3,J)
               RRIJ=XIJ**2+YIJ**2+ZIJ**2
               AIJ=ONE/SQRT(RRIJ)
               A(I,J)=AIJ
               A(J,I)=AIJ
            ENDDO
         ENDIF
         A(I,I)=TRTPI*FGAM(I)/SQRT(CAVW(I))
      ENDDO
C
      RETURN
      END
C*MODULE SVPCHG  *DECK SVPSO
      SUBROUTINE SVPSO(NCAV,CAVC,CAVW,FGAM,A)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C     ----- COSMO SIGMA SYSTEM MATRIX A FORMED OUT OF CORE -----
C
      PARAMETER (ONE=1.0D+00, TWO=2.0D+00, FOUR=4.0D+00)
      DIMENSION CAVC(3,*),CAVW(*)
      DIMENSION FGAM(*),A(NCAV)
      DATA NFT17 /26/
C
      PI  = FOUR*ATAN(ONE)
      TRTPI=TWO*SQRT(PI)
C
      CALL SEQREW(NFT17)
      DO I=1,NCAV
         XI=CAVC(1,I)
         YI=CAVC(2,I)
         ZI=CAVC(3,I)
         DO J=1,NCAV
            IF(J.NE.I) THEN
               XIJ =XI-CAVC(1,J)
               YIJ =YI-CAVC(2,J)
               ZIJ =ZI-CAVC(3,J)
               RRIJ=XIJ**2+YIJ**2+ZIJ**2
               A(J)=ONE/SQRT(RRIJ)
            ENDIF
         ENDDO
         A(I)=TRTPI*FGAM(I)/SQRT(CAVW(I))
         WRITE(NFT17) A
      ENDDO
      CALL SEQREW(NFT17)
C
      RETURN
      END
C*MODULE SVPCHG  *DECK SVPFI
      SUBROUTINE SVPFI(DIEL,NCAV,CAVC,CAVW,CAVN,A)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C     ----- SPE SIGMA SYSTEM MATRIX A FORMED IN CORE -----
C
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00, TWO=2.0D+00, FOUR=4.0D+00)
      DIMENSION CAVC(3,*),CAVW(*),CAVN(3,*)
      DIMENSION A(NCAV,*)
C
      PI=FOUR*ATAN(ONE)
      TWOPI=TWO*PI
      TWOPIM=ONE/TWOPI
      FAC1=(DIEL-ONE)/(DIEL+ONE)
      FAC2=FAC1*TWOPIM
C
      DO J=1,NCAV
         XJ=CAVC(1,J)
         YJ=CAVC(2,J)
         ZJ=CAVC(3,J)
         WJ=CAVW(J)
         SUM=ZERO
         DO I=1,NCAV
            IF(I.NE.J) THEN
               XIJ=CAVC(1,I)-XJ
               YIJ=CAVC(2,I)-YJ
               ZIJ=CAVC(3,I)-ZJ
               RRIJ=XIJ**2+YIJ**2+ZIJ**2
               RRIJ32=ONE/(RRIJ*SQRT(RRIJ))
               DOTI=CAVN(1,I)*XIJ+CAVN(2,I)*YIJ+CAVN(3,I)*ZIJ
               DSTRIJ=-DOTI*RRIJ32
               A(I,J)=-FAC2*DSTRIJ
               SUM=SUM+CAVW(I)*DSTRIJ
            ENDIF
         ENDDO
         DSTRJJ=-(TWOPI+SUM)/WJ
         A(J,J)=ONE/WJ-FAC2*DSTRJJ
      ENDDO
C
      RETURN
      END
C*MODULE SVPCHG  *DECK SVPFO
      SUBROUTINE SVPFO(DIEL,NCAV,CAVC,CAVW,CAVN,A,AT)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C     ----- SPE SIGMA SYSTEM MATRIX A FORMED OUT OF CORE -----
C
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00, TWO=2.0D+00, FOUR=4.0D+00)
      DIMENSION CAVC(3,*),CAVW(*),CAVN(3,*)
      DIMENSION A(NCAV),AT(NCAV)
      DATA NFT17 /26/
      DATA NFT18 /27/
C
      PI=FOUR*ATAN(ONE)
      TWOPI=TWO*PI
      TWOPIM=ONE/TWOPI
      FAC1=(DIEL-ONE)/(DIEL+ONE)
      FAC2=FAC1*TWOPIM
C
      CALL SEQREW(NFT17)
      CALL SEQREW(NFT18)
      DO I=1,NCAV
         XI=CAVC(1,I)
         YI=CAVC(2,I)
         ZI=CAVC(3,I)
         WI=CAVW(I)
         XNORI=CAVN(1,I)
         YNORI=CAVN(2,I)
         ZNORI=CAVN(3,I)
         SUM=ZERO
         DO J=1,NCAV
            IF(J.NE.I) THEN
               XIJ=XI-CAVC(1,J)
               YIJ=YI-CAVC(2,J)
               ZIJ=ZI-CAVC(3,J)
               RRIJ=XIJ**2+YIJ**2+ZIJ**2
               RRIJ32=ONE/(RRIJ*SQRT(RRIJ))
               DOTI=XNORI*XIJ+YNORI*YIJ+ZNORI*ZIJ
               DSTRIJ=-DOTI*RRIJ32
               A(J)=-FAC2*DSTRIJ
               DOTJ=CAVN(1,J)*XIJ+CAVN(2,J)*YIJ+CAVN(3,J)*ZIJ
               DSTRJI=DOTJ*RRIJ32
               AT(J)=-FAC2*DSTRJI
               SUM=SUM+CAVW(J)*DSTRJI
            ENDIF
         ENDDO
         DSTRII=-(TWOPI+SUM)/WI
         AII=ONE/WI-FAC2*DSTRII
         A(I)=AII
         AT(I)=AII
         WRITE(NFT17) A
         WRITE(NFT18) AT
      ENDDO
      CALL SEQREW(NFT17)
      CALL SEQREW(NFT18)
C
      RETURN
      END
C*MODULE SVPCHG  *DECK SVPGI
      SUBROUTINE SVPGI(DIEL,NCAV,CAVC,CAVW,CAVN,A)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C     ----- SS(V)PE MU SYSTEM MATRIX A FORMED IN CORE -----
C
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00, TWO=2.0D+00, FOUR=4.0D+00)
      DIMENSION CAVC(3,*),CAVW(*),CAVN(3,*)
      DIMENSION A(NCAV,*)
C
      PI=FOUR*ATAN(ONE)
      TWOPI=TWO*PI
      TWOPIM=ONE/TWOPI
      FAC1=(DIEL-ONE)/(DIEL+ONE)
      FAC2=FAC1*TWOPIM
C
      DO J=1,NCAV
         XJ=CAVC(1,J)
         YJ=CAVC(2,J)
         ZJ=CAVC(3,J)
         WJ=CAVW(J)
         SUM=ZERO
         DO I=1,NCAV
            IF(I.NE.J) THEN
               XIJ=CAVC(1,I)-XJ
               YIJ=CAVC(2,I)-YJ
               ZIJ=CAVC(3,I)-ZJ
               RRIJ=XIJ**2+YIJ**2+ZIJ**2
               RRIJ32=ONE/(RRIJ*SQRT(RRIJ))
               DOTI=CAVN(1,I)*XIJ+CAVN(2,I)*YIJ+CAVN(3,I)*ZIJ
               DJI=-DOTI*RRIJ32
               A(J,I)=-FAC2*DJI
               SUM=SUM+CAVW(I)*DJI
            ENDIF
         ENDDO
         DJJ=-(TWOPI+SUM)/WJ
         A(J,J)=ONE/WJ-FAC2*DJJ
      ENDDO
C
      RETURN
      END
C*MODULE SVPCHG  *DECK SVPGO
      SUBROUTINE SVPGO(DIEL,NCAV,CAVC,CAVW,CAVN,A,AT)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C     ----- SS(V)PE MU SYSTEM MATRIX A FORMED OUT OF CORE -----
C
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00, TWO=2.0D+00, FOUR=4.0D+00)
      DIMENSION CAVC(3,*),CAVW(*),CAVN(3,*)
      DIMENSION A(NCAV),AT(NCAV)
      DATA NFT17 /26/
      DATA NFT18 /27/
C
      PI=FOUR*ATAN(ONE)
      TWOPI=TWO*PI
      TWOPIM=ONE/TWOPI
      FAC1=(DIEL-ONE)/(DIEL+ONE)
      FAC2=FAC1*TWOPIM
C
      CALL SEQREW(NFT17)
      CALL SEQREW(NFT18)
      DO I=1,NCAV
         XI=CAVC(1,I)
         YI=CAVC(2,I)
         ZI=CAVC(3,I)
         WI=CAVW(I)
         XNORI=CAVN(1,I)
         YNORI=CAVN(2,I)
         ZNORI=CAVN(3,I)
         SUM=ZERO
         DO J=1,NCAV
            IF(J.NE.I) THEN
               XIJ=XI-CAVC(1,J)
               YIJ=YI-CAVC(2,J)
               ZIJ=ZI-CAVC(3,J)
               RRIJ=XIJ**2+YIJ**2+ZIJ**2
               RRIJ32=ONE/(RRIJ*SQRT(RRIJ))
               DOTJ=CAVN(1,J)*XIJ+CAVN(2,J)*YIJ+CAVN(3,J)*ZIJ
               DIJ=DOTJ*RRIJ32
               A(J)=-FAC2*DIJ
               DOTI=XNORI*XIJ+YNORI*YIJ+ZNORI*ZIJ
               DJI=-DOTI*RRIJ32
               AT(J)=-FAC2*DJI
               SUM=SUM+CAVW(J)*DIJ
            ENDIF
         ENDDO
         DII=-(TWOPI+SUM)/WI
         AII=ONE/WI-FAC2*DII
         A(I)=AII
         AT(I)=AII
         WRITE(NFT17) A
         WRITE(NFT18) AT
      ENDDO
      CALL SEQREW(NFT17)
      CALL SEQREW(NFT18)
C
      RETURN
      END
C*MODULE SVPCHG  *DECK SVPMI
      SUBROUTINE SVPMI(NCAV,CAVC,CAVW,CAVN,A)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C     ----- COSMO MU SYSTEM MATRIX A FORMED IN CORE -----
C
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00, TWO=2.0D+00, FOUR=4.0D+00)
      DIMENSION CAVC(3,*),CAVW(*),CAVN(3,*)
      DIMENSION A(NCAV,*)
C
      PI=FOUR*ATAN(ONE)
      TWOPI=TWO*PI
      TWOPIM=ONE/TWOPI
C
      DO J=1,NCAV
         XJ=CAVC(1,J)
         YJ=CAVC(2,J)
         ZJ=CAVC(3,J)
         WJ=CAVW(J)
         SUM=ZERO
         DO I=1,NCAV
            IF(I.NE.J) THEN
               XIJ=CAVC(1,I)-XJ
               YIJ=CAVC(2,I)-YJ
               ZIJ=CAVC(3,I)-ZJ
               RRIJ=XIJ**2+YIJ**2+ZIJ**2
               RRIJ32=ONE/(RRIJ*SQRT(RRIJ))
               DOTI=CAVN(1,I)*XIJ+CAVN(2,I)*YIJ+CAVN(3,I)*ZIJ
               DJI=-DOTI*RRIJ32
               A(J,I)=-TWOPIM*DJI
               SUM=SUM+CAVW(I)*DJI
            ENDIF
         ENDDO
         DJJ=-(TWOPI+SUM)/WJ
         A(J,J)=ONE/WJ-TWOPIM*DJJ
      ENDDO
C
      RETURN
      END
C*MODULE SVPCHG  *DECK SVPMO
      SUBROUTINE SVPMO(NCAV,CAVC,CAVW,CAVN,A,AT)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C     ----- SS(V)PE MU SYSTEM MATRIX A FORMED OUT OF CORE -----
C
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00, TWO=2.0D+00, FOUR=4.0D+00)
      DIMENSION CAVC(3,*),CAVW(*),CAVN(3,*)
      DIMENSION A(NCAV),AT(NCAV)
      DATA NFT17 /26/
      DATA NFT18 /27/
C
      PI=FOUR*ATAN(ONE)
      TWOPI=TWO*PI
      TWOPIM=ONE/TWOPI
C
      CALL SEQREW(NFT17)
      CALL SEQREW(NFT18)
      DO I=1,NCAV
         XI=CAVC(1,I)
         YI=CAVC(2,I)
         ZI=CAVC(3,I)
         WI=CAVW(I)
         XNORI=CAVN(1,I)
         YNORI=CAVN(2,I)
         ZNORI=CAVN(3,I)
         SUM=ZERO
         DO J=1,NCAV
            IF(J.NE.I) THEN
               XIJ=XI-CAVC(1,J)
               YIJ=YI-CAVC(2,J)
               ZIJ=ZI-CAVC(3,J)
               RRIJ=XIJ**2+YIJ**2+ZIJ**2
               RRIJ32=ONE/(RRIJ*SQRT(RRIJ))
               DOTJ=CAVN(1,J)*XIJ+CAVN(2,J)*YIJ+CAVN(3,J)*ZIJ
               DIJ=DOTJ*RRIJ32
               A(J)=-TWOPIM*DIJ
               DOTI=XNORI*XIJ+YNORI*YIJ+ZNORI*ZIJ
               DJI=-DOTI*RRIJ32
               AT(J)=-TWOPIM*DJI
               SUM=SUM+CAVW(J)*DIJ
            ENDIF
         ENDDO
         DII=-(TWOPI+SUM)/WI
         AII=ONE/WI-TWOPIM*DII
         A(I)=AII
         AT(I)=AII
         WRITE(NFT17) A
         WRITE(NFT18) AT
      ENDDO
      CALL SEQREW(NFT17)
      CALL SEQREW(NFT18)
C
      RETURN
      END
C*MODULE SVPCHG  *DECK SVPDII
      SUBROUTINE SVPDII(DIEL,NCAV,CAVC,CAVW,CAVN,A,WD,D)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C     ----- SPE MU SYSTEM MATRIX A FORMED ENTIRELY IN CORE -----
C
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00, TWO=2.0D+00, FOUR=4.0D+00)
      DIMENSION CAVC(3,*),CAVW(*),CAVN(3,*)
      DIMENSION A(NCAV,*),WD(NCAV,*),D(*)
C
      PI=FOUR*ATAN(ONE)
      TWOPI=TWO*PI
      TWOPIM=ONE/TWOPI
      FAC1=(DIEL-ONE)/(DIEL+ONE)
      FAC3=FAC1*TWOPIM**2
      FAC6=(TWO*DIEL/(DIEL+ONE))*TWOPIM
C
      DO I=1,NCAV
         XI=CAVC(1,I)
         YI=CAVC(2,I)
         ZI=CAVC(3,I)
         WI=CAVW(I)
         SUMDW=ZERO
         DO J=1,NCAV
            IF(J.NE.I) THEN
               XJI=CAVC(1,J)-XI
               YJI=CAVC(2,J)-YI
               ZJI=CAVC(3,J)-ZI
               WJ=CAVW(J)
               RRIJ=XJI**2+YJI**2+ZJI**2
               DOTIJ=CAVN(1,J)*XJI+CAVN(2,J)*YJI+CAVN(3,J)*ZJI
               DIJ=-DOTIJ/(RRIJ*SQRT(RRIJ))
               A(I,J)=DIJ
               WD(I,J)=WI*DIJ
               SUMDW=SUMDW+DIJ*WJ
            ENDIF
         ENDDO
         WDII=-(TWOPI+SUMDW)
         WD(I,I)=WDII
         A(I,I)=WDII/WI
      ENDDO
C
      DO I=1,NCAV
         DO J=1,NCAV
            D(J)=A(I,J)
         ENDDO
         DO K=1,NCAV
            DWDIK=ZERO
            DO J=1,NCAV
               DWDIK=DWDIK+D(J)*WD(J,K)
            ENDDO
            A(I,K)=-FAC6*A(I,K)+FAC3*DWDIK
         ENDDO
         A(I,I)=ONE/CAVW(I)+A(I,I)
      ENDDO
C
      RETURN
      END
C*MODULE SVPCHG  *DECK SVPDIO
      SUBROUTINE SVPDIO(DIEL,NCAV,CAVC,CAVW,CAVN,A,DW,DSTR)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C     ----- SPE MU SYSTEM MATRIX A FORMED PARTAILLY IN CORE -----
C
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00, TWO=2.0D+00, FOUR=4.0D+00)
      DIMENSION CAVC(3,*),CAVW(*),CAVN(3,*)
      DIMENSION A(NCAV,*),DW(*),DSTR(*)
C
      PI=FOUR*ATAN(ONE)
      TWOPI=TWO*PI
      TWOPIM=ONE/TWOPI
      FAC1=(DIEL-ONE)/(DIEL+ONE)
      FAC3=FAC1*TWOPIM**2
      FAC6=(TWO*DIEL/(DIEL+ONE))*TWOPIM
C
      DO I=1,NCAV
         XI=CAVC(1,I)
         YI=CAVC(2,I)
         ZI=CAVC(3,I)
         WI=CAVW(I)
         XNORI=CAVN(1,I)
         YNORI=CAVN(2,I)
         ZNORI=CAVN(3,I)
         SUMDW=ZERO
         DO J=1,NCAV
            IF(J.NE.I) THEN
               XJI=CAVC(1,J)-XI
               YJI=CAVC(2,J)-YI
               ZJI=CAVC(3,J)-ZI
               WJ=CAVW(J)
               RRIJ=XJI**2+YJI**2+ZJI**2
               RRIJ32=ONE/(RRIJ*SQRT(RRIJ))
               DOTIJ=CAVN(1,J)*XJI+CAVN(2,J)*YJI+CAVN(3,J)*ZJI
               DWIJ=-DOTIJ*WJ*RRIJ32
               DW(J)=DWIJ
               SUMDW=SUMDW+DWIJ
               DOTJI=-XNORI*XJI-YNORI*YJI-ZNORI*ZJI
               DSTR(J)=-DOTJI*RRIJ32
            ENDIF
         ENDDO
         DWI=-(TWOPI+SUMDW)
         DW(I)=DWI
         DSTR(I)=DWI/WI
C
         DO K=1,NCAV
            XK=CAVC(1,K)
            YK=CAVC(2,K)
            ZK=CAVC(3,K)
            SUM=ZERO
            DWDKI=ZERO
            DO J=1,NCAV
               IF(J.NE.K) THEN
                  XKJ=XK-CAVC(1,J)
                  YKJ=YK-CAVC(2,J)
                  ZKJ=ZK-CAVC(3,J)
                  WJ=CAVW(J)
                  RRKJ=XKJ**2+YKJ**2+ZKJ**2
                  RRKJ32=ONE/(RRKJ*SQRT(RRKJ))
                  DOTKJ=CAVN(1,J)*XKJ+CAVN(2,J)*YKJ+CAVN(3,J)*ZKJ
                  DKJ=DOTKJ*RRKJ32
                  DWDKI=DWDKI+DKJ*WJ*DSTR(J)
                  SUM=SUM+DKJ*WJ
               ENDIF
            ENDDO
            DWKK=-(TWOPI+SUM)
            DWDKI=DWDKI+DWKK*DSTR(K)
            A(K,I)=-FAC6*DSTR(K)+FAC3*DWDKI
         ENDDO
         TMP=ONE/WI
         A(I,I)=TMP+A(I,I)
      ENDDO
C
      RETURN
      END
C*MODULE SVPCHG  *DECK SVPDOO
      SUBROUTINE SVPDOO(DIEL,NCAV,CAVC,CAVW,CAVN,A,AT,DW,DSTR)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C     ----- SPE MU SYSTEM MATRIX A FORMED OUT OF CORE -----
C
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00, TWO=2.0D+00, FOUR=4.0D+00)
      DIMENSION CAVC(3,*),CAVW(*),CAVN(3,*)
      DIMENSION A(NCAV),AT(NCAV),DW(*),DSTR(*)
      DATA NFT17 /26/
      DATA NFT18 /27/
C
      PI=FOUR*ATAN(ONE)
      TWOPI=TWO*PI
      TWOPIM=ONE/TWOPI
      FAC1=(DIEL-ONE)/(DIEL+ONE)
      FAC3=FAC1*TWOPIM**2
      FAC6=(TWO*DIEL/(DIEL+ONE))*TWOPIM
C
      CALL SEQREW(NFT17)
      CALL SEQREW(NFT18)
      DO I=1,NCAV
         XI=CAVC(1,I)
         YI=CAVC(2,I)
         ZI=CAVC(3,I)
         WI=CAVW(I)
         XNORI=CAVN(1,I)
         YNORI=CAVN(2,I)
         ZNORI=CAVN(3,I)
         SUMDW=ZERO
         DO J=1,NCAV
            IF(J.NE.I) THEN
               XJI=CAVC(1,J)-XI
               YJI=CAVC(2,J)-YI
               ZJI=CAVC(3,J)-ZI
               WJ=CAVW(J)
               RRIJ=XJI**2+YJI**2+ZJI**2
               RRIJ32=ONE/(RRIJ*SQRT(RRIJ))
               DOTIJ=CAVN(1,J)*XJI+CAVN(2,J)*YJI+CAVN(3,J)*ZJI
               DWIJ=-DOTIJ*WJ*RRIJ32
               DW(J)=DWIJ
               SUMDW=SUMDW+DWIJ
               DOTJI=-XNORI*XJI-YNORI*YJI-ZNORI*ZJI
               DSTR(J)=-DOTJI*RRIJ32
            ENDIF
         ENDDO
         DWI=-(TWOPI+SUMDW)
         DW(I)=DWI
         DSTR(I)=DWI/WI
C
         DO K=1,NCAV
            XK=CAVC(1,K)
            YK=CAVC(2,K)
            ZK=CAVC(3,K)
            WK=CAVW(K)
            XNORK=CAVN(1,K)
            YNORK=CAVN(2,K)
            ZNORK=CAVN(3,K)
            SUM=ZERO
            DWDIK=ZERO
            DWDKI=ZERO
            DO J=1,NCAV
               IF(J.NE.K) THEN
                  XKJ=XK-CAVC(1,J)
                  YKJ=YK-CAVC(2,J)
                  ZKJ=ZK-CAVC(3,J)
                  WJ=CAVW(J)
                  RRKJ=XKJ**2+YKJ**2+ZKJ**2
                  RRKJ32=ONE/(RRKJ*SQRT(RRKJ))
                  DOTJK=XNORK*XKJ+YNORK*YKJ+ZNORK*ZKJ
                  DJK=-DOTJK*RRKJ32
                  DWDIK=DWDIK+DW(J)*DJK
                  DOTKJ=CAVN(1,J)*XKJ+CAVN(2,J)*YKJ+CAVN(3,J)*ZKJ
                  DKJ=DOTKJ*RRKJ32
                  DWDKI=DWDKI+DKJ*WJ*DSTR(J)
                  SUM=SUM+DKJ*WJ
               ENDIF
            ENDDO
            DWKK=-(TWOPI+SUM)
            DKK=DWKK/WK
            DWK=DW(K)
            DWDIK=DWDIK+DWK*DKK
            DWDKI=DWDKI+DWKK*DSTR(K)
            A(K)=-FAC6*DWK/WK+FAC3*DWDIK
            AT(K)=-FAC6*DSTR(K)+FAC3*DWDKI
         ENDDO
         TMP=ONE/WI
         A(I)=TMP+A(I)
         AT(I)=TMP+AT(I)
         WRITE(NFT17) A
         WRITE(NFT18) AT
      ENDDO
      CALL SEQREW(NFT17)
      CALL SEQREW(NFT18)
C
      RETURN
      END
C*MODULE SVPCHG  *DECK SVPEQU
      SUBROUTINE SVPEQU(IADDR,ILAST,LINEQ,CVGLIN,NCAV,SYMMA,
     1                  INCORA,INCORT,B,A,AT,Q)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C     ----- SOLVE SYSTEM EQUATION A * Q = B -----
C
      PARAMETER (ZERO=0.0D+00)
      LOGICAL     DBUG
      LOGICAL     MORE
      LOGICAL     OUT
      LOGICAL     SOME
      LOGICAL     SYMMA,INCORA,INCORT
      CHARACTER*4 KEYBLK,KEYFST,IFIRST
      COMMON /FMCOM / X(1)
      COMMON /IOFILE/ IR,IW,IP,IJK,IJKT,IDAF,NAV,IODA(950)
      COMMON/SVPDBG/IDBG
C
      DIMENSION   B(*),A(*),AT(*),Q(*)
      EXTERNAL    SVPAXI,SVPXAI,SVPAXO,SVPXAO
      DATA NFT17 /26/
      DATA NFT18 /27/
      DATA KEYBLK /'    '/
      DATA KEYFST /'FRST'/
      DATA IFIRST /'FRST'/
      SAVE IFIRST
C
      DBUG=.FALSE.
      DBUG=DBUG.OR.IDBG.GE.4
      MORE=.FALSE.
      MORE=MORE.OR.DBUG.OR.IDBG.GE.3
      OUT =.FALSE.
      OUT =OUT.OR.MORE.OR.IDBG.GE.2
      SOME=.FALSE.
      SOME=SOME.OR.OUT.OR.IDBG.GE.1
C
C     AT SPACE NEEDED FOR A(TRANSPOSE) WHEN A IS NONSYMMETRIC
C     IS USED ONLY IN CALL TO SVPEQG WHEN BOTH A AND AT ARE IN CORE
C
      IF(LINEQ.EQ.0) THEN
C
C     ----- SOLVE BY LU DECOMPOSITION IN CORE -----
C
         IF(.NOT.INCORA) THEN
            WRITE(IW,*) 'LINEQ=0 REQUESTED BUT MATRIX NOT IN CORE. STOP'
            CALL ABRT
         ENDIF
         I10=IADDR
         I20=I10+NCAV
         I30=I20+NCAV
         LAST=I30-1
         IF(LAST.GT.ILAST) THEN
            NEED=LAST-ILAST
            WRITE(IW,*) 'NOT ENOUGH MEMORY FOR LINEQ=0. STOP'
            WRITE(IW,*) 'IADDR = ',IADDR
            WRITE(IW,*) 'ILAST = ',ILAST
            WRITE(IW,*) 'I10   = ',I10
            WRITE(IW,*) 'LAST  = ',LAST
            WRITE(IW,*) 'ADDITIONAL WORDS NEEDED =',NEED
            CALL ABRT
         ENDIF
         DO I=1,NCAV
            Q(I)=B(I)
         ENDDO
         NODCMP=1
         CALL SVPEQL(A,NCAV,Q,NCAV,X(I10),X(I20),IERR,NODCMP)
C
      ELSEIF(LINEQ.EQ.1) THEN
C
C     ----- SOLVE BY CONJUGATE GRADIENT ITERATIONS IN CORE -----
C
         IF(.NOT.INCORA) THEN
            WRITE(IW,*) 'LINEQ=1 REQUESTED BUT MATRIX NOT IN CORE. STOP'
            CALL ABRT
         ENDIF
         I10=IADDR
         I20=I10+NCAV
         I30=I20+NCAV
         I40=I30+NCAV
         I50=I40+NCAV
         LAST=I50-1
         IF(LAST.GT.ILAST) THEN
            NEED=LAST-ILAST
            WRITE(IW,*) 'NOT ENOUGH MEMORY FOR LINEQ=1. STOP'
            WRITE(IW,*) 'IADDR = ',IADDR
            WRITE(IW,*) 'ILAST = ',ILAST
            WRITE(IW,*) 'I10   = ',I10
            WRITE(IW,*) 'LAST  = ',LAST
            WRITE(IW,*) 'ADDITIONAL WORDS NEEDED =',NEED
            CALL ABRT
         ENDIF
         IF(.NOT.SYMMA.AND..NOT.INCORT.AND.IFIRST.EQ.KEYFST) THEN
            WRITE(IW,9999)
         ENDIF
         IF(SYMMA) THEN
            CALL SVPEQG(B,Q,A,A,NCAV,
     1                  X(I10),X(I20),X(I30),X(I40),
     2                  SVPXAI,SVPXAI,CVGLIN)
         ELSE
            IF(INCORT) THEN
               CALL SVPEQG(B,Q,A,AT,NCAV,
     1                  X(I10),X(I20),X(I30),X(I40),
     2                  SVPXAI,SVPXAI,CVGLIN)
            ELSE
C                 THIS BRANCH USING SVPAXI MAY HAVE SERIOUS PAGING PROBL
                     CALL SVPEQG(B,Q,A,A,NCAV,
     1                     X(I10),X(I20),X(I30),X(I40),
     2                     SVPAXI,SVPXAI,CVGLIN)
            ENDIF
         ENDIF
      ELSEIF(LINEQ.EQ.2) THEN
C
C     ----- SOLVE BY CONJUGATE GRADIENT ITERATIONS OUT OF CORE -----
C
         I10=IADDR
         I20=I10+NCAV
         I30=I20+NCAV
         I40=I30+NCAV
         I50=I40+NCAV
         LAST=I50-1
         IF(LAST.GT.ILAST) THEN
            NEED=LAST-ILAST
            WRITE(IW,*) 'NOT ENOUGH MEMORY FOR LINEQ=2. STOP'
            WRITE(IW,*) 'IADDR = ',IADDR
            WRITE(IW,*) 'ILAST = ',ILAST
            WRITE(IW,*) 'I10   = ',I10
            WRITE(IW,*) 'LAST  = ',LAST
            WRITE(IW,*) 'ADDITIONAL WORDS NEEDED =',NEED
            CALL ABRT
         ENDIF
         DO I=1,NCAV
            Q(I)=ZERO
         ENDDO
C
C        IF SYSTEM MATRIX IS IN CORE, THEN WRITE IT OUT
C
         IF(INCORA) THEN
            CALL SEQREW(NFT17)
            DO I=1,NCAV
               WRITE(NFT17) (A(I+(J-1)*NCAV),J=1,NCAV)
            ENDDO
            CALL SEQREW(NFT17)
         ENDIF
C
C        IF NONSYMMETRIC, THEN ALSO WRITE OUT ITS TRANSPOSE
C
         IF(.NOT.SYMMA.AND.INCORA) THEN
            CALL SEQREW(NFT18)
            DO I=1,NCAV
               WRITE(NFT18) (A(J+(I-1)*NCAV),J=1,NCAV)
            ENDDO
            CALL SEQREW(NFT18)
         ENDIF
         IF(SYMMA) THEN
            CALL SVPEQG(B,Q,A,A,NCAV,
     1                  X(I10),X(I20),X(I30),X(I40),
     2                  SVPAXO,SVPAXO,CVGLIN)
         ELSE
            CALL SVPEQG(B,Q,A,A,NCAV,
     1                  X(I10),X(I20),X(I30),X(I40),
     2                  SVPAXO,SVPXAO,CVGLIN)
         ENDIF
      ENDIF
      IF(MORE) THEN
         WRITE(IW,*) '-Q-'
         CALL PRSQ(Q,1,NCAV,NCAV)
      ENDIF
C
      IFIRST=KEYBLK
      RETURN
 9999 FORMAT('WARNING: TRANSPOSE OF NONSYMMETRIC MATRIX NOT IN CORE ',
     1       'MAY CAUSE SERIOUS PAGING PROBLEMS FOR LINEQ=1 SOLUTION',
     2       ' OF SVP SYSTEM EQUATION')
      END
C*MODULE SVPCHG  *DECK SVPEQL
      SUBROUTINE SVPEQL(A,LDA,B,N,IB,T,     IERR,NODCMP)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION A(LDA,1),B(N),IB(N),T(N)
C
C     ----- SOLVE A * X = B WITH AN LU DECOMPOSITION METHOD -----
C     ----- A AND B ARE BOTH CHEWED UP; X IS RETURNED IN B  -----
C
      IF(NODCMP.NE.1) GO TO 20
      CALL LUDCMP(A,LDA,N,IB,T,DETA,IERR)
C
   20 CONTINUE
      CALL LUBKSB(A,LDA,N,IB,B)
C
      RETURN
      END
C*MODULE SVPCHG  *DECK SVPEQG
      SUBROUTINE SVPEQG(B,X,A,AT,N,G,H,XI,XJ,SVPAX,SVPXA,CVGLIN)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C     ----- SOLVE A * X = B WITH AN ITERATIVE CONJUGATE GRADIENT METHOD
C
C     ----- NUMERICAL RECIPES (P.70), CAMBRIDGE UNIVERSITY PRESS -----
C          W.H.PRESS, B.P.FLANNERY, S.A.TEUKOLSKY, W.T.VETTERLING
C
C     ----- MODIFIED BY DMC TO INVOKE AT=A(TRANSPOSE) FOR BETTER PAGING
C
      PARAMETER (ZERO=0.0D+00)
      LOGICAL DBUG
C
      COMMON /IOFILE/ IR,IW,IP,IJK,IJKT,IDAF,NAV,IODA(950)
      COMMON/SVPDBG/IDBG
C
      DIMENSION   A(N),AT(N),X(N),B(N)
      DIMENSION   G(N),H(N),XI(N),XJ(N)
C
      EXTERNAL    SVPAX,SVPXA
C
      DATA EPS    /1.0D-07/
C
      DBUG=.FALSE.
      DBUG=DBUG.OR.IDBG.GE.4
      IF(DBUG) THEN
         WRITE(IW,*) 'IN -SVPEQG-'
         DO I=1,N
            WRITE(IW,9999) I,B(I)
         ENDDO
      ENDIF
C
      EPS=CVGLIN
      EPS2=N*EPS*EPS
      IRST=0
   10 IRST=IRST+1
      CALL SVPAX(AT,X,XI,N)
      RP=ZERO
      BSQ=ZERO
      DO 11 J=1,N
         BSQ=BSQ+B(J)*B(J)
         XI(J)=XI(J)-B(J)
         RP=RP+XI(J)*XI(J)
   11 CONTINUE
      CALL SVPXA(A,XI,G,N)
      DO 12 J=1,N
      G(J)=-G(J)
      H(J)= G(J)
   12 CONTINUE
      DO 19 ITER=1,10*N
         CALL SVPAX(AT,H,XI,N)
         ANUM=ZERO
         ADEN=ZERO
         DO 13 J=1,N
            ANUM=ANUM+G(J)*H(J)
            ADEN=ADEN+XI(J)*XI(J)
   13    CONTINUE
         IF(ADEN.EQ.ZERO) THEN
            WRITE(IW,*) 'VERY SINGULAR MATRIX'
            CALL ABRT
         ENDIF
         ANUM=ANUM/ADEN
         DO 14 J=1,N
            XI(J)=X(J)
            X(J)=X(J)+ANUM*H(J)
   14    CONTINUE
         CALL SVPAX(AT,X,XJ,N)
         RSQ=ZERO
         DO 15 J=1,N
            XJ(J)=XJ(J)-B(J)
            RSQ=RSQ+XJ(J)*XJ(J)
   15    CONTINUE
         IF(RSQ.EQ.RP.OR.RSQ.LE.BSQ*EPS2) RETURN
         IF(RSQ.GT.RP) THEN
            DO 16 J=1,N
               X(J)=XI(J)
   16       CONTINUE
            IF(IRST.GE.3) RETURN
            GO TO 10
         ENDIF
         RP=RSQ
         CALL SVPXA(A,XJ,XI,N)
         GG=ZERO
         DGG=ZERO
         DO 17 J=1,N
            GG=GG+G(J)*G(J)
            DGG=DGG+(XI(J)+G(J))*XI(J)
   17    CONTINUE
         IF(GG.EQ.ZERO) RETURN
         GAM=DGG/GG
         DO 18 J=1,N
            G(J)=-XI(J)
            H(J)=G(J)+GAM*H(J)
   18    CONTINUE
   19 CONTINUE
      WRITE(IW,*) 'TOO MANY ITERATIONS'
      CALL ABRT
      RETURN
 9999 FORMAT(I8,F16.8)
      END
C*MODULE SVPCHG  *DECK SVPAXI
      SUBROUTINE SVPAXI(A,X,AX,N)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (ZERO=0.0D+00)
      DIMENSION A(N,N),X(N),AX(N)
C
C     THIS ROUTINE HAS SERIOUS PAGING PROBLEMS WITH LARGE N
C
      DO I=1,N
         DUM=ZERO
         DO J=1,N
            AIJ=A(I,J)
             XJ=X(J)
            DUM=DUM+AIJ*XJ
         ENDDO
         AX(I)=DUM
      ENDDO
C
      RETURN
      END
C*MODULE SVPCHG  *DECK SVPXAI
      SUBROUTINE SVPXAI(A,X,XA,N)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (ZERO=0.0D+00)
      DIMENSION A(N,N),X(N),XA(N)
C
      DO I=1,N
         DUM=ZERO
         DO J=1,N
             AJI=A(J,I)
             XJ=X(J)
            DUM=DUM+XJ*AJI
         ENDDO
         XA(I)=DUM
      ENDDO
C
      RETURN
      END
C*MODULE SVPCHG  *DECK SVPAXO
      SUBROUTINE SVPAXO(A,X,AX,N)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (ZERO=0.0D+00)
      DIMENSION A(N),X(N),AX(N)
      DATA NFT17 /26/
C
      CALL SEQREW(NFT17)
      DO I=1,N
         READ(NFT17) A
         DUM=ZERO
         DO J=1,N
            AIJ=A(J)
             XJ=X(J)
            DUM=DUM+AIJ*XJ
         ENDDO
         AX(I)=DUM
      ENDDO
      CALL SEQREW(NFT17)
C
      RETURN
      END
C*MODULE SVPCHG  *DECK SVPXAO
      SUBROUTINE SVPXAO(AT,X,XA,N)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (ZERO=0.0D+00)
      DIMENSION AT(N),X(N),XA(N)
      DATA NFT18 /27/
C
      CALL SEQREW(NFT18)
      DO I=1,N
         READ(NFT18) AT
         DUM=ZERO
         DO J=1,N
             AJI=AT(J)
             XJ=X(J)
            DUM=DUM+XJ*AJI
         ENDDO
         XA(I)=DUM
      ENDDO
      CALL SEQREW(NFT18)
C
      RETURN
      END
C*MODULE SVPCHG  *DECK SVPENR
      SUBROUTINE SVPENR(NCAV,IQP,CAVC,CAVQ,CAVN,CAVP,ELP,ELF,
     1                  ATMSVP,ELCSVP,SVPSVP,SURSVP)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C     ----- REACTION FIELD ENERGY -----
C
      PARAMETER (ZERO=0.0D+00, TWO=2.0D+00, TENM3=1.0D-03)
      PARAMETER  (MXATM=2000)
      LOGICAL    OUT
      COMMON /IOFILE/ IR,IW,IP,IJK,IJKT,IDAF,NAV,IODA(950)
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON/SVPDBG/IDBG
      DIMENSION CAVC(3,*),CAVQ(*),CAVN(3,*),CAVP(*),ELP(*),ELF(*)
C
      OUT =.TRUE.
      OUT =OUT.OR.IDBG.GE.2
C
      SURSVP=ZERO
      ATMSVP=ZERO
      ELCSVP=ZERO
      SVPSVP=ZERO
      IF(IQP.EQ.0.OR.IQP.EQ.2) THEN
         DO JPT=1,NCAV
            XJ=CAVC(1,JPT)
            YJ=CAVC(2,JPT)
            ZJ=CAVC(3,JPT)
            QJ=CAVQ(JPT)
            SURSVP=SURSVP+QJ*ELP(JPT)
            DO IAT=1,NAT
               XJN=XJ-C(1,IAT)
               YJN=YJ-C(2,IAT)
               ZJN=ZJ-C(3,IAT)
               QN=ZAN(IAT)
               RJN=SQRT(XJN*XJN+YJN*YJN+ZJN*ZJN)
               ATMSVP=ATMSVP+QJ*QN/RJN
            ENDDO
            DO IPT=1,NCAV
               XI=CAVC(1,IPT)
               YI=CAVC(2,IPT)
               ZI=CAVC(3,IPT)
               QI=CAVQ(IPT)
               IF(IPT.NE.JPT) THEN
                  RIJ=SQRT((XI-XJ)**2+(YI-YJ)**2+(ZI-ZJ)**2)
                  SVPSVP=SVPSVP+QI*QJ/RIJ
               ENDIF
            ENDDO
         ENDDO
      ENDIF
      IF(IQP.EQ.1.OR.IQP.EQ.2) THEN
         DO JPT=1,NCAV
            XJ=CAVC(1,JPT)
            YJ=CAVC(2,JPT)
            ZJ=CAVC(3,JPT)
            DIPJ=CAVP(JPT)
            XNORJ=CAVN(1,JPT)
            YNORJ=CAVN(2,JPT)
            ZNORJ=CAVN(3,JPT)
            SURSVP=SURSVP-DIPJ*ELF(JPT)
            DO IAT=1,NAT
               XJN=XJ-C(1,IAT)
               YJN=YJ-C(2,IAT)
               ZJN=ZJ-C(3,IAT)
               QN=ZAN(IAT)
               RJN=SQRT(XJN*XJN+YJN*YJN+ZJN*ZJN)
               IF(RJN.GT.TENM3) THEN
                  DIPN=QN*(XNORJ*XJN+YNORJ*YJN+ZNORJ*ZJN)
                  ATMSVP=ATMSVP-DIPJ*DIPN/RJN**3
               ELSE
                  WRITE(IW,9988) XJ,YJ,ZJ,IAT
               ENDIF
            ENDDO
            DO IPT=1,NCAV
               XI=CAVC(1,IPT)
               YI=CAVC(2,IPT)
               ZI=CAVC(3,IPT)
               DIPI=CAVP(IPT)
               IF(IPT.NE.JPT) THEN
                  RIJ=SQRT((XI-XJ)**2+(YI-YJ)**2+(ZI-ZJ)**2)
C                 SVPSVP HERE IS INFORMATIONAL, NOT PHYSICAL
                  SVPSVP=SVPSVP+DIPI*DIPJ/RIJ
               ENDIF
            ENDDO
         ENDDO
      ENDIF
      ELCSVP=SURSVP-ATMSVP
      SVPSVP=SVPSVP/TWO
C        SVPSVP IS THE SELF-INTERACTION ENERGY OF THE SVP CHARGES
C        AND A SIMILAR BUT INCORRECT THING FOR THE SVP DIPOLES;
C        IT IS NOT PHYSICALLY MEANINGFUL, BUT MIGHT BE USEFUL
C        AS A CONSISTENCY CHECK WHILE TRANSPORTING THE RXN FIELD
C
C     -- REACTION FIELD FREE ENERGY FROM SURFACE CHARGES/DIPOLES --
C
      SURSVP=SURSVP/TWO
C
 9988 FORMAT(' --- WARNING - ELECTRIC FIELD AT ',
     1 3F10.5,' . CONTRIBUTION FROM  -IAT-  ',I3,' IGNORED')
      RETURN
      END
C*MODULE SVPCHG  *DECK SVPHAM
      SUBROUTINE SVPHAM(DENMAT,IADDR,ILAST,L2,NCAV,CENCAV,CAVC,CAVQ,
     1      CAVN,CAVP,IQP,H0,HSVP,IUPRXN,NVLPL,SPHW,DIEL,
     2      BTABAR,ATMVOL,ELCVOL,VOLPLM,VOLSVP)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C     -- MODIFY 1-ELECTRON HAMILTONIAN TO INCLUDE POLARIZATION CHARGES -
C     --  SAVE CHARGES ON IDAF 260 AND GET VOLUME POLARIZATION ENERGY --
C
      PARAMETER (MXATM=2000)
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00, TWO=2.0D+00)
      LOGICAL     DBUG
      LOGICAL     OUT
      COMMON /FMCOM / X(1)
      COMMON /IOFILE/ IR,IW,IP,IJK,IJKT,IDAF,NAV,IODA(950)
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      DIMENSION CENCAV(*),CAVC(3,*),CAVQ(*),CAVN(3,*),CAVP(*)
      DIMENSION DENMAT(*),SPHW(*)
      DIMENSION UGL(25),WGL(25),EGL(25)
      DIMENSION   H0(L2),HSVP(L2)
C
      DATA NFT17 /26/
C
      DBUG=.FALSE.
      OUT =.FALSE.
      OUT =OUT.OR.DBUG
C
      IF(OUT) THEN
         IF(IQP.EQ.0) WRITE(IW,9999)
         IF(IQP.EQ.1) WRITE(IW,9998)
         IF(IQP.EQ.2) WRITE(IW,9997)
         WRITE(IW,9996) NCAV
         IF(DBUG) THEN
            IF(IQP.EQ.0) THEN
               WRITE(IW,9995)
               DO I=1,NCAV
                  WRITE(IW,9992) I,(CAVC(K,I),K=1,3),CAVQ(I)
               ENDDO
            ELSEIF(IQP.EQ.1) THEN
               WRITE(IW,9994)
               DO I=1,NCAV
                  WRITE(IW,9992) I,(CAVC(K,I),K=1,3),CAVP(I)
               ENDDO
            ELSEIF(IQP.EQ.2) THEN
               WRITE(IW,9993)
               DO I=1,NCAV
                  WRITE(IW,9992) I,(CAVC(K,I),K=1,3),CAVQ(I),CAVP(I)
               ENDDO
            ENDIF
         ENDIF
      ENDIF
C
C     -- HAMILTONIAN OPERATOR DUE TO SURFACE CHARGES --
C
      IF(IQP.EQ.0.OR.IQP.EQ.2) THEN
         CALL SVPEFC(NCAV,CAVC,CAVQ,HSVP,H0)
      ENDIF
C
C     -- HAMILTONIAN OPERATOR DUE TO SURFACE DIPOLES --
C
      IF(IQP.EQ.1.OR.IQP.EQ.2) THEN
         CALL SVPEFD(NCAV,CAVC,CAVN,CAVP,HSVP,H0)
      ENDIF
C
C    -- CLEAN UP FOR SURFACE POLARIZATION --
C
      ATMVOL=ZERO
      ELCVOL=ZERO
      VOLPLM=ZERO
      VOLSVP=ZERO
      IF(NVLPL.EQ.0) THEN
         IRDWRT=0
         CALL SVP260(IRDWRT,NVLPL)
         RETURN
      ENDIF
C
C     -- HAMILTONIAN OPERATOR AND ENERGY DUE TO VOLUME CHARGES --
C     ----- SET POINTERS FOR PARTITIONING OF CORE  -----
C
C     -RHO-            AT X(I10) (NCAV)
C     -ZETA-           AT X(I20) (NCAV)
C     -ELP-            AT X(I30) (NCAV)
C     -DRHO- OR -SIK-  AT X(I40) (3*NCAV)
C     -BIK-            AT X(I50) (NCAV)
C
      I10=IADDR
      I20=I10+NCAV
      I30=I20+NCAV
      I40=I30+NCAV
      I50=I40+3*NCAV
      I60=I50+NCAV
      LAST=I60-1
      IF(LAST.GT.ILAST) THEN
         NEED=LAST-ILAST
         WRITE(IW,*) 'NOT ENOUGH MEMORY FOR VOL POL CHARGES. STOP'
         WRITE(IW,*) 'ADDITIONAL WORDS NEEDED =',NEED
         WRITE(IW,*) 'IADDR = ',IADDR
         WRITE(IW,*) 'ILAST = ',ILAST
         WRITE(IW,*) 'I10   = ',I10
         WRITE(IW,*) 'LAST  = ',LAST
         CALL ABRT
      ENDIF
C
C     DETERMINE RHO, DRHO, ZETA ON CURRENT CAVITY SURFACE
C
      NDER=1
      CALL SVP_ELDEND(NCAV,CAVC,X(I10),X(I40),DUMMY,DENMAT,NDER)
      DO I=1,NCAV
         XI=CAVC(1,I)-CENCAV(1)
         YI=CAVC(2,I)-CENCAV(2)
         ZI=CAVC(3,I)-CENCAV(3)
         RI=SQRT(XI**2+YI**2+ZI**2)
         RHOI=X(I+I10-1)
C        GET DRHO IN RADIAL DIRECTION
         DRHOXI=X(1+3*(I-1)+I40-1)
         DRHOYI=X(2+3*(I-1)+I40-1)
         DRHOZI=X(3+3*(I-1)+I40-1)
         DRHOI=(DRHOXI*XI+DRHOYI*YI+DRHOZI*ZI)/RI
C        GET EFFECTIVE EXPONENTIAL PARAMETER ZETA
         X(I+I20-1)=-DRHOI/RHOI
      ENDDO
C
C     DETERMINE VOLUME POLARIZATION POINTS, CHARGES, AND ENERGY
C     IF(IUPRXN.EQ.0) THEY ARE ALREADY ON UNIT 17 FROM SVPIRF INPUT
C     IF(IUPRXN.GT.0) THEN CALCULATE AND WRITE THEM ON UNIT 17 HERE
C
      FAC=-(DIEL-ONE)/DIEL
C     GAUSS-LAGUERRE POINTS AND WEIGHTS
      CALL SVPGL(NVLPL,UGL,WGL,EGL)
      CALL SEQREW(NFT17)
      BTABAR=ZERO
      DO K=1,NVLPL
C        DETERMINE ALL POINTS SIK ON LAYER K
         IF(IUPRXN.EQ.0) THEN
            READ(NFT17) ((X(J+3*(I-1)+I40-1),J=1,3),X(I+I50-1),I=1,NCAV)
         ELSEIF(IUPRXN.GT.0) THEN
            CALL SVPSIK(NCAV,K,X(I20),CENCAV,CAVC,UGL,X(I40))
         ENDIF
C        EVALUATE CHARGE DENSITY AND ELECTROSTATIC POTENTIAL ON LAYER K
         CALL SVP_ELDELPOT(NCAV,X(I40),X(I10),X(I30),DENMAT)
C        GET VOLUME POLARIZATION CHARGES BIK
         IF(IUPRXN.GT.0) THEN
            CALL SVPBIK(NCAV,K,FAC,X(I20),SPHW,CENCAV,CAVC,UGL,EGL,
     1                  X(I10),X(I50))
         ENDIF
C        GET VOLUME POLARIZATION ENERGY AND NET CHARGE ON LAYER K
         BTBARK=ZERO
         VOLPLK=ZERO
         DO IPT=1,NCAV
            BTBARK=BTBARK+X(IPT+I50-1)
            VOLPLK=VOLPLK+X(IPT+I50-1)*X(IPT+I30-1)
         ENDDO
         BTABAR=BTABAR+BTBARK
         VOLSVP=VOLSVP+VOLPLK
         IF(K.EQ.NVLPL) VOLPLM=VOLPLK
C        REDO THE NUCLEAR CONTRIBUTION TO THE VOLUME POLARIZATION ENERGY
         ATMVLK=ZERO
         DO IPT=1,NCAV
            XI=X(1+3*(IPT-1)+I40-1)
            YI=X(2+3*(IPT-1)+I40-1)
            ZI=X(3+3*(IPT-1)+I40-1)
            QI=X(IPT+I50-1)
            DO IAT=1,NAT
               XIN=XI-C(1,IAT)
               YIN=YI-C(2,IAT)
               ZIN=ZI-C(3,IAT)
               QN=ZAN(IAT)
               RIN=SQRT(XIN*XIN+YIN*YIN+ZIN*ZIN)
               ATMVLK=ATMVLK+QI*QN/RIN
            ENDDO
         ENDDO
         ATMVOL=ATMVOL+ATMVLK
         IF(IUPRXN.GT.0) THEN
           WRITE(NFT17) ((X(J+3*(I-1)+I40-1),J=1,3),X(I+I50-1),I=1,NCAV)
         ENDIF
C        ADD CONTRIBUTIONS FROM LAYER K TO 1-ELEC HAMILTONIAN
         CALL SVPEFC(NCAV,X(I40),X(I50),HSVP,H0)
         IF(OUT) THEN
            WRITE(IW,9991) K
            DO I=1,NCAV
               WRITE(IW,9995) I,(X(J+3*(I-1)+I40-1),J=1,3),X(I+I50-1)
            ENDDO
         ENDIF
      ENDDO
      CALL SEQREW(NFT17)
      ELCVOL=VOLSVP-ATMVOL
C
C     -- CONVERT TOTAL VOLUME POLARIZATION ENERGIES TO FREE ENERGIES --
C
      VOLPLM=VOLPLM/TWO
      VOLSVP=VOLSVP/TWO
C
C     -- SAVE THE SURFACE AND VOLUME POLARIZATION INFO TO -IDAF- 260 --
C
      IRDWRT=0
      CALL SVP260(IRDWRT,NVLPL)
C
      RETURN
 9999 FORMAT(/,10X,48('-'),
     1       /,10X,'-SVP- POINT CHARGE HAMILTONIAN ON CAVITY SURFACE',
     2       /,10X,48('-'))
 9998 FORMAT(/,10X,48('-'),
     1       /,10X,'-SVP- POINT DIPOLE HAMILTONIAN ON CAVITY SURFACE',
     2       /,10X,48('-'))
 9997 FORMAT(/,10X,55('-'),
     1       /,10X,'-SVP- POINT CHARGE+DIPOLE HAMILTONIAN',
     2       ' ON CAVITY SURFACE',/,10X,55('-'))
 9996 FORMAT(' NCAV = ',I8)
 9995 FORMAT(4X,'ISVP',6X,'X',5X,6X,'Y',5X,6X,'Z',5X,5X,'Q',5X,
     1     /,1X,53('-'))
 9994 FORMAT(4X,'ISVP',6X,'X',5X,6X,'Y',5X,6X,'Z',5X,5X,'P',5X,
     1     /,1X,53('-'))
 9993 FORMAT(4X,'ISVP',6X,'X',5X,6X,'Y',5X,6X,'Z',5X,5X,'Q',5X,
     1     5X,'P',5X,/,1X,63('-'))
 9992 FORMAT(1X,I7,3F12.6,2F10.6)
 9991 FORMAT(' NCAV =',I8,'  VOL POL LAYER K =',I8)
      END
C*MODULE SVPCHG  *DECK SVPEFC
      SUBROUTINE SVPEFC(NCAV,CAVC,CAVQ,HSVP,H0)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (MXAO=8192, MXATM=2000, MXGTOT=20000, MXSH=5000)
      LOGICAL     IANDJ
      LOGICAL     NORM
      LOGICAL     DOUBLE
      LOGICAL     SOME
      LOGICAL     OUT
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      COMMON /IJPAIR/ IA(MXAO)
      COMMON /IOFILE/ IR,IW,IP,IJK,IJKT,IDAF,NAV,IODA(950)
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /NSHEL / EX(MXGTOT),CS(MXGTOT),CP(MXGTOT),CD(MXGTOT),
     *                CF(MXGTOT),CG(MXGTOT),CH(MXGTOT),CI(MXGTOT),
     *                KSTART(MXSH),KATOM(MXSH),KTYPE(MXSH),KNG(MXSH),
     *                KLOC(MXSH),KMIN(MXSH),KMAX(MXSH),NSHELL
      COMMON /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /ROOT  / XX,U(13),W(13),NROOTS
      COMMON /STV   / XINT,YINT,ZINT,T,X0,Y0,Z0,
     *                XI,YI,ZI,XJ,YJ,ZJ,NI,NJ
      COMMON /SSGG  / S(225),G(225)
C
      DIMENSION CAVC(3,*),CAVQ(*)
      DIMENSION   H0(*)
      DIMENSION HSVP(*)
      DIMENSION DIJ(225)
      DIMENSION IJX(35),IJY(35),IJZ(35)
      DIMENSION XV(5,5,5),YV(5,5,5),ZV(5,5,5)
C
      DATA RLN10 /2.30258D+00/
      DATA ZERO  /0.0D+00/
      DATA ONE   /1.0D+00/
      DATA PI212 /1.1283791670955D+00/
      DATA SQRT3 /1.73205080756888D+00/
      DATA SQRT5 /2.23606797749979D+00/
      DATA SQRT7 /2.64575131106459D+00/
      DATA IJX    / 1, 2, 1, 1, 3, 1, 1, 2, 2, 1,
     1              4, 1, 1, 3, 3, 2, 1, 2, 1, 2,
     2              5, 1, 1, 4, 4, 2, 1, 2, 1, 3,
     3              3, 1, 3, 2, 2/
      DATA IJY    / 1, 1, 2, 1, 1, 3, 1, 2, 1, 2,
     1              1, 4, 1, 2, 1, 3, 3, 1, 2, 2,
     2              1, 5, 1, 2, 1, 4, 4, 1, 2, 3,
     3              1, 3, 2, 3, 2/
      DATA IJZ    / 1, 1, 1, 2, 1, 1, 3, 1, 2, 2,
     1              1, 1, 4, 1, 2, 1, 2, 3, 3, 2,
     2              1, 1, 5, 1, 2, 1, 2, 4, 4, 1,
     3              3, 3, 2, 2, 3/
C
      OUT =.FALSE.
      SOME=.FALSE.
      SOME=SOME.OR.OUT
C
      TOL=RLN10*ITOL
      NORM=NORMF.NE.1.OR.NORMP.NE.1
C
C     ----- CALCULATE -HSVP- MATRIX FOR POINT CHARGES -----
C
      IF(SOME) THEN
         WRITE(IW,9999)
      ENDIF
C
      NUM2=(NUM*(NUM+1))/2
      DO I=1,NUM2
         HSVP(I)=ZERO
      ENDDO
C
C     ----- ISHELL -----
C
      IJSH = 0
C
      DO 9000 II=1,NSHELL
      I=KATOM(II)
      XI=C(1,I)
      YI=C(2,I)
      ZI=C(3,I)
      I1=KSTART(II)
      I2=I1+KNG(II)-1
      LIT=KTYPE(II)
      MINI=KMIN(II)
      MAXI=KMAX(II)
      LOCI=KLOC(II)-MINI
C
C     ----- JSHELL -----
C
      DO 8000 JJ=1,II
C
C     ----- PARALLEL PROCESSING -----
C
      IJSH = IJSH+1
      IF(MOD(IJSH,NPROC).NE.ME) GO TO 8000
C
      J=KATOM(JJ)
      XJ=C(1,J)
      YJ=C(2,J)
      ZJ=C(3,J)
      J1=KSTART(JJ)
      J2=J1+KNG(JJ)-1
      LJT=KTYPE(JJ)
      MINJ=KMIN(JJ)
      MAXJ=KMAX(JJ)
      LOCJ=KLOC(JJ)-MINJ
C
      IANDJ=II.EQ.JJ
      RR=(XI-XJ)**2+(YI-YJ)**2+(ZI-ZJ)**2
      NROOTS=(LIT+LJT-2)/2+1
C
      IJ=0
      DO 100 I=MINI,MAXI
      JMAX=MAXJ
      IF(IANDJ) JMAX=I
      DO 100 J=MINJ,JMAX
      IJ=IJ+1
      G(IJ)=ZERO
  100 CONTINUE
C
C     ----- I PRIMITIVE -----
C
      DO 7000 IG=I1,I2
      AI=EX(IG)
      ARRI=AI*RR
      AXI=AI*XI
      AYI=AI*YI
      AZI=AI*ZI
      CSI=CS(IG)
      CPI=CP(IG)
      CDI=CD(IG)
      CFI=CF(IG)
      CGI=CG(IG)
C
C     ----- J PRIMITIVE -----
C
      JGMAX=J2
      IF(IANDJ) JGMAX=IG
      DO 6000 JG=J1,JGMAX
      AJ=EX(JG)
      AA=AI+AJ
      AA1=ONE/AA
      DUM=AJ*ARRI*AA1
      IF(DUM.GT.TOL) GO TO 6000
      FAC= EXP(-DUM)
      CSJ=CS(JG)
      CPJ=CP(JG)
      CDJ=CD(JG)
      CFJ=CF(JG)
      CGJ=CG(JG)
      AX=(AXI+AJ*XJ)*AA1
      AY=(AYI+AJ*YJ)*AA1
      AZ=(AZI+AJ*ZJ)*AA1
C
C     ----- DENSITY FACTOR -----
C
      DOUBLE=IANDJ.AND.IG.NE.JG
      IJ=0
      DO 360 I=MINI,MAXI
      GO TO (110,120,220,220,130,220,220,140,220,220,
     1       150,220,220,160,220,220,220,220,220,170,
     2       180,220,220,190,220,220,220,220,220,200,
     3       220,220,210,220,220),I
  110 DUM1=CSI*FAC
      GO TO 220
  120 DUM1=CPI*FAC
      GO TO 220
  130 DUM1=CDI*FAC
      GO TO 220
  140 IF(NORM) DUM1=DUM1*SQRT3
      GO TO 220
  150 DUM1=CFI*FAC
      GO TO 220
  160 IF(NORM) DUM1=DUM1*SQRT5
      GO TO 220
  170 IF(NORM) DUM1=DUM1*SQRT3
      GO TO 220
  180 DUM1=CGI*FAC
      GO TO 220
  190 IF(NORM) DUM1=DUM1*SQRT7
      GO TO 220
  200 IF(NORM) DUM1=DUM1*SQRT5/SQRT3
      GO TO 220
  210 IF(NORM) DUM1=DUM1*SQRT3
  220 CONTINUE
C
      JMAX=MAXJ
      IF(IANDJ) JMAX=I
      DO 360 J=MINJ,JMAX
      GO TO (230,250,350,350,260,350,350,270,350,350,
     1       280,350,350,290,350,350,350,350,350,300,
     2       310,350,350,320,350,350,350,350,350,330,
     3       350,350,340,350,350),J
  230 DUM2=DUM1*CSJ
      IF(.NOT.DOUBLE) GO TO 350
      IF(I.GT.1) GO TO 240
      DUM2=DUM2+DUM2
      GO TO 350
  240 DUM2=DUM2+CSI*CPJ*FAC
      GO TO 350
  250 DUM2=DUM1*CPJ
      IF(DOUBLE) DUM2=DUM2+DUM2
      GO TO 350
  260 DUM2=DUM1*CDJ
      IF(DOUBLE) DUM2=DUM2+DUM2
      GO TO 350
  270 IF(NORM) DUM2=DUM2*SQRT3
      GO TO 350
  280 DUM2=DUM1*CFJ
      IF(DOUBLE) DUM2=DUM2+DUM2
      GO TO 350
  290 IF(NORM) DUM2=DUM2*SQRT5
      GO TO 350
  300 IF(NORM) DUM2=DUM2*SQRT3
      GO TO 350
  310 DUM2=DUM1*CGJ
      IF(DOUBLE) DUM2=DUM2+DUM2
      GO TO 350
  320 IF(NORM) DUM2=DUM2*SQRT7
      GO TO 350
  330 IF(NORM) DUM2=DUM2*SQRT5/SQRT3
      GO TO 350
  340 IF(NORM) DUM2=DUM2*SQRT3
  350 CONTINUE
C
      IJ=IJ+1
  360 DIJ(IJ)=DUM2
C
C     ----- INTERACTION OF -SVP- POINT CHARGES WITH SOLUTE POTENTIAL ---
C
      AAX=AA*AX
      AAY=AA*AY
      AAZ=AA*AZ
      DO 500 IC=1,NCAV
      ZNUC=-CAVQ(IC)
      CX=CAVC(1,IC)
      CY=CAVC(2,IC)
      CZ=CAVC(3,IC)
      XX=AA*((AX-CX)**2+(AY-CY)**2+(AZ-CZ)**2)
      IF(NROOTS.LE.3) CALL RT123
      IF(NROOTS.EQ.4) CALL ROOT4
      IF(NROOTS.EQ.5) CALL ROOT5
      DO 420 IROOT=1,NROOTS
      UU=U(IROOT)*AA
      WW=W(IROOT)*ZNUC
      TT=ONE/(AA+UU)
      T = SQRT(TT)
      X0=(AAX+UU*CX)*TT
      Y0=(AAY+UU*CY)*TT
      Z0=(AAZ+UU*CZ)*TT
      DO 410 J=1,LJT
      NJ=J
      DO 410 I=1,LIT
      NI=I
      CALL STVINT
      XV(I,J,IROOT)=XINT
      YV(I,J,IROOT)=YINT
      ZV(I,J,IROOT)=ZINT*WW
  410 CONTINUE
  420 CONTINUE
C
      IJ=0
      DO 450 I=MINI,MAXI
      IX=IJX(I)
      IY=IJY(I)
      IZ=IJZ(I)
      JMAX=MAXJ
      IF(IANDJ) JMAX=I
      DO 440 J=MINJ,JMAX
      JX=IJX(J)
      JY=IJY(J)
      JZ=IJZ(J)
      DUM=ZERO
      DO 430 IROOT=1,NROOTS
  430 DUM=DUM+XV(IX,JX,IROOT)*YV(IY,JY,IROOT)*ZV(IZ,JZ,IROOT)
      DUM=DUM*(AA1*PI212)
      IJ=IJ+1
      G(IJ)=G(IJ)+DUM*DIJ(IJ)
  440 CONTINUE
  450 CONTINUE
C
  500 CONTINUE
C
 6000 CONTINUE
 7000 CONTINUE
C
C     ----- SET UP -HSVP- MATRIX -----
C
      IJ=0
      DO 7500 I=MINI,MAXI
      JMAX=MAXJ
      IF(IANDJ) JMAX=I
      DO 7500 J=MINJ,JMAX
      IJ=IJ+1
      NN=IA(LOCI+I)+(LOCJ+J)
      HSVP(NN)=G(IJ)
 7500 CONTINUE
C
 8000 CONTINUE
 9000 CONTINUE
C
C     ----- GLOBAL SUM ON -HSVP- -----
C
      NUM2=(NUM*(NUM+1))/2
      IF(GOPARR) CALL DDI_GSUMF(964,HSVP,NUM2)
C
      IF(OUT) THEN
         WRITE(IW,*) '-H0-         '
         CALL PRTRIL(H0  ,NUM)
         WRITE(IW,*) '       -HSVP-'
         CALL PRTRIL(HSVP,NUM)
      ENDIF
C
C     -----  ADD -HSVP- TO -H0-  -----
C
      DO I=1,NUM2
         H0(I)=H0(I)+HSVP(I)
      ENDDO
C
      IF(OUT) THEN
         WRITE(IW,*) '-H0- + -HSVP-'
         CALL PRTRIL(H0,NUM)
      ENDIF
C
      IF(SOME) THEN
         WRITE(IW,9998)
      ENDIF
      RETURN
 9999 FORMAT(/,10X,23('-'),/,10X,'-SVP CHARGES- INTEGRALS',
     1       /,10X,23('-'))
 9998 FORMAT(' ...... END OF -SVP CHARGES- INTEGRALS ......')
      END
C*MODULE SVPCHG  *DECK SVPEFD
      SUBROUTINE SVPEFD(NCAV,CAVC,CAVN,CAVP,HSVP,H0)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (MXAO=8192, MXATM=2000, MXGTOT=20000, MXSH=5000)
      LOGICAL     IANDJ
      LOGICAL     NORM
      LOGICAL     DOUBLE
      LOGICAL     DBUG
      LOGICAL     OUT
      LOGICAL     SOME
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      COMMON /IJPAIR/ IA(MXAO)
      COMMON /IOFILE/ IR,IW,IP,IJK,IJKT,IDAF,NAV,IODA(950)
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /NSHEL / EX(MXGTOT),CS(MXGTOT),CP(MXGTOT),CD(MXGTOT),
     *                CF(MXGTOT),CG(MXGTOT),CH(MXGTOT),CI(MXGTOT),
     *                KSTART(MXSH),KATOM(MXSH),KTYPE(MXSH),KNG(MXSH),
     *                KLOC(MXSH),KMIN(MXSH),KMAX(MXSH),NSHELL
      COMMON /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /ROOT  / XX,U(13),W(13),NROOTS
      COMMON /SSGG  / S(225),G(225)
      COMMON/XYZDER/XINT,YINT,ZINT,T,X0,Y0,Z0,XI,YI,ZI,XJ,YJ,ZJ,NI,NJ
     1                              ,CX,CY,CZ
C
      DIMENSION CAVC(3,*),CAVN(3,*),CAVP(*)
      DIMENSION   H0(*)
      DIMENSION HSVP(*)
      DIMENSION DIJ(225)
      DIMENSION IJX(35),IJY(35),IJZ(35)
      DIMENSION  XV(5,5,5), YV(5,5,5), ZV(5,5,5)
      DIMENSION DXV(5,5,5),DYV(5,5,5),DZV(5,5,5)
      DATA MAXRYS /5/
      DATA RLN10  /2.30258D+00/
      DATA ZERO   /0.0D+00/
      DATA ONE    /1.0D+00/
      DATA PI212  /1.1283791670955D+00/
      DATA SQRT3  /1.73205080756888D+00/
      DATA SQRT5  /2.23606797749979D+00/
      DATA SQRT7  /2.64575131106459D+00/
      DATA IJX    / 1, 2, 1, 1, 3, 1, 1, 2, 2, 1,
     1              4, 1, 1, 3, 3, 2, 1, 2, 1, 2,
     2              5, 1, 1, 4, 4, 2, 1, 2, 1, 3,
     3              3, 1, 3, 2, 2/
      DATA IJY    / 1, 1, 2, 1, 1, 3, 1, 2, 1, 2,
     1              1, 4, 1, 2, 1, 3, 3, 1, 2, 2,
     2              1, 5, 1, 2, 1, 4, 4, 1, 2, 3,
     3              1, 3, 2, 3, 2/
      DATA IJZ    / 1, 1, 1, 2, 1, 1, 3, 1, 2, 2,
     1              1, 1, 4, 1, 2, 1, 2, 3, 3, 2,
     2              1, 1, 5, 1, 2, 1, 2, 4, 4, 1,
     3              3, 3, 2, 2, 3/
C
      DBUG=.FALSE.
      OUT =.FALSE.
      OUT =OUT.OR.DBUG
      SOME=.FALSE.
      SOME=SOME.OR.OUT
C
      TOL=RLN10*ITOL
      NORM=NORMF.NE.1.OR.NORMP.NE.1
C
C     ----- CALCULATE -HSVP- MATRIX FOR POINT DIPOLES -----
C
      IF(SOME) THEN
         WRITE(IW,9999)
      ENDIF
C
      NUM2=(NUM*(NUM+1))/2
      DO I=1,NUM2
         HSVP(I)=ZERO
      ENDDO
C
      NDER=1
C
C     ----- ISHELL -----
C
      IJSH = 0
C
      DO 9000 II=1,NSHELL
      I=KATOM(II)
      XI=C(1,I)
      YI=C(2,I)
      ZI=C(3,I)
      I1=KSTART(II)
      I2=I1+KNG(II)-1
      LIT=KTYPE(II)
      MINI=KMIN(II)
      MAXI=KMAX(II)
      LOCI=KLOC(II)-MINI
C
C     ----- JSHELL -----
C
      DO 8000 JJ=1,II
C
C     ----- PARALLEL PROCESSING -----
C
      IJSH = IJSH+1
      IF(MOD(IJSH,NPROC).NE.ME) GO TO 8000
C
      J=KATOM(JJ)
      XJ=C(1,J)
      YJ=C(2,J)
      ZJ=C(3,J)
      J1=KSTART(JJ)
      J2=J1+KNG(JJ)-1
      LJT=KTYPE(JJ)
      MINJ=KMIN(JJ)
      MAXJ=KMAX(JJ)
      LOCJ=KLOC(JJ)-MINJ
C
      IANDJ=II.EQ.JJ
      RR=(XI-XJ)**2+(YI-YJ)**2+(ZI-ZJ)**2
      NROOTS=(LIT+LJT+NDER-2)/2+1
      IF(NROOTS.GT.MAXRYS) THEN
         WRITE(IW,9997) MAXRYS,LIT,LJT,NROOTS
         CALL ABRT
      ENDIF
C
      IJ=0
      DO 100 I=MINI,MAXI
      JMAX=MAXJ
      IF(IANDJ) JMAX=I
      DO 100 J=MINJ,JMAX
      IJ=IJ+1
      G(IJ)=ZERO
  100 CONTINUE
C
C     ----- I PRIMITIVE -----
C
      DO 7000 IG=I1,I2
      AI=EX(IG)
      ARRI=AI*RR
      AXI=AI*XI
      AYI=AI*YI
      AZI=AI*ZI
      CSI=CS(IG)
      CPI=CP(IG)
      CDI=CD(IG)
      CFI=CF(IG)
      CGI=CG(IG)
C
C     ----- J PRIMITIVE -----
C
      JGMAX=J2
      IF(IANDJ) JGMAX=IG
      DO 6000 JG=J1,JGMAX
      AJ=EX(JG)
      AA=AI+AJ
      AA1=ONE/AA
      DUM=AJ*ARRI*AA1
      IF(DUM.GT.TOL) GO TO 6000
      FAC= EXP(-DUM)
      CSJ=CS(JG)
      CPJ=CP(JG)
      CDJ=CD(JG)
      CFJ=CF(JG)
      CGJ=CG(JG)
      AX=(AXI+AJ*XJ)*AA1
      AY=(AYI+AJ*YJ)*AA1
      AZ=(AZI+AJ*ZJ)*AA1
C
C     ----- DENSITY FACTOR -----
C
      DOUBLE=IANDJ.AND.IG.NE.JG
      IJ=0
      DO 360 I=MINI,MAXI
      GO TO (110,120,220,220,130,220,220,140,220,220,
     1       150,220,220,160,220,220,220,220,220,170,
     2       180,220,220,190,220,220,220,220,220,200,
     3       220,220,210,220,220),I
  110 DUM1=CSI*FAC
      GO TO 220
  120 DUM1=CPI*FAC
      GO TO 220
  130 DUM1=CDI*FAC
      GO TO 220
  140 IF(NORM) DUM1=DUM1*SQRT3
      GO TO 220
  150 DUM1=CFI*FAC
      GO TO 220
  160 IF(NORM) DUM1=DUM1*SQRT5
      GO TO 220
  170 IF(NORM) DUM1=DUM1*SQRT3
      GO TO 220
  180 DUM1=CGI*FAC
      GO TO 220
  190 IF(NORM) DUM1=DUM1*SQRT7
      GO TO 220
  200 IF(NORM) DUM1=DUM1*SQRT5/SQRT3
      GO TO 220
  210 IF(NORM) DUM1=DUM1*SQRT3
  220 CONTINUE
C
      JMAX=MAXJ
      IF(IANDJ) JMAX=I
      DO 360 J=MINJ,JMAX
      GO TO (230,250,350,350,260,350,350,270,350,350,
     1       280,350,350,290,350,350,350,350,350,300,
     2       310,350,350,320,350,350,350,350,350,330,
     3       350,350,340,350,350),J
  230 DUM2=DUM1*CSJ
      IF(.NOT.DOUBLE) GO TO 350
      IF(I.GT.1) GO TO 240
      DUM2=DUM2+DUM2
      GO TO 350
  240 DUM2=DUM2+CSI*CPJ*FAC
      GO TO 350
  250 DUM2=DUM1*CPJ
      IF(DOUBLE) DUM2=DUM2+DUM2
      GO TO 350
  260 DUM2=DUM1*CDJ
      IF(DOUBLE) DUM2=DUM2+DUM2
      GO TO 350
  270 IF(NORM) DUM2=DUM2*SQRT3
      GO TO 350
  280 DUM2=DUM1*CFJ
      IF(DOUBLE) DUM2=DUM2+DUM2
      GO TO 350
  290 IF(NORM) DUM2=DUM2*SQRT5
      GO TO 350
  300 IF(NORM) DUM2=DUM2*SQRT3
      GO TO 350
  310 DUM2=DUM1*CGJ
      IF(DOUBLE) DUM2=DUM2+DUM2
      GO TO 350
  320 IF(NORM) DUM2=DUM2*SQRT7
      GO TO 350
  330 IF(NORM) DUM2=DUM2*SQRT5/SQRT3
      GO TO 350
  340 IF(NORM) DUM2=DUM2*SQRT3
  350 CONTINUE
C
      IJ=IJ+1
  360 DIJ(IJ)=DUM2
C
C     ----- INTERACTION OF -SVP- POINT DIPOLES WITH SOLUTE ELECTRIC FIEL
C
      AAX=AA*AX
      AAY=AA*AY
      AAZ=AA*AZ
      DO 500 IEF=1,NCAV
      CX=CAVC(1,IEF)
      CY=CAVC(2,IEF)
      CZ=CAVC(3,IEF)
      XX=AA*((AX-CX)**2+(AY-CY)**2+(AZ-CZ)**2)
      IF(NROOTS.LE.3) CALL RT123
      IF(NROOTS.EQ.4) CALL ROOT4
      IF(NROOTS.EQ.5) CALL ROOT5
      DO 420 IROOT=1,NROOTS
      UU=U(IROOT)*AA
      WW=W(IROOT)
      WW=WW*(UU+UU)
      TT=ONE/(AA+UU)
      T = SQRT(TT)
      X0=(AAX+UU*CX)*TT
      Y0=(AAY+UU*CY)*TT
      Z0=(AAZ+UU*CZ)*TT
      DO 410 J=1,LJT
      NJ=J
      DO 410 I=1,LIT
      NI=I
      CALL DS2XYZ
      XV(I,J,IROOT)=XINT
      YV(I,J,IROOT)=YINT
      ZV(I,J,IROOT)=ZINT*WW
      CALL DVXYZ
      DXV(I,J,IROOT)=XINT
      DYV(I,J,IROOT)=YINT
      DZV(I,J,IROOT)=ZINT*WW
  410 CONTINUE
  420 CONTINUE
C
      IJ=0
      DO 450 I=MINI,MAXI
      IX=IJX(I)
      IY=IJY(I)
      IZ=IJZ(I)
      JMAX=MAXJ
      IF(IANDJ) JMAX=I
      DO 440 J=MINJ,JMAX
      JX=IJX(J)
      JY=IJY(J)
      JZ=IJZ(J)
      DUMX=ZERO
      DUMY=ZERO
      DUMZ=ZERO
      DO 430 IROOT=1,NROOTS
      DUMX=DUMX+DXV(IX,JX,IROOT)* YV(IY,JY,IROOT)* ZV(IZ,JZ,IROOT)
      DUMY=DUMY+ XV(IX,JX,IROOT)*DYV(IY,JY,IROOT)* ZV(IZ,JZ,IROOT)
      DUMZ=DUMZ+ XV(IX,JX,IROOT)* YV(IY,JY,IROOT)*DZV(IZ,JZ,IROOT)
  430 CONTINUE
      IJ=IJ+1
      DUM =PI212*AA1*DIJ(IJ)
      DUMX=DUMX*DUM
      DUMY=DUMY*DUM
      DUMZ=DUMZ*DUM
      G(IJ)=G(IJ)-CAVP(IEF)*(CAVN(1,IEF)*DUMX+CAVN(2,IEF)*DUMY
     1                                       +CAVN(3,IEF)*DUMZ)
  440 CONTINUE
  450 CONTINUE
C
  500 CONTINUE
C
 6000 CONTINUE
 7000 CONTINUE
C
C     ----- SET UP -HSVP- MATRIX -----
C
      IJ=0
      DO 7500 I=MINI,MAXI
      JMAX=MAXJ
      IF(IANDJ) JMAX=I
      DO 7500 J=MINJ,JMAX
      IJ=IJ+1
      NN=IA(LOCI+I)+(LOCJ+J)
      HSVP(NN)=G(IJ)
 7500 CONTINUE
C
 8000 CONTINUE
 9000 CONTINUE
C
C     ----- GLOBAL SUM ON -HSVP- -----
C     -----  ADD -HSVP- TO -H0-  -----
C
      NUM2=(NUM*(NUM+1))/2
      IF(GOPARR) CALL DDI_GSUMF(965,HSVP,NUM2)
C
      IF(OUT) THEN
         WRITE(IW,*) '-H0-         '
         CALL PRTRIL(H0  ,NUM)
         WRITE(IW,*) '       -HSVP-'
         CALL PRTRIL(HSVP,NUM)
      ENDIF
C
      DO I=1,NUM2
         H0(I)=H0(I)+HSVP(I)
      ENDDO
C
      IF(OUT) THEN
         WRITE(IW,*) '-H0- + -HSVP-'
         CALL PRTRIL(H0,NUM)
      ENDIF
C
      IF(SOME) THEN
         WRITE(IW,9998)
      ENDIF
      RETURN
 9999 FORMAT(/,10X,23('-'),/,10X,'-SVP DIPOLES- INTEGRALS',
     1       /,10X,23('-'))
 9998 FORMAT(' ...... END OF -SVP DIPOLES- INTEGRALS ......')
 9997 FORMAT(' IN -SVPEFD- , THE RYS QUADRATURE IS NOT IMPLEMENTED',
     1       ' BEYOND -NROOTS- = ',I3,/,
     2       ' LIT,LJT,NROOTS= ',3I3)
      END
C*MODULE SVPCHG  *DECK SVPGL
      SUBROUTINE SVPGL(N,X,W,E)
      IMPLICIT REAL*8(A-H,O-Z)
      DIMENSION X(*),W(*),E(*)
C
C     ----- POINTS AND WEIGHTS FOR GAUSS-LAGUERRE INTEGRATION -----
C
C     INTEGRAL(O,INFINITY) F(X)*EXP(-X) DX ~ SUM(I=1,N) W(I)*F(X(I))
C  OR INTEGRAL(O,INFINITY) G(X)*DX         ~ SUM(I=1,N) E(I)*G(X(I))
C     WITH E(I) = W(I)*EXP(X(I))
C
      IF(N.EQ. 1) THEN
         X( 1) =  1.000000000000000D+00
         W( 1) =  1.000000000000000D+00
         E( 1) =  2.718281828459045D+00
      ELSEIF(N.EQ. 2) THEN
         X( 1) =  0.585786437626905D+00
         W( 1) =  8.535533905932735D-01
         E( 1) =  1.533326033119416D+00
         X( 2) =  3.414213562373095D+00
         W( 2) =  1.464466094067262D-01
         E( 2) =  4.450957335054592D+00
      ELSEIF(N.EQ. 3) THEN
         X( 1) =  0.415774556783479D+00
         W( 1) =  7.110930099291731D-01
         E( 1) =  1.077692859270921D+00
         X( 2) =  2.294280360279041D+00
         W( 2) =  2.785177335692408D-01
         E( 2) =  2.762142961901584D+00
         X( 3) =  6.289945082937479D+00
         W( 3) =  1.038925650158613D-02
         E( 3) =  5.601094625434420D+00
      ELSEIF(N.EQ. 4) THEN
         X( 1) =  0.322547689619392D+00
         W( 1) =  6.031541043416339D-01
         E( 1) =  8.327391238378894D-01
         X( 2) =  1.745761101158348D+00
         W( 2) =  3.574186924378002D-01
         E( 2) =  2.048102438454303D+00
         X( 3) =  4.536620296921129D+00
         W( 3) =  3.888790851500540D-02
         E( 3) =  3.631146305821522D+00
         X( 4) =  9.395070912301135D+00
         W( 4) =  5.392947055613275D-04
         E( 4) =  6.487145084407674D+00
      ELSEIF(N.EQ. 5) THEN
         X( 1) =  0.263560319718141D+00
         W( 1) =  5.217556105828087D-01
         E( 1) =  6.790940422077506D-01
         X( 2) =  1.413403059106517D+00
         W( 2) =  3.986668110831758D-01
         E( 2) =  1.638487873602747D+00
         X( 3) =  3.596425771040723D+00
         W( 3) =  7.594244968170771D-02
         E( 3) =  2.769443242370845D+00
         X( 4) =  7.085810005858831D+00
         W( 4) =  3.611758679922054D-03
         E( 4) =  4.315656900920874D+00
         X( 5) = 12.640800844275784D+00
         W( 5) =  2.336997238577616D-05
         E( 5) =  7.219186354354436D+00
      ELSEIF(N.EQ. 6) THEN
         X( 1) =  0.222846604179260D+00
         W( 1) =  4.589646739499636D-01
         E( 1) =  5.735355074227377D-01
         X( 2) =  1.188932101672623D+00
         W( 2) =  4.170008307721207D-01
         E( 2) =  1.369252590712304D+00
         X( 3) =  2.992736326059315D+00
         W( 3) =  1.133733820740450D-01
         E( 3) =  2.260684593382675D+00
         X( 4) =  5.775143569104510D+00
         W( 4) =  1.039919745314910D-02
         E( 4) =  3.350524582355464D+00
         X( 5) =  9.837467418382586D+00
         W( 5) =  2.610172028149328D-04
         E( 5) =  4.886826800210818D+00
         X( 6) = 15.982873980601701D+00
         W( 6) =  8.985479064296189D-07
         E( 6) =  7.849015945595794D+00
      ELSEIF(N.EQ. 7) THEN
         X( 1) =  0.193043676560362D+00
         W( 1) =  4.093189517012742D-01
         E( 1) =  4.964775975399725D-01
         X( 2) =  1.026664895339192D+00
         W( 2) =  4.218312778617200D-01
         E( 2) =  1.177643060861198D+00
         X( 3) =  2.567876744950745D+00
         W( 3) =  1.471263486575053D-01
         E( 3) =  1.918249781659805D+00
         X( 4) =  4.900353084526483D+00
         W( 4) =  2.063351446871692D-02
         E( 4) =  2.771848636232104D+00
         X( 5) =  8.182153444562857D+00
         W( 5) =  1.074010143280745D-03
         E( 5) =  3.841249122488499D+00
         X( 6) = 12.734180291797818D+00
         W( 6) =  1.586546434856409D-05
         E( 6) =  5.380678207921514D+00
         X( 7) = 19.395727862262543D+00
         W( 7) =  3.170315478995578D-08
         E( 7) =  8.405432486828333D+00
      ELSEIF(N.EQ. 8) THEN
         X( 1) =  0.170279632305101D+00
         W( 1) =  3.691885893416376D-01
         E( 1) =  4.377234104929115D-01
         X( 2) =  0.903701776799380D+00
         W( 2) =  4.187867808143428D-01
         E( 2) =  1.033869347665597D+00
         X( 3) =  2.251086629866130D+00
         W( 3) =  1.757949866371717D-01
         E( 3) =  1.669709765658773D+00
         X( 4) =  4.266700170287658D+00
         W( 4) =  3.334349226121565D-02
         E( 4) =  2.376924701758597D+00
         X( 5) =  7.045905402393465D+00
         W( 5) =  2.794536235225675D-03
         E( 5) =  3.208540913347926D+00
         X( 6) = 10.758516010180994D+00
         W( 6) =  9.076508773358203D-05
         E( 6) =  4.268575510825122D+00
         X( 7) = 15.740678641278011D+00
         W( 7) =  8.485746716272529D-07
         E( 7) =  5.818083368671958D+00
         X( 8) = 22.863131736889272D+00
         W( 8) =  1.048001174871506D-09
         E( 8) =  8.906226215292248D+00
      ELSEIF(N.EQ. 9) THEN
         X( 1) =  0.152322227731809D+00
         W( 1) =  3.361264217979623D-01
         E( 1) =  3.914311243156399D-01
         X( 2) =  0.807220022742256D+00
         W( 2) =  4.112139804239842D-01
         E( 2) =  9.218050285289628D-01
         X( 3) =  2.005135155619348D+00
         W( 3) =  1.992875253708855D-01
         E( 3) =  1.480127909942916D+00
         X( 4) =  3.783473973331234D+00
         W( 4) =  4.746056276565155D-02
         E( 4) =  2.086770807549261D+00
         X( 5) =  6.204956777876616D+00
         W( 5) =  5.599626610794583D-03
         E( 5) =  2.772921389711978D+00
         X( 6) =  9.372985251687579D+00
         W( 6) =  3.052497670932107D-04
         E( 6) =  3.591626068092280D+00
         X( 7) = 13.466236911092109D+00
         W( 7) =  6.592123026075337D-06
         E( 7) =  4.648766002140267D+00
         X( 8) = 18.833597788991714D+00
         W( 8) =  4.110769330349547D-08
         E( 8) =  6.212275419747243D+00
         X( 9) = 26.374071890927379D+00
         W( 9) =  3.290874030350721D-11
         E( 9) =  9.363218237705869D+00
      ELSEIF(N.EQ.10) THEN
         X( 1) =  0.137793470540492D+00
         W( 1) =  3.084411157650207D-01
         E( 1) =  3.540097386069968D-01
         X( 2) =  0.729454549503171D+00
         W( 2) =  4.011199291552737D-01
         E( 2) =  8.319023010435815D-01
         X( 3) =  1.808342901740316D+00
         W( 3) =  2.180682876118094D-01
         E( 3) =  1.330288561749328D+00
         X( 4) =  3.401433697854900D+00
         W( 4) =  6.208745609867763D-02
         E( 4) =  1.863063903111128D+00
         X( 5) =  5.552496140063805D+00
         W( 5) =  9.501516975181109D-03
         E( 5) =  2.450255558083015D+00
         X( 6) =  8.330152746764501D+00
         W( 6) =  7.530083885875356D-04
         E( 6) =  3.122764155135183D+00
         X( 7) = 11.843785837900070D+00
         W( 7) =  2.825923349599557D-05
         E( 7) =  3.934152695561526D+00
         X( 8) = 16.279257831378104D+00
         W( 8) =  4.249313984962717D-07
         E( 8) =  4.992414872193066D+00
         X( 9) = 21.996585811980772D+00
         W( 9) =  1.839564823979625D-09
         E( 9) =  6.572202485130848D+00
         X(10) = 29.920697012273898D+00
         W(10) =  9.911827219609029D-13
         E(10) =  9.784695840374713D+00
      ELSEIF(N.EQ.11) THEN
         X( 1) =  0.125796442187968D+00
         W( 1) =  2.849332128942006D-01
         E( 1) =  3.231288804345737D-01
         X( 2) =  0.665418255839228D+00
         W( 2) =  3.897208895278491D-01
         E( 2) =  7.581255998096256D-01
         X( 3) =  1.647150545872169D+00
         W( 3) =  2.327818318489914D-01
         E( 3) =  1.208641422901475D+00
         X( 4) =  3.091138143035254D+00
         W( 4) =  7.656445354619669D-02
         E( 4) =  1.684579167140417D+00
         X( 5) =  5.029284401579831D+00
         W( 5) =  1.439328276735067D-02
         E( 5) =  2.199633478618833D+00
         X( 6) =  7.509887863806610D+00
         W( 6) =  1.518880846484876D-03
         E( 6) =  2.773489745754630D+00
         X( 7) = 10.605950999546968D+00
         W( 7) =  8.513122435471903D-05
         E( 7) =  3.437121416521950D+00
         X( 8) = 14.431613758064179D+00
         W( 8) =  2.292403879574509D-06
         E( 8) =  4.244840290798204D+00
         X( 9) = 19.178857403214653D+00
         W( 9) =  2.486353702767818D-08
         E( 9) =  5.306826019478295D+00
         X(10) = 25.217709339677569D+00
         W(10) =  7.712626933691196D-11
         E(10) =  6.904215478826043D+00
         X(11) = 33.497192847175533D+00
         W(11) =  2.883775868323628D-14
         E(11) =  1.017671274694610D+01
      ELSEIF(N.EQ.12) THEN
         X( 1) =  0.115722117358021D+00
         W( 1) =  2.647313710554435D-01
         E( 1) =  2.972096360444112D-01
         X( 2) =  0.611757484515131D+00
         W( 2) =  3.777592758731382D-01
         E( 2) =  6.964629804305978D-01
         X( 3) =  1.512610269776419D+00
         W( 3) =  2.440820113198774D-01
         E( 3) =  1.107781394615752D+00
         X( 4) =  2.833751337743509D+00
         W( 4) =  9.044922221168074D-02
         E( 4) =  1.538464239042829D+00
         X( 5) =  4.599227639418353D+00
         W( 5) =  2.010238115463406D-02
         E( 5) =  1.998327606274248D+00
         X( 6) =  6.844525453115181D+00
         W( 6) =  2.663973541865321D-03
         E( 6) =  2.500745769100881D+00
         X( 7) =  9.621316842456871D+00
         W( 7) =  2.032315926629993D-04
         E( 7) =  3.065321518282396D+00
         X( 8) = 13.006054993306350D+00
         W( 8) =  8.365055856819753D-06
         E( 8) =  3.723289110782759D+00
         X( 9) = 17.116855187462260D+00
         W( 9) =  1.668493876540914D-07
         E( 9) =  4.529814029981765D+00
         X(10) = 22.151090379396983D+00
         W(10) =  1.342391030515027D-09
         E(10) =  5.597258461835290D+00
         X(11) = 28.487967250983992D+00
         W(11) =  3.061601635035012D-12
         E(11) =  7.212995460925796D+00
         X(12) = 37.099121044466926D+00
         W(12) =  8.148077467426124D-16
         E(12) =  1.054383746190999D+01
      ELSEIF(N.EQ.13) THEN
         X( 1) =  0.107142388472252D+00
         W( 1) =  2.471887084299629D-01
         E( 1) =  2.751439554706095D-01
         X( 2) =  0.566131899040402D+00
         W( 2) =  3.656888229005218D-01
         E( 2) =  6.441390765427173D-01
         X( 3) =  1.398564336451020D+00
         W( 3) =  2.525624200576586D-01
         E( 3) =  1.022721778580024D+00
         X( 4) =  2.616597108406412D+00
         W( 4) =  1.034707580241836D-01
         E( 4) =  1.416417605660190D+00
         X( 5) =  4.238845929017034D+00
         W( 5) =  2.643275441556165D-02
         E( 5) =  1.832524617857581D+00
         X( 6) =  6.292256271140078D+00
         W( 6) =  4.220396040254745D-03
         E( 6) =  2.280580382278458D+00
         X( 7) =  8.815001941186980D+00
         W( 7) =  4.118817704727351D-04
         E( 7) =  2.773826365864964D+00
         X( 8) = 11.861403588811243D+00
         W( 8) =  2.351547398155331D-05
         E( 8) =  3.331929956425665D+00
         X( 9) = 15.510762037703755D+00
         W( 9) =  7.317311620249146D-07
         E( 9) =  3.986482974917318D+00
         X(10) = 19.884635663880221D+00
         W(10) =  1.108841625703973D-08
         E(10) =  4.793547821925483D+00
         X(11) = 25.185263864677768D+00
         W(11) =  6.770826692205850D-11
         E(11) =  5.867631337114664D+00
         X(12) = 31.800386301947270D+00
         W(12) =  1.159979959905077D-13
         E(12) =  7.502098804917360D+00
         X(13) = 40.723008669265582D+00
         W(13) =  2.245093203892749D-17
         E(13) =  1.088961001392153D+01
      ELSEIF(N.EQ.14) THEN
         X( 1) =  0.099747507032597D+00
         W( 1) =  2.318155771448655D-01
         E( 1) =  2.561311547369099D-01
         X( 2) =  0.526857648851903D+00
         W( 2) =  3.537846915975430D-01
         E( 2) =  5.991704774951181D-01
         X( 3) =  1.300629121251497D+00
         W( 3) =  2.587346102454282D-01
         E( 3) =  9.499715024749590D-01
         X( 4) =  2.430801078730846D+00
         W( 4) =  1.154828935569231D-01
         E( 4) =  1.312807811466164D+00
         X( 5) =  3.932102822293219D+00
         W( 5) =  3.319209215933736D-02
         E( 5) =  1.693265990751966D+00
         X( 6) =  5.825536218301709D+00
         W( 6) =  6.192869437006579D-03
         E( 6) =  2.098409084271834D+00
         X( 7) =  8.140240141565144D+00
         W( 7) =  7.398903778673880D-04
         E( 7) =  2.537632654935398D+00
         X( 8) = 10.916499507366012D+00
         W( 8) =  5.490719466841721D-05
         E( 8) =  3.024159917703233D+00
         X( 9) = 14.210805011161286D+00
         W( 9) =  2.409585764085366D-06
         E( 9) =  3.577804355719832D+00
         X(10) = 18.104892220218115D+00
         W(10) =  5.801543981676485D-08
         E(10) =  4.230565034906497D+00
         X(11) = 22.723381628269642D+00
         W(11) =  6.819314692484891D-10
         E(11) =  5.039413368463538D+00
         X(12) = 28.272981723248211D+00
         W(12) =  3.221207751894853D-12
         E(12) =  6.120947928329770D+00
         X(13) = 35.149443660592432D+00
         W(13) =  4.221352440516609D-15
         E(13) =  7.774295367006114D+00
         X(14) = 44.366081711117417D+00
         W(14) =  6.052375022289181D-19
         E(14) =  1.121683421670324D+01
      ELSEIF(N.EQ.15) THEN
         X( 1) =  0.093307812017282D+00
         W( 1) =  2.182348859400872D-01
         E( 1) =  2.395781703110999D-01
         X( 2) =  0.492691740301884D+00
         W( 2) =  3.422101779228834D-01
         E( 2) =  5.601008427926125D-01
         X( 3) =  1.215595412070949D+00
         W( 3) =  2.630275779416803D-01
         E( 3) =  8.870082629186037D-01
         X( 4) =  2.269949526203743D+00
         W( 4) =  1.264258181059306D-01
         E( 4) =  1.223664402147916D+00
         X( 5) =  3.667622721751437D+00
         W( 5) =  4.020686492100094D-02
         E( 5) =  1.574448721629545D+00
         X( 6) =  5.425336627413556D+00
         W( 6) =  8.563877803611813D-03
         E( 6) =  1.944751976529957D+00
         X( 7) =  7.565916226613068D+00
         W( 7) =  1.212436147214254D-03
         E( 7) =  2.341502056636213D+00
         X( 8) = 10.120228568019114D+00
         W( 8) =  1.116743923442522D-04
         E( 8) =  2.774041926825749D+00
         X( 9) = 13.130282482175724D+00
         W( 9) =  6.459926762022885D-06
         E( 9) =  3.255643346397823D+00
         X(10) = 16.654407708329966D+00
         W(10) =  2.226316907096266D-07
         E(10) =  3.806311714225772D+00
         X(11) = 20.776478899448776D+00
         W(11) =  4.227430384979381D-09
         E(11) =  4.458477753837045D+00
         X(12) = 25.623894226728787D+00
         W(12) =  3.921897267041136D-11
         E(12) =  5.270017784429873D+00
         X(13) = 31.407519169753943D+00
         W(13) =  1.456515264073122D-13
         E(13) =  6.359563469730584D+00
         X(14) = 38.530683306485990D+00
         W(14) =  1.483027051113311D-16
         E(14) =  8.031787632117044D+00
         X(15) = 48.026085572685794D+00
         W(15) =  1.600594906211129D-20
         E(15) =  1.152777210094117D+01
      ELSEIF(N.EQ.16) THEN
         X( 1) =  0.087649410478928D+00
         W( 1) =  2.061517149578016D-01
         E( 1) =  2.250363148642480D-01
         X( 2) =  0.462696328915081D+00
         W( 2) =  3.310578549508837D-01
         E( 2) =  5.258360527623418D-01
         X( 3) =  1.141057774831228D+00
         W( 3) =  2.657957776442144D-01
         E( 3) =  8.319613916870889D-01
         X( 4) =  2.129283645098383D+00
         W( 4) =  1.362969342963770D-01
         E( 4) =  1.146099240963750D+00
         X( 5) =  3.437086633893207D+00
         W( 5) =  4.732892869412523D-02
         E( 5) =  1.471751316966809D+00
         X( 6) =  5.078018614549770D+00
         W( 6) =  1.129990008033939D-02
         E( 6) =  1.813134687381342D+00
         X( 7) =  7.070338535048236D+00
         W( 7) =  1.849070943526311D-03
         E( 7) =  2.175517519694613D+00
         X( 8) =  9.438314336391938D+00
         W( 8) =  2.042719153082776D-04
         E( 8) =  2.565762750165018D+00
         X( 9) = 12.214223368866158D+00
         W( 9) =  1.484458687398130D-05
         E( 9) =  2.993215086371372D+00
         X(10) = 15.441527368781626D+00
         W(10) =  6.828319330871144D-07
         E(10) =  3.471234483102094D+00
         X(11) = 19.180156856753154D+00
         W(11) =  1.881024841079652D-08
         E(11) =  4.020044086444701D+00
         X(12) = 23.515905693991925D+00
         W(12) =  2.862350242973877D-10
         E(12) =  4.672516607732925D+00
         X(13) = 28.578729742882135D+00
         W(13) =  2.127079033224117D-12
         E(13) =  5.487420657986162D+00
         X(14) = 34.583398702286665D+00
         W(14) =  6.297967002517678D-15
         E(14) =  6.585361233289274D+00
         X(15) = 41.940452647688311D+00
         W(15) =  5.050473700035650D-18
         E(15) =  8.276357984364276D+00
         X(16) = 51.701160339543343D+00
         W(16) =  4.161462370372826D-22
         E(16) =  1.182427755165864D+01
      ELSEIF(N.EQ.17) THEN
         X( 1) =  0.082638214708948D+00
         W( 1) =  1.953322052517708D-01
         E( 1) =  2.121598373671370D-01
         X( 2) =  0.436150323558711D+00
         W( 2) =  3.203753572745405D-01
         E( 2) =  4.955377930519823D-01
         X( 3) =  1.075176577511429D+00
         W( 3) =  2.673297263571708D-01
         E( 3) =  7.834125211490017D-01
         X( 4) =  2.005193531649233D+00
         W( 4) =  1.451298543587585D-01
         E( 4) =  1.077956524209001D+00
         X( 5) =  3.234256124047443D+00
         W( 5) =  5.443694324533853D-02
         E( 5) =  1.382016787075887D+00
         X( 6) =  4.773513513700198D+00
         W( 6) =  1.435729776606183D-02
         E( 6) =  1.698960515851416D+00
         X( 7) =  6.637829205364961D+00
         W( 7) =  2.662824735572763D-03
         E( 7) =  2.032896079248132D+00
         X( 8) =  8.846685511169797D+00
         W( 8) =  3.436797271563025D-04
         E( 8) =  2.389024565862588D+00
         X( 9) = 11.425529319373348D+00
         W( 9) =  3.027551783782896D-05
         E( 9) =  2.774188175899003D+00
         X(10) = 14.407823037481313D+00
         W(10) =  1.768515053231681D-06
         E(10) =  3.197766895391797D+00
         X(11) = 17.838284730701147D+00
         W(11) =  6.576272886810442D-08
         E(11) =  3.673232780776504D+00
         X(12) = 21.778268257722296D+00
         W(12) =  1.469730932159536D-09
         E(12) =  4.221040938264196D+00
         X(13) = 26.315317811248800D+00
         W(13) =  1.816910362555468D-11
         E(13) =  4.874508329374917D+00
         X(14) = 31.581771680456761D+00
         W(14) =  1.095401388928672D-13
         E(14) =  5.693278866460870D+00
         X(15) = 37.796093837477137D+00
         W(15) =  2.617373882223325D-16
         E(15) =  6.799872279930203D+00
         X(16) = 45.375716533988971D+00
         W(16) =  1.672935693146154D-19
         E(16) =  8.509470760282502D+00
         X(17) = 55.389751789839607D+00
         W(17) =  1.065626316274051D-23
         E(17) =  1.210789074418804D+01
      ELSEIF(N.EQ.18) THEN
         X( 1) =  0.078169166669706D+00
         W( 1) =  1.855886031469193D-01
         E( 1) =  2.006779892089067D-01
         X( 2) =  0.412490085259130D+00
         W( 2) =  3.101817663702247D-01
         E( 2) =  4.685526868918787D-01
         X( 3) =  1.016520179623539D+00
         W( 3) =  2.678665671485359D-01
         E( 3) =  7.402656826535068D-01
         X( 4) =  1.894888509969760D+00
         W( 4) =  1.529797474680750D-01
         E( 4) =  1.017591717303967D+00
         X( 5) =  3.054353113202662D+00
         W( 5) =  6.143491786096171D-02
         E( 5) =  1.302878702065422D+00
         X( 6) =  4.504205538889891D+00
         W( 6) =  1.768721308077299D-02
         E( 6) =  1.598862139757244D+00
         X( 7) =  6.256725073949110D+00
         W( 7) =  3.660179767759904D-03
         E( 7) =  1.908813906969682D+00
         X( 8) =  8.327825156605627D+00
         W( 8) =  5.406227870077342D-04
         E( 8) =  2.236777877856917D+00
         X( 9) = 10.737990047757604D+00
         W( 9) =  5.616965051214256D-05
         E( 9) =  2.587924166792749D+00
         X(10) = 13.513656207555096D+00
         W(10) =  4.015307883701155D-06
         E(10) =  2.969102377726269D+00
         X(11) = 16.689306281930094D+00
         W(11) =  1.914669856675682D-07
         E(11) =  3.389748873853976D+00
         X(12) = 20.310767626267747D+00
         W(12) =  5.836095268631618D-09
         E(12) =  3.863462276042993D+00
         X(13) = 24.440681359283698D+00
         W(13) =  1.071711266955400D-10
         E(13) =  4.410936896966335D+00
         X(14) = 29.168208662579627D+00
         W(14) =  1.089098713888835D-12
         E(14) =  5.065931514611449D+00
         X(15) = 34.627927065660188D+00
         W(15) =  5.386664748378341D-15
         E(15) =  5.888946263673518D+00
         X(16) = 41.041816772808737D+00
         W(16) =  1.049865978035703D-17
         E(16) =  7.004359269190001D+00
         X(17) = 48.833922716086562D+00
         W(17) =  5.405398451630974D-21
         E(17) =  8.732344850766685D+00
         X(18) = 59.090546435901260D+00
         W(18) =  2.691653269201047D-25
         E(18) =  1.237990649217394D+01
      ELSEIF(N.EQ.19) THEN
         X( 1) =  0.074158783757206D+00
         W( 1) =  1.767684749159133D-01
         E( 1) =  1.903757229594394D-01
         X( 2) =  0.391268613319995D+00
         W( 2) =  3.004781436072535D-01
         E( 2) =  4.443638155208133D-01
         X( 3) =  0.963957343997959D+00
         W( 3) =  2.675995470381755D-01
         E( 3) =  7.016600163855571D-01
         X( 4) =  1.796175582068327D+00
         W( 4) =  1.599133721355806D-01
         E( 4) =  9.637267754940716D-01
         X( 5) =  2.893651381873784D+00
         W( 5) =  6.824937997614915D-02
         E( 5) =  1.232524435025772D+00
         X( 6) =  4.264215539627767D+00
         W( 6) =  2.123930760654438D-02
         E( 6) =  1.510308384205917D+00
         X( 7) =  5.918141561644051D+00
         W( 7) =  4.841627351148375D-03
         E( 7) =  1.799730940904622D+00
         X( 8) =  7.868618915334737D+00
         W( 8) =  8.049127473813633D-04
         E( 8) =  2.104004093742030D+00
         X( 9) = 10.132423716815268D+00
         W( 9) =  9.652472093153448D-05
         E( 9) =  2.427136845642661D+00
         X(10) = 12.730881463842405D+00
         W(10) =  8.207305258050987D-06
         E(10) =  2.774291914449515D+00
         X(11) = 15.691278339835906D+00
         W(11) =  4.830566724730710D-07
         E(11) =  3.152344570181081D+00
         X(12) = 19.048993209823550D+00
         W(12) =  1.904991361123320D-08
         E(12) =  3.570800997228506D+00
         X(13) = 22.850849760829462D+00
         W(13) =  4.816684630928128D-10
         E(13) =  4.043395003083437D+00
         X(14) = 27.160669327411444D+00
         W(14) =  7.348258839551074D-12
         E(14) =  4.591063075259461D+00
         X(15) = 32.069122251862268D+00
         W(15) =  6.202275387572570D-14
         E(15) =  5.248000635129635D+00
         X(16) = 37.712905801219598D+00
         W(16) =  2.541430843015534D-16
         E(16) =  6.075544165359110D+00
         X(17) = 44.317362795831521D+00
         W(17) =  4.078861296825621D-19
         E(17) =  7.199876582037971D+00
         X(18) = 52.312902457404377D+00
         W(18) =  1.707750187593848D-22
         E(18) =  8.946006539555883D+00
         X(19) = 62.802423153500371D+00
         W(19) =  6.715064649908208D-27
         E(19) =  1.264142475436949D+01
      ELSEIF(N.EQ.20) THEN
         X( 1) =  0.070539889691989D+00
         W( 1) =  1.687468018511149D-01
         E( 1) =  1.810800624189904D-01
         X( 2) =  0.372126818001612D+00
         W( 2) =  2.912543620060674D-01
         E( 2) =  4.225567678785630D-01
         X( 3) =  0.916582102483273D+00
         W( 3) =  2.666861028670004D-01
         E( 3) =  6.669095467018455D-01
         X( 4) =  1.707306531028342D+00
         W( 4) =  1.660024532695066D-01
         E( 4) =  9.153523727830707D-01
         X( 5) =  2.749199255309430D+00
         W( 5) =  7.482606466879230D-02
         E( 5) =  1.169539707195542D+00
         X( 6) =  4.048925313850887D+00
         W( 6) =  2.496441730928328D-02
         E( 6) =  1.431354985928210D+00
         X( 7) =  5.615174970861620D+00
         W( 7) =  6.202550844572215D-03
         E( 7) =  1.702981137985023D+00
         X( 8) =  7.459017453671069D+00
         W( 8) =  1.144962386476901D-03
         E( 8) =  1.987015890792746D+00
         X( 9) =  9.594392869581101D+00
         W( 9) =  1.557417730278111D-04
         E( 9) =  2.286635781253428D+00
         X(10) = 12.038802546964321D+00
         W(10) =  1.540144086522490D-05
         E(10) =  2.605834727553844D+00
         X(11) = 14.814293442630746D+00
         W(11) =  1.086486366517978D-06
         E(11) =  2.949783734213955D+00
         X(12) = 17.948895520519379D+00
         W(12) =  5.330120909556746D-08
         E(12) =  3.325395782009349D+00
         X(13) = 21.478788240285017D+00
         W(13) =  1.757981179050583D-09
         E(13) =  3.742255470589834D+00
         X(14) = 25.451702793186890D+00
         W(14) =  3.725502402512387D-11
         E(14) =  4.214236710251888D+00
         X(15) = 29.932554631700611D+00
         W(15) =  4.767529251578165D-13
         E(15) =  4.762518461490181D+00
         X(16) = 35.013434240479008D+00
         W(16) =  3.372844243362378D-15
         E(16) =  5.421726044245518D+00
         X(17) = 40.833057056728528D+00
         W(17) =  1.155014339500410D-17
         E(17) =  6.254012356932211D+00
         X(18) = 47.619994047346424D+00
         W(18) =  1.539522140582393D-20
         E(18) =  7.387314389054093D+00
         X(19) = 55.810795750063882D+00
         W(19) =  5.286442725569194D-24
         E(19) =  9.151328730987386D+00
         X(20) = 66.524416525615734D+00
         W(20) =  1.656456612499026D-28
         E(20) =  1.289338864593977D+01
      ELSEIF(N.EQ.21) THEN
         X( 1) =  0.067257817923162D+00
         W( 1) =  1.614201001816388D-01
         E( 1) =  1.726502898123237D-01
         X( 2) =  0.354772895323512D+00
         W( 2) =  2.824935645829945D-01
         E( 2) =  4.027953696669826D-01
         X( 3) =  0.873660166778642D+00
         W( 3) =  2.652545755139000D-01
         E( 3) =  6.354606658716229D-01
         X( 4) =  1.626869941929211D+00
         W( 4) =  1.713193963900214D-01
         E( 4) =  8.716601148520555D-01
         X( 5) =  2.618626410545548D+00
         W( 5) =  8.112662589235328D-02
         E( 5) =  1.112803323466856D+00
         X( 6) =  3.854652138109764D+00
         W( 6) =  2.881630176776937D-02
         E( 6) =  1.360480736129657D+00
         X( 7) =  5.342369280622438D+00
         W( 7) =  7.734239426118691D-03
         E( 7) =  1.616512663335716D+00
         X( 8) =  7.091168813219679D+00
         W( 8) =  1.567481390421184D-03
         E( 8) =  1.883032775552378D+00
         X( 9) =  9.112778854269704D+00
         W( 9) =  2.384226587634135D-04
         E( 9) =  2.162604477882829D+00
         X(10) = 11.421771762378389D+00
         W(10) =  2.693007343968608D-05
         E(10) =  2.458385511359759D+00
         X(11) = 14.036270697873757D+00
         W(11) =  2.224790793645034D-06
         E(11) =  2.774368145007231D+00
         X(12) = 16.978952692783839D+00
         W(12) =  1.317334497432325D-07
         E(12) =  3.115742282286449D+00
         X(13) = 20.278509414993742D+00
         W(13) =  5.443952290646403D-09
         E(13) =  3.489466639371123D+00
         X(14) = 23.971845587151481D+00
         W(14) =  1.516366205198049D-10
         E(14) =  3.905209673379409D+00
         X(15) = 28.107528600944310D+00
         W(15) =  2.717883118058924D-12
         E(15) =  4.376987913761248D+00
         X(16) = 32.751497410560859D+00
         W(16) =  2.942519354071892D-14
         E(16) =  4.926221411440408D+00
         X(17) = 37.997187819260901D+00
         W(17) =  1.759074035797758D-16
         E(17) =  5.587957780248551D+00
         X(18) = 43.985245757142245D+00
         W(18) =  5.073802227171857D-19
         E(18) =  6.425146762784212D+00
         X(19) = 50.947351189940001D+00
         W(19) =  5.659720870324156D-22
         E(19) =  7.567431567097572D+00
         X(20) = 59.325994120230057D+00
         W(20) =  1.606260924799303D-25
         E(20) =  9.349060588629651D+00
         X(21) = 70.255688628018987D+00
         W(21) =  4.044133927115962D-30
         E(21) =  1.313661351260639D+01
      ELSEIF(N.EQ.22) THEN
         X( 1) =  0.064267628744808D+00
         W( 1) =  1.547019876398929D-01
         E( 1) =  1.649707581056077D-01
         X( 2) =  0.338967254814911D+00
         W( 2) =  2.741750823285652D-01
         E( 2) =  3.848040115405233D-01
         X( 3) =  0.834589985449178D+00
         W( 3) =  2.634097015356333D-01
         E( 3) =  6.068615074887099D-01
         X( 4) =  1.553713386750029D+00
         W( 4) =  1.759346092630729D-01
         E( 4) =  8.319944536165607D-01
         X( 5) =  2.500006236736174D+00
         W( 5) =  8.712562217220969D-02
         E( 5) =  1.061413985673834D+00
         X( 6) =  3.678420344463639D+00
         W( 6) =  3.275268789653855D-02
         E( 6) =  1.296476366803233D+00
         X( 7) =  5.095349068968740D+00
         W( 7) =  9.424900256998254D-03
         E( 7) =  1.538716981758731D+00
         X( 8) =  6.758835515813549D+00
         W( 8) =  2.077335752654618D-03
         E( 8) =  1.789911936863393D+00
         X( 9) =  8.678853313678429D+00
         W( 9) =  3.491673714923024D-04
         E( 9) =  2.052162545615037D+00
         X(10) = 10.867686893540569D+00
         W(10) =  4.438219314066132D-05
         E(10) =  2.328011964345702D+00
         X(11) = 13.340451051495238D+00
         W(11) =  4.214229901104629D-06
         E(11) =  2.620610652078496D+00
         X(12) = 16.115811338766310D+00
         W(12) =  2.940668246130181D-07
         E(12) =  2.933958508288531D+00
         X(13) = 19.217003684901339D+00
         W(13) =  1.476193826389766D-08
         E(13) =  3.273271610304288D+00
         X(14) = 22.673316601434554D+00
         W(14) =  5.186423025724953D-10
         E(14) =  3.645559771138021D+00
         X(15) = 26.522319587637117D+00
         W(15) =  1.230526251554398D-11
         E(15) =  4.060578655239286D+00
         X(16) = 30.813357944506542D+00
         W(16) =  1.880465509631468D-13
         E(16) =  4.532488349832744D+00
         X(17) = 35.613335203196172D+00
         W(17) =  1.735564139126855D-15
         E(17) =  5.082947556944183D+00
         X(18) = 41.016968598471671D+00
         W(18) =  8.831402308327170D-18
         E(18) =  5.747418160466498D+00
         X(19) = 47.166757849153512D+00
         W(19) =  2.160718646818207D-20
         E(19) =  6.589627767640492D+00
         X(20) = 54.297385256578849D+00
         W(20) =  2.031119967583335D-23
         E(20) =  7.740880701125192D+00
         X(21) = 62.857096246298937D+00
         W(21) =  4.797903520990897D-27
         E(21) =  9.539850280823837D+00
         X(22) = 73.995507008599532D+00
         W(22) =  9.780246506683544D-32
         E(22) =  1.337180949239416D+01
      ELSEIF(N.EQ.23) THEN
         X( 1) =  0.061532037757520D+00
         W( 1) =  1.485197990820467D-01
         E( 1) =  1.579455438221546D-01
         X( 2) =  0.324511329154553D+00
         W( 2) =  2.662763422220287D-01
         E( 2) =  3.683545698073415D-01
         X( 3) =  0.798873968692984D+00
         W( 3) =  2.612370674653506D-01
         E( 3) =  5.807394865289024D-01
         X( 4) =  1.486886334222197D+00
         W( 4) =  1.799149140382857D-01
         E( 4) =  7.958178862631986D-01
         X( 5) =  2.391755829792768D+00
         W( 5) =  9.280788216398930D-02
         E( 5) =  1.014638228775698D+00
         X( 6) =  3.517797442503534D+00
         W( 6) =  3.673579259475957D-02
         E( 6) =  1.238367176046633D+00
         X( 7) =  4.870560368733451D+00
         W( 7) =  1.126058922254349D-02
         E( 7) =  1.468312878412539D+00
         X( 8) =  6.456991306767736D+00
         W( 8) =  2.677540143126999D-03
         E( 8) =  1.705971159815636D+00
         X( 9) =  8.285651892598002D+00
         W( 9) =  4.923896728665586D-04
         E( 9) =  1.953088089653665D+00
         X(10) = 10.367009043445769D+00
         W(10) =  6.956649894243928D-05
         E(10) =  2.211744564690187D+00
         X(11) = 12.713825028162598D+00
         W(11) =  7.476361523134085D-06
         E(11) =  2.484473377214064D+00
         X(12) = 15.341687572888507D+00
         W(12) =  6.030632412462966D-07
         E(12) =  2.774425794423161D+00
         X(13) = 18.269742393895992D+00
         W(13) =  3.588339690021515D-08
         E(13) =  3.085615846651833D+00
         X(14) = 21.521727850814141D+00
         W(14) =  1.540551240061165D-09
         E(14) =  3.423290812594679D+00
         X(15) = 25.127477130115508D+00
         W(15) =  4.639077530348996D-11
         E(15) =  3.794515161630257D+00
         X(16) = 29.125175108751012D+00
         W(16) =  9.446912374131420D-13
         E(16) =  4.209133702105681D+00
         X(17) = 33.564896563116399D+00
         W(17) =  1.239741169314352D-14
         E(17) =  4.681449970050238D+00
         X(18) = 38.514459677180717D+00
         W(18) =  9.821168268011364D-17
         E(18) =  5.233358223729088D+00
         X(19) = 44.069807814871254D+00
         W(19) =  4.281846844983449D-19
         E(19) =  5.900726449366727D+00
         X(20) = 50.375226603043814D+00
         W(20) =  8.943238836296874D-22
         E(20) =  6.748041851266620D+00
         X(21) = 57.668304350434092D+00
         W(21) =  7.129396795317911D-25
         E(21) =  7.908227359729249D+00
         X(22) = 66.402873068345201D+00
         W(22) =  1.410767108895284D-28
         E(22) =  9.724262681549060D+00
         X(23) = 77.743227284712361D+00
         W(23) =  2.344614766311685D-33
         E(23) =  1.359959925214107D+01
      ELSEIF(N.EQ.24) THEN
         X( 1) =  0.059019852181508D+00
         W( 1) =  1.428119733347820D-01
         E( 1) =  1.514944128595096D-01
         X( 2) =  0.311239146198483D+00
         W( 2) =  2.587741075174232D-01
         E( 2) =  3.532565825299226D-01
         X( 3) =  0.766096905545936D+00
         W( 3) =  2.588067072728699D-01
         E( 3) =  5.567845632881525D-01
         X( 4) =  1.425597590803613D+00
         W( 4) =  1.833226889777778D-01
         E( 4) =  7.626853176973080D-01
         X( 5) =  2.292562058632190D+00
         W( 5) =  9.816627262991875D-02
         E( 5) =  9.718726322465459D-01
         X( 6) =  3.370774264208996D+00
         W( 6) =  4.073247815140859D-02
         E( 6) =  1.185357893037797D+00
         X( 7) =  4.665083703467167D+00
         W( 7) =  1.322601940512009D-02
         E( 7) =  1.404265627284407D+00
         X( 8) =  6.181535118736766D+00
         W( 8) =  3.369349058478263D-03
         E( 8) =  1.629868615757023D+00
         X( 9) =  7.927539247172152D+00
         W( 9) =  6.721625640935491D-04
         E( 9) =  1.863635055332077D+00
         X(10) =  9.912098015077705D+00
         W(10) =  1.044612146592746D-04
         E(10) =  2.107291151081466D+00
         X(11) = 12.146102711729773D+00
         W(11) =  1.254472197799318D-05
         E(11) =  2.362905891041923D+00
         X(12) = 14.642732289596678D+00
         W(12) =  1.151315812737269D-06
         E(12) =  2.633008753163841D+00
         X(13) = 17.417992646508981D+00
         W(13) =  7.960812959133550D-08
         E(13) =  2.920757579727703D+00
         X(14) = 20.491460082616438D+00
         W(14) =  4.072858987549957D-09
         E(14) =  3.230185133492363D+00
         X(15) = 23.887329848169752D+00
         W(15) =  1.507008226292567D-10
         E(15) =  3.566573377368783D+00
         X(16) = 27.635937174332742D+00
         W(16) =  3.917736515058387D-12
         E(16) =  3.937043755455193D+00
         X(17) = 31.776041352374715D+00
         W(17) =  6.894181052958219D-14
         E(17) =  4.351531188863562D+00
         X(18) = 36.358405801651614D+00
         W(18) =  7.819800382459429D-16
         E(18) =  4.824481854897986D+00
         X(19) = 41.451720484870776D+00
         W(19) =  5.350188813009955D-18
         E(19) =  5.378022079789149D+00
         X(20) = 47.153106445156318D+00
         W(20) =  2.010517464555523D-20
         E(20) =  6.048417812619995D+00
         X(21) = 53.608574544695017D+00
         W(21) =  3.605765864553080D-23
         E(21) =  6.900898352180364D+00
         X(22) = 61.058531447218769D+00
         W(22) =  2.451818845878402D-26
         E(22) =  8.069965156147013D+00
         X(23) = 69.962240035105083D+00
         W(23) =  4.088301593680406D-30
         E(23) =  9.902793319484134D+00
         X(24) = 81.498279233948836D+00
         W(24) =  5.575345788328487D-35
         E(24) =  1.382053209479164D+01
      ELSEIF(N.EQ.25) THEN
         X( 1) =  0.056704775452706D+00
         W( 1) =  1.375260142293455D-01
         E( 1) =  1.455497378454643D-01
         X( 2) =  0.299010898586989D+00
         W( 2) =  2.516452737649086D-01
         E( 2) =  3.393497717863082D-01
         X( 3) =  0.735909555435016D+00
         W( 3) =  2.561760028097560D-01
         E( 3) =  5.347365922210578D-01
         X( 4) =  1.369183116035193D+00
         W( 4) =  1.862154903624361D-01
         E( 4) =  7.322248723751615D-01
         X( 5) =  2.201326053721465D+00
         W( 5) =  1.031998481075207D-01
         E( 5) =  9.326159014946040D-01
         X( 6) =  3.235675803558034D+00
         W( 6) =  4.471416112993361D-02
         E( 6) =  1.136792590389696D+00
         X( 7) =  4.476496615073830D+00
         W( 7) =  1.530523288639544D-02
         E( 7) =  1.345729337882852D+00
         X( 8) =  5.929083762700445D+00
         W( 8) =  4.152414632877108D-03
         E( 8) =  1.560519046450818D+00
         X( 9) =  7.599899309956746D+00
         W( 9) =  8.920990732596834D-04
         E( 9) =  1.782409226315826D+00
         X(10) =  9.496749220932433D+00
         W(10) =  1.511560191642415D-04
         E(10) =  2.012849149820460D+00
         X(11) = 11.629014911778741D+00
         W(11) =  2.006553180193321D-05
         E(11) =  2.253552502637366D+00
         X(12) = 14.007957976545065D+00
         W(12) =  2.067774396431873D-06
         E(12) =  2.506582512631154D+00
         X(13) = 16.647125597288777D+00
         W(13) =  1.634652022291161D-07
         E(13) =  2.774470442968602D+00
         X(14) = 19.562898011469052D+00
         W(14) =  9.766015062124498D-09
         E(14) =  3.060384869688151D+00
         X(15) = 22.775241986835038D+00
         W(15) =  4.327720794184913D-10
         E(15) =  3.368380566658863D+00
         X(16) = 26.308772390968887D+00
         W(16) =  1.389600963389507D-11
         E(16) =  3.703776583237858D+00
         X(17) = 30.194291163316109D+00
         W(17) =  3.138922792539912D-13
         E(17) =  4.073752788828841D+00
         X(18) = 34.471097571922037D+00
         W(18) =  4.802614822604315D-15
         E(18) =  4.488334516969803D+00
         X(19) = 39.190608803937415D+00
         W(19) =  4.735885364807389D-17
         E(19) =  4.962109314023299D+00
         X(20) = 44.422349336161965D+00
         W(20) =  2.814205379843154D-19
         E(20) =  5.517431865774071D+00
         X(21) = 50.264574993833534D+00
         W(21) =  9.164954395991217D-22
         E(21) =  6.190958079761836D+00
         X(22) = 56.864967173940222D+00
         W(22) =  1.418940009497175D-24
         E(22) =  7.048642624550755D+00
         X(23) = 64.466670615954172D+00
         W(23) =  8.273651944099073D-28
         E(23) =  8.226527659276456D+00
         X(24) = 73.534234792100108D+00
         W(24) =  1.168881711542845D-31
         E(24) =  1.007587949613119D+01
         X(25) = 85.260155562495967D+00
         W(25) =  1.315831500059124D-36
         E(25) =  1.403509529984159D+01
      ENDIF
C
      RETURN
      END
C*MODULE SVPCHG  *DECK SVPSIK
      SUBROUTINE SVPSIK(NCAV,KK,ZETA,CENCAV,CAVC,UGL,SIK)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C     -- DETERMINE ALL VOLUME POLARIZATION POINTS ON LAYER K --
C
      DIMENSION ZETA(*),CENCAV(*),CAVC(3,*),UGL(*),SIK(3,*)
C
      K=KK
      DO IPT=1,NCAV
         ZETAI=ZETA(IPT)
         CAVXI=CAVC(1,IPT)-CENCAV(1)
         CAVYI=CAVC(2,IPT)-CENCAV(2)
         CAVZI=CAVC(3,IPT)-CENCAV(3)
         RI=SQRT(CAVXI**2+CAVYI**2+CAVZI**2)
         RIK=RI+UGL(K)/ZETAI
         RATIO=RIK/RI
         SIK(1,IPT)=CENCAV(1)+CAVXI*RATIO
         SIK(2,IPT)=CENCAV(2)+CAVYI*RATIO
         SIK(3,IPT)=CENCAV(3)+CAVZI*RATIO
      ENDDO
C
      RETURN
      END
C*MODULE SVPCHG  *DECK SVPBIK
      SUBROUTINE SVPBIK(NCAV,KK,FAC,ZETA,SPHW,CENCAV,CAVC,UGL,EGL,
     1                  RHO,BIK)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C     -- DETERMINE VOLUME POLARIZATION CHARGES BIK AND --
C     -- VOL POL ENERGY CONTRIBUTION FROM ONE LAYER K  --
C
      DIMENSION ZETA(*),SPHW(*),CENCAV(*),CAVC(3,*),UGL(*),EGL(*)
      DIMENSION RHO(*),BIK(*)
C
      K=KK
      DO IPT=1,NCAV
         ZETAI=ZETA(IPT)
         FACI=FAC*SPHW(IPT)/ZETAI
         CAVXI=CAVC(1,IPT)-CENCAV(1)
         CAVYI=CAVC(2,IPT)-CENCAV(2)
         CAVZI=CAVC(3,IPT)-CENCAV(3)
         RI=SQRT(CAVXI**2+CAVYI**2+CAVZI**2)
         RIK=RI+UGL(K)/ZETAI
C        EXTRA MINUS HERE BECAUSE RHO SHOULD BE NEGATIVE
         BIK(IPT)=-FACI*EGL(K)*RIK*RIK*RHO(IPT)
      ENDDO
C
      RETURN
      END
C*MODULE SVPCHG  *DECK SVP260
      SUBROUTINE SVP260(IRDWRT,NVLPL)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (MXCAV=5810)
      COMMON /FMCOM / X(1)
      COMMON /IOFILE/ IR,IW,IP,IJK,IJKT,IDAF,NAV,IODA(950)
      COMMON/SVPPAR/CAVC(3,MXCAV),CAVW(MXCAV),CAVQ(MXCAV),
     1              CAVN(3,MXCAV),SPHW(MXCAV),CAVP(MXCAV),
     2              CENCAV(3),RNTCAV(3),NCAV,IQP
C
      LENDAF=10*NCAV+6
C
C     ----- SET POINTERS FOR PARTITIONING OF CORE -----
C
      CALL VALFM(LOADFM)
      I10  = LOADFM + 1
      LAST = I10    + LENDAF
      NEED = LAST - LOADFM - 1
      CALL GETFM(NEED)
C
      IF(IRDWRT.GT.0) GO TO 20
C
C     --- WRITE SVP INFORMATION ON RECORD 260 OF -IDAF- ---
C
      LOFF=0
      DO I=1,NCAV
         DO K=1,3
            LOFF=LOFF+1
            X(I10+LOFF-1)=CAVC(K,I)
         ENDDO
      ENDDO
      DO I=1,NCAV
         LOFF=LOFF+1
         X(I10+LOFF-1)=CAVW(I)
      ENDDO
      DO I=1,NCAV
         LOFF=LOFF+1
         X(I10+LOFF-1)=CAVQ(I)
      ENDDO
      DO I=1,NCAV
         DO K=1,3
            LOFF=LOFF+1
            X(I10+LOFF-1)=CAVN(K,I)
         ENDDO
      ENDDO
      DO I=1,NCAV
         LOFF=LOFF+1
         X(I10+LOFF-1)=SPHW(I)
      ENDDO
      DO I=1,NCAV
         LOFF=LOFF+1
         X(I10+LOFF-1)=CAVP(I)
      ENDDO
      DO I=1,3
         LOFF=LOFF+1
         X(I10+LOFF-1)=CENCAV(I)
      ENDDO
      DO I=1,3
         LOFF=LOFF+1
         X(I10+LOFF-1)=RNTCAV(I)
      ENDDO
      IF(NVLPL.LT.1) GOTO 30
C     VOL POL PART NOT YET OPERATIONAL
C     MAINLY BECAUSE OF EXCESSIVE SPACE REQUIREMENT FOR X
C     LENDAF=LENDAF+4*NCAV*NVLPL
C     CALL SEQREW(NFT17)
C     READ ALL VOL POL X,Y,Z,B COORDINATES AND CHARGES
C     DO K=1,NVLPL
C        READ(NFT17) ((X(J+4*(I-1)+I10+LOFF-1),J=1,4),I=1,NCAV)
C        LOFF=LOFF+4*NCAV
C     ENDDO
C     CALL SEQREW(NFT17)
      CALL DAWRIT(IDAF,IODA,X(I10),LENDAF,260,0)
      GO TO 30
C
C     -- READ SVP INFORMATION FROM RECORD 260 OF -IDAF- ---
C
   20 CONTINUE
C     VOL POL PART NOT YET OPERATIONAL
C     MAINLY BECAUSE OF EXCESSIVE SPACE REQUIREMENT FOR X
C     IF(NVLPL.GT.1) LENDAF=LENDAF+4*NCAV*NVLPL
      CALL DAREAD(IDAF,IODA,X(I10),LENDAF,260,0)
      LOFF=0
      DO I=1,NCAV
         DO K=1,3
            LOFF=LOFF+1
            CAVC(K,I)=X(I10+LOFF-1)
         ENDDO
      ENDDO
      DO I=1,NCAV
         LOFF=LOFF+1
         CAVW(I)=X(I10+LOFF-1)
      ENDDO
      DO I=1,NCAV
         LOFF=LOFF+1
         CAVQ(I)=X(I10+LOFF-1)
      ENDDO
      DO I=1,NCAV
         DO K=1,3
            LOFF=LOFF+1
            CAVN(K,I)=X(I10+LOFF-1)
         ENDDO
      ENDDO
      DO I=1,NCAV
         LOFF=LOFF+1
         SPHW(I)=X(I10+LOFF-1)
      ENDDO
      DO I=1,NCAV
         LOFF=LOFF+1
         CAVP(I)=X(I10+LOFF-1)
      ENDDO
      DO I=1,3
         LOFF=LOFF+1
         CENCAV(I)=X(I10+LOFF-1)
      ENDDO
      DO I=1,3
         LOFF=LOFF+1
         RNTCAV(I)=X(I10+LOFF-1)
      ENDDO
      IF(NVLPL.LT.1) GOTO 30
C     CALL SEQREW(NFT17)
C     READ ALL VOL POL X,Y,Z,B COORDINATES AND CHARGES
C     DO K=1,NVLPL
C        WRITE(NFT17) ((X(J+4*(I-1)+I10+LOFF-1),J=1,4),I=1,NCAV)
C        DO I=1,NCAV
C           SIK(1,I)=X(1+4*(I-1)+I10+LOFF-1)
C           SIK(2,I)=X(2+4*(I-1)+I10+LOFF-1)
C           SIK(3,I)=X(3+4*(I-1)+I10+LOFF-1)
C           BIK(I)  =X(4+4*(I-1)+I10+LOFF-1)
C        ENDDO
C        LOFF=LOFF+4*NCAV
C     ENDDO
C     CALL SEQREW(NFT17)
C
   30 CONTINUE
      CALL RETFM(NEED)
C
      RETURN
      END
C*MODULE SVPCHG  *DECK SVP_ELDEND
      SUBROUTINE SVP_ELDEND(NPT,XYZPT,ELD,ELDD,ELDDD,DAB,NDER)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C     --- EVALUATE ELECTRON DENSITY AT A GIVEN SET OF GRID POINTS ---
C     --- OPTIONALLY ALSO COMPUTE 1ST AND 2ND DENSITY DERIVATIVES ---
C
      PARAMETER (MXAO=8192, MXATM=2000, MXGTOT=20000, MXSH=5000)
      LOGICAL IANDJ,NORM,DOUBLE
      LOGICAL DBUG,OUT
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      COMMON /IJPAIR/ IA(MXAO)
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /NSHEL / EX(MXGTOT),CS(MXGTOT),CP(MXGTOT),CD(MXGTOT),
     *                CF(MXGTOT),CG(MXGTOT),CH(MXGTOT),CI(MXGTOT),
     *                KSTART(MXSH),KATOM(MXSH),KTYPE(MXSH),KNG(MXSH),
     *                KLOC(MXSH),KMIN(MXSH),KMAX(MXSH),NSHELL
      COMMON /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON/XYZDN/XINT,YINT,ZINT,X0,Y0,Z0,XI,YI,ZI,XJ,YJ,ZJ,NI,NJ
C
      DIMENSION ELD(NPT),ELDD(3,NPT),ELDDD(6,NPT)
      DIMENSION XYZPT(3,NPT),DAB(*)
      DIMENSION DIJ(225)
      DIMENSION     XG(7,7),    YG(7,7),    ZG(7,7)
      DIMENSION    DXG(5,5),   DYG(5,5),   DZG(5,5)
      DIMENSION   DDXG(5,5),  DDYG(5,5),  DDZG(5,5)
      DIMENSION IJX(35),IJY(35),IJZ(35)
      DATA ZERO  /0.0D+00/
      DATA ONE   /1.0D+00/
      DATA RLN10 /2.30258D+00/
      DATA SQRT3 /1.73205080756888D+00/
      DATA SQRT5 /2.23606797749979D+00/
      DATA SQRT7 /2.64575131106459D+00/
      DATA IJX    / 1, 2, 1, 1, 3, 1, 1, 2, 2, 1,
     1              4, 1, 1, 3, 3, 2, 1, 2, 1, 2,
     2              5, 1, 1, 4, 4, 2, 1, 2, 1, 3,
     3              3, 1, 3, 2, 2/
      DATA IJY    / 1, 1, 2, 1, 1, 3, 1, 2, 1, 2,
     1              1, 4, 1, 2, 1, 3, 3, 1, 2, 2,
     2              1, 5, 1, 2, 1, 4, 4, 1, 2, 3,
     3              1, 3, 2, 3, 2/
      DATA IJZ    / 1, 1, 1, 2, 1, 1, 3, 1, 2, 2,
     1              1, 1, 4, 1, 2, 1, 2, 3, 3, 2,
     2              1, 1, 5, 1, 2, 1, 2, 4, 4, 1,
     3              3, 3, 2, 2, 3/
C
      DBUG=.FALSE.
      OUT =.FALSE.
      OUT =OUT.OR.DBUG
      OUT =OUT.OR.NPRINT.EQ.6
C
      TOL=RLN10*ITOL
      NORM=NORMF.NE.1.OR.NORMP.NE.1
C
      DO IPT=1,NPT
         ELD(IPT)=ZERO
      ENDDO
      IF(NDER.GT.0) THEN
         DO IPT=1,NPT
            DO K=1,3
               ELDD(K,IPT)=ZERO
            ENDDO
         ENDDO
      ENDIF
      IF(NDER.GT.1) THEN
         DO IPT=1,NPT
            DO K=1,6
               ELDDD(K,IPT)=ZERO
            ENDDO
         ENDDO
      ENDIF
C
C    ----- ISHELL -----
C
      DO 9000 II=1,NSHELL
      I=KATOM(II)
      XI=C(1,I)
      YI=C(2,I)
      ZI=C(3,I)
      I1=KSTART(II)
      I2=I1+KNG(II)-1
      LIT=KTYPE(II)
      MINI=KMIN(II)
      MAXI=KMAX(II)
      LOCI=KLOC(II)-MINI
C
C    ----- JSHELL -----
C
      DO 8000 JJ=1,II
      J=KATOM(JJ)
      XJ=C(1,J)
      YJ=C(2,J)
      ZJ=C(3,J)
      J1=KSTART(JJ)
      J2=J1+KNG(JJ)-1
      LJT=KTYPE(JJ)
      MINJ=KMIN(JJ)
      MAXJ=KMAX(JJ)
      LOCJ=KLOC(JJ)-MINJ
C
      IANDJ=II.EQ.JJ
      RR=(XI-XJ)**2+(YI-YJ)**2+(ZI-ZJ)**2
C
C    ----- I PRIMITIVE -----
C
      DO 7000 IG=I1,I2
      AI=EX(IG)
      ARRI=AI*RR
      AXI=AI*XI
      AYI=AI*YI
      AZI=AI*ZI
      CSI=CS(IG)
      CPI=CP(IG)
      CDI=CD(IG)
      CFI=CF(IG)
      CGI=CG(IG)
C
C    ----- J PRIMITIVE -----
C
      JGMAX=J2
      IF(IANDJ) JGMAX=IG
      DO 6000 JG=J1,JGMAX
      AJ=EX(JG)
      AA=AI+AJ
      AA1=ONE/AA
      DUM=AJ*ARRI*AA1
      IF(DUM.GT.TOL) GO TO 6000
      FAC= EXP(-DUM)
      CSJ=CS(JG)
      CPJ=CP(JG)
      CDJ=CD(JG)
      CFJ=CF(JG)
      CGJ=CG(JG)
      AX=(AXI+AJ*XJ)*AA1
      AY=(AYI+AJ*YJ)*AA1
      AZ=(AZI+AJ*ZJ)*AA1
C
C    ----- DENSITY FACTOR -----
C
      DOUBLE=IANDJ.AND.IG.NE.JG
      IJ=0
      DO 360 I=MINI,MAXI
      GO TO (110,120,220,220,130,220,220,140,220,220,
     1       150,220,220,160,220,220,220,220,220,170,
     2       180,220,220,190,220,220,220,220,220,200,
     3       220,220,210,220,220),I
  110 DUM1=CSI*FAC
      GO TO 220
  120 DUM1=CPI*FAC
      GO TO 220
  130 DUM1=CDI*FAC
      GO TO 220
  140 IF(NORM) DUM1=DUM1*SQRT3
      GO TO 220
  150 DUM1=CFI*FAC
      GO TO 220
  160 IF(NORM) DUM1=DUM1*SQRT5
      GO TO 220
  170 IF(NORM) DUM1=DUM1*SQRT3
      GO TO 220
  180 DUM1=CGI*FAC
      GO TO 220
  190 IF(NORM) DUM1=DUM1*SQRT7
      GO TO 220
  200 IF(NORM) DUM1=DUM1*SQRT5/SQRT3
      GO TO 220
  210 IF(NORM) DUM1=DUM1*SQRT3
  220 CONTINUE
C
      JMAX=MAXJ
      IF(IANDJ) JMAX=I
      DO 360 J=MINJ,JMAX
      GO TO (230,250,350,350,260,350,350,270,350,350,
     1       280,350,350,290,350,350,350,350,350,300,
     2       310,350,350,320,350,350,350,350,350,330,
     3       350,350,340,350,350),J
  230 DUM2=DUM1*CSJ
      IF(.NOT.DOUBLE) GO TO 350
      IF(I.GT.1) GO TO 240
      DUM2=DUM2+DUM2
      GO TO 350
  240 DUM2=DUM2+CSI*CPJ*FAC
      GO TO 350
  250 DUM2=DUM1*CPJ
      IF(DOUBLE) DUM2=DUM2+DUM2
      GO TO 350
  260 DUM2=DUM1*CDJ
      IF(DOUBLE) DUM2=DUM2+DUM2
      GO TO 350
  270 IF(NORM) DUM2=DUM2*SQRT3
      GO TO 350
  280 DUM2=DUM1*CFJ
      IF(DOUBLE) DUM2=DUM2+DUM2
      GO TO 350
  290 IF(NORM) DUM2=DUM2*SQRT5
      GO TO 350
  300 IF(NORM) DUM2=DUM2*SQRT3
      GO TO 350
  310 DUM2=DUM1*CGJ
      IF(DOUBLE) DUM2=DUM2+DUM2
      GO TO 350
  320 IF(NORM) DUM2=DUM2*SQRT7
      GO TO 350
  330 IF(NORM) DUM2=DUM2*SQRT5/SQRT3
      GO TO 350
  340 IF(NORM) DUM2=DUM2*SQRT3
  350 CONTINUE
C
      IJ=IJ+1
  360 DIJ(IJ)=DUM2
C
C    ----- LOOP OVER GRID POINTS -----
C
      DO IPT=ME+1,NPT,NPROC
         X0 = XYZPT(1,IPT)
         Y0 = XYZPT(2,IPT)
         Z0 = XYZPT(3,IPT)
C
         DUM = AA*((X0-AX)**2+(Y0-AY)**2+(Z0-AZ)**2)
         IF(DUM.LE.TOL) THEN
            FAC = EXP(-DUM)
C
C    ----- CHARGE DENSITY AND DERIVATIVE VALUES -----
C
            DO J=1,LJT+NDER
               NJ=J
               DO I=1,LIT+NDER
                  NI=I
                  CALL CHGXYZ
                  XG(I,J)=XINT
                  YG(I,J)=YINT
                  ZG(I,J)=ZINT
               ENDDO
            ENDDO
            IF(NDER.GT.0) THEN
                CALL CHDXYZ(XG,YG,ZG,DXG,DYG,DZG,DDXG,DDYG,DDZG,
     1                      LIT,LJT,AI,AJ,NDER)
            ENDIF
C
C    ----- WAVEFUNCTION DENSITY VALUES -----
C
            IJ=0
            DO I=MINI,MAXI
               IX=IJX(I)
               IY=IJY(I)
               IZ=IJZ(I)
               JMAX=MAXJ
               IF(IANDJ) JMAX=I
               DO J=MINJ,JMAX
                  JX=IJX(J)
                  JY=IJY(J)
                  JZ=IJZ(J)
                  IJ=IJ+1
                  VAL  =  XG(IX,JX)*  YG(IY,JY)*  ZG(IZ,JZ)
                  ELDEN=DIJ(IJ)*VAL  *FAC
                  DEN=DAB(IA(LOCI+I)+(LOCJ+J))
                  IF(.NOT.IANDJ.OR.J.NE.I) DEN=DEN+DEN
                  ELD(IPT)=ELD(IPT)+DEN*ELDEN
               ENDDO
            ENDDO
C
C    ----- 1ST DERIVATIVE VALUES -----
C
            IF(NDER.GT.0) THEN
               IJ=0
               DO I=MINI,MAXI
                  IX=IJX(I)
                  IY=IJY(I)
                  IZ=IJZ(I)
                  JMAX=MAXJ
                  IF(IANDJ) JMAX=I
                  DO J=MINJ,JMAX
                     JX=IJX(J)
                     JY=IJY(J)
                     JZ=IJZ(J)
                     IJ=IJ+1
                     VALX = DXG(IX,JX)*  YG(IY,JY)*  ZG(IZ,JZ)
                     VALY =  XG(IX,JX)* DYG(IY,JY)*  ZG(IZ,JZ)
                     VALZ =  XG(IX,JX)*  YG(IY,JY)* DZG(IZ,JZ)
                     ELDX =DIJ(IJ)*VALX *FAC
                     ELDY =DIJ(IJ)*VALY *FAC
                     ELDZ =DIJ(IJ)*VALZ *FAC
                     DEN=DAB(IA(LOCI+I)+(LOCJ+J))
                     IF(.NOT.IANDJ.OR.J.NE.I) DEN=DEN+DEN
                     ELDD(1,IPT)=ELDD(1,IPT)+DEN*ELDX
                     ELDD(2,IPT)=ELDD(2,IPT)+DEN*ELDY
                     ELDD(3,IPT)=ELDD(3,IPT)+DEN*ELDZ
                  ENDDO
               ENDDO
            ENDIF
C
C    ----- 2D DERIVATIVE VALUES -----
C
            IF(NDER.GT.1) THEN
               IJ=0
               DO I=MINI,MAXI
                  IX=IJX(I)
                  IY=IJY(I)
                  IZ=IJZ(I)
                  JMAX=MAXJ
                  IF(IANDJ) JMAX=I
                  DO J=MINJ,JMAX
                     JX=IJX(J)
                     JY=IJY(J)
                     JZ=IJZ(J)
                     IJ=IJ+1
                     VALXX=DDXG(IX,JX)*  YG(IY,JY)*  ZG(IZ,JZ)
                     VALYY=  XG(IX,JX)*DDYG(IY,JY)*  ZG(IZ,JZ)
                     VALZZ=  XG(IX,JX)*  YG(IY,JY)*DDZG(IZ,JZ)
                     VALXY= DXG(IX,JX)* DYG(IY,JY)*  ZG(IZ,JZ)
                     VALXZ= DXG(IX,JX)*  YG(IY,JY)* DZG(IZ,JZ)
                     VALYZ=  XG(IX,JX)* DYG(IY,JY)* DZG(IZ,JZ)
                     ELDXX=DIJ(IJ)*VALXX*FAC
                     ELDYY=DIJ(IJ)*VALYY*FAC
                     ELDZZ=DIJ(IJ)*VALZZ*FAC
                     ELDXY=DIJ(IJ)*VALXY*FAC
                     ELDXZ=DIJ(IJ)*VALXZ*FAC
                     ELDYZ=DIJ(IJ)*VALYZ*FAC
                     DEN=DAB(IA(LOCI+I)+(LOCJ+J))
                     IF(.NOT.IANDJ.OR.J.NE.I) DEN=DEN+DEN
                     ELDDD(1,IPT)=ELDDD(1,IPT)+DEN*ELDXX
                     ELDDD(2,IPT)=ELDDD(2,IPT)+DEN*ELDYY
                     ELDDD(3,IPT)=ELDDD(3,IPT)+DEN*ELDZZ
                     ELDDD(4,IPT)=ELDDD(4,IPT)+DEN*ELDXY
                     ELDDD(5,IPT)=ELDDD(5,IPT)+DEN*ELDXZ
                     ELDDD(6,IPT)=ELDDD(6,IPT)+DEN*ELDYZ
                  ENDDO
               ENDDO
            ENDIF
C
         ENDIF
      ENDDO
C
      IF(GOPARR) THEN
                       CALL DDI_GSUMF(961,ELD  ,  NPT)
         IF(NDER.GT.0) CALL DDI_GSUMF(962,ELDD ,3*NPT)
         IF(NDER.GT.1) CALL DDI_GSUMF(963,ELDDD,6*NPT)
      END IF
C
 6000 CONTINUE
 7000 CONTINUE
C
 8000 CONTINUE
 9000 CONTINUE
C
      RETURN
      END
C*MODULE SVPCHG  *DECK CHGXYZ
      SUBROUTINE CHGXYZ
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/XYZDN/XINT,YINT,ZINT,X0,Y0,Z0,XI,YI,ZI,XJ,YJ,ZJ,NI,NJ
      DATA ONE /1.0D+00/
C
      XINT=ONE
      YINT=ONE
      ZINT=ONE
      PTXI=X0-XI
      PTYI=Y0-YI
      PTZI=Z0-ZI
      PTXJ=X0-XJ
      PTYJ=Y0-YJ
      PTZJ=Z0-ZJ
      GO TO (7,6,5,4,3,2,1),NI
    1 XINT=XINT*PTXI
      YINT=YINT*PTYI
      ZINT=ZINT*PTZI
    2 XINT=XINT*PTXI
      YINT=YINT*PTYI
      ZINT=ZINT*PTZI
    3 XINT=XINT*PTXI
      YINT=YINT*PTYI
      ZINT=ZINT*PTZI
    4 XINT=XINT*PTXI
      YINT=YINT*PTYI
      ZINT=ZINT*PTZI
    5 XINT=XINT*PTXI
      YINT=YINT*PTYI
      ZINT=ZINT*PTZI
    6 XINT=XINT*PTXI
      YINT=YINT*PTYI
      ZINT=ZINT*PTZI
    7 GO TO (14,13,12,11,10,9,8),NJ
    8 XINT=XINT*PTXJ
      YINT=YINT*PTYJ
      ZINT=ZINT*PTZJ
    9 XINT=XINT*PTXJ
      YINT=YINT*PTYJ
      ZINT=ZINT*PTZJ
   10 XINT=XINT*PTXJ
      YINT=YINT*PTYJ
      ZINT=ZINT*PTZJ
   11 XINT=XINT*PTXJ
      YINT=YINT*PTYJ
      ZINT=ZINT*PTZJ
   12 XINT=XINT*PTXJ
      YINT=YINT*PTYJ
      ZINT=ZINT*PTZJ
   13 XINT=XINT*PTXJ
      YINT=YINT*PTYJ
      ZINT=ZINT*PTZJ
   14 CONTINUE
      RETURN
      END
C*MODULE SVPCHG  *DECK CHDXYZ
      SUBROUTINE CHDXYZ(XG,YG,ZG,DXG,DYG,DZG,DDXG,DDYG,DDZG,
     1                  LIT,LJT,AI,AJ,NDER)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION     XG(7,*),    YG(7,*),    ZG(7,*)
      DIMENSION    DXG(5,*),   DYG(5,*),   DZG(5,*)
      DIMENSION   DDXG(5,*),  DDYG(5,*),  DDZG(5,*)
      DIMENSION      X(7,7),     Y(7,7),     Z(7,7)
      DIMENSION   DIDX(5,5),  DIDY(5,5),  DIDZ(5,5)
      DIMENSION   DJDX(5,5),  DJDY(5,5),  DJDZ(5,5)
      DIMENSION DIIDDX(5,5),DIIDDY(5,5),DIIDDZ(5,5)
      DIMENSION DIJDDX(5,5),DIJDDY(5,5),DIJDDZ(5,5)
      DIMENSION DJJDDX(5,5),DJJDDY(5,5),DJJDDZ(5,5)
C
      DO J=1,LJT+NDER
         DO I=1,LIT+NDER
            X(I,J)=XG(I,J)
            Y(I,J)=YG(I,J)
            Z(I,J)=ZG(I,J)
         ENDDO
      ENDDO
C
C     ----- D(I)/DX ... -----
C
      DO J=1,LJT
         DIDX(1,J)=-X(2,J)*(AI+AI)
         DIDY(1,J)=-Y(2,J)*(AI+AI)
         DIDZ(1,J)=-Z(2,J)*(AI+AI)
      ENDDO
      IF(LIT.GT.1) THEN
         DO I=2,LIT
            DO J=1,LJT
               DIDX(I,J)=-X(I+1,J)*(AI+AI)+X(I-1,J)*(I-1)
               DIDY(I,J)=-Y(I+1,J)*(AI+AI)+Y(I-1,J)*(I-1)
               DIDZ(I,J)=-Z(I+1,J)*(AI+AI)+Z(I-1,J)*(I-1)
            ENDDO
         ENDDO
      ENDIF
C
C     ----- D(J)/DX ... -----
C
      DO I=1,LIT
         DJDX(I,1)=-X(I,2)*(AJ+AJ)
         DJDY(I,1)=-Y(I,2)*(AJ+AJ)
         DJDZ(I,1)=-Z(I,2)*(AJ+AJ)
      ENDDO
      IF(LJT.GT.1) THEN
         DO J=2,LJT
            DO I=1,LIT
               DJDX(I,J)=-X(I,J+1)*(AJ+AJ)+X(I,J-1)*(J-1)
               DJDY(I,J)=-Y(I,J+1)*(AJ+AJ)+Y(I,J-1)*(J-1)
               DJDZ(I,J)=-Z(I,J+1)*(AJ+AJ)+Z(I,J-1)*(J-1)
            ENDDO
         ENDDO
      ENDIF
C
C     ----- D(IJ)/DX ... -----
C
      DO J=1,LJT
         DO I=1,LIT
            DXG(I,J)=DIDX(I,J)+DJDX(I,J)
            DYG(I,J)=DIDY(I,J)+DJDY(I,J)
            DZG(I,J)=DIDZ(I,J)+DJDZ(I,J)
         ENDDO
      ENDDO
C
      IF(NDER.GT.1) THEN
C
C     ----- DD(I)/DX2 ... -----
C
      DO J=1,LJT
         DIIDDX(1,J)=(X(3,J)*(AI+AI)-X(1,J))*(AI+AI)
         DIIDDY(1,J)=(Y(3,J)*(AI+AI)-Y(1,J))*(AI+AI)
         DIIDDZ(1,J)=(Z(3,J)*(AI+AI)-Z(1,J))*(AI+AI)
      ENDDO
      IF(LIT.GT.1) THEN
         DO J=1,LJT
         DIIDDX(2,J)=(X(4,J)*(AI+AI)-X(2,J)*(2+2-1))*(AI+AI)
         DIIDDY(2,J)=(Y(4,J)*(AI+AI)-Y(2,J)*(2+2-1))*(AI+AI)
         DIIDDZ(2,J)=(Z(4,J)*(AI+AI)-Z(2,J)*(2+2-1))*(AI+AI)
         ENDDO
         IF(LIT.GT.2) THEN
            DO I=3,LIT
               DO J=1,LJT
               DIIDDX(I,J)=
     1            (X(I+2,J)*(AI+AI)-X(I,J)*(I+I-1))*(AI+AI)
     2            +X(I-2,J)*((I-1)*(I-2))
               DIIDDY(I,J)=
     1            (Y(I+2,J)*(AI+AI)-Y(I,J)*(I+I-1))*(AI+AI)
     2            +Y(I-2,J)*((I-1)*(I-2))
               DIIDDZ(I,J)=
     1            (Z(I+2,J)*(AI+AI)-Z(I,J)*(I+I-1))*(AI+AI)
     2            +Z(I-2,J)*((I-1)*(I-2))
               ENDDO
            ENDDO
         ENDIF
      ENDIF
C
C     ----- DD(J)/DX2 ... -----
C
      DO I=1,LIT
         DJJDDX(I,1)=(X(I,3)*(AJ+AJ)-X(I,1))*(AJ+AJ)
         DJJDDY(I,1)=(Y(I,3)*(AJ+AJ)-Y(I,1))*(AJ+AJ)
         DJJDDZ(I,1)=(Z(I,3)*(AJ+AJ)-Z(I,1))*(AJ+AJ)
      ENDDO
      IF(LJT.GT.1) THEN
         DO I=1,LIT
         DJJDDX(I,2)=(X(I,4)*(AJ+AJ)-X(I,2)*(2+2-1))*(AJ+AJ)
         DJJDDY(I,2)=(Y(I,4)*(AJ+AJ)-Y(I,2)*(2+2-1))*(AJ+AJ)
         DJJDDZ(I,2)=(Z(I,4)*(AJ+AJ)-Z(I,2)*(2+2-1))*(AJ+AJ)
         ENDDO
         IF(LJT.GT.2) THEN
            DO J=3,LJT
               DO I=1,LIT
               DJJDDX(I,J)=
     1            (X(I,J+2)*(AJ+AJ)-X(I,J)*(J+J-1))*(AJ+AJ)
     2            +X(I,J-2)*((J-1)*(J-2))
               DJJDDY(I,J)=
     1            (Y(I,J+2)*(AJ+AJ)-Y(I,J)*(J+J-1))*(AJ+AJ)
     2            +Y(I,J-2)*((J-1)*(J-2))
               DJJDDZ(I,J)=
     1            (Z(I,J+2)*(AJ+AJ)-Z(I,J)*(J+J-1))*(AJ+AJ)
     2            +Z(I,J-2)*((J-1)*(J-2))
               ENDDO
            ENDDO
         ENDIF
      ENDIF
C
C     ----- D(I)/DX * D(J)/DX ... -----
C
      DIJDDX(1,1)= X(2,2)*((AJ+AJ)*(AI+AI))
      DIJDDY(1,1)= Y(2,2)*((AJ+AJ)*(AI+AI))
      DIJDDZ(1,1)= Z(2,2)*((AJ+AJ)*(AI+AI))
C
      IF(LJT.GT.1) THEN
         DO J=2,LJT
         DIJDDX(1,J)=(X(2,J+1)*(AJ+AJ)-X(2,J-1)*(J-1))*(AI+AI)
         DIJDDY(1,J)=(Y(2,J+1)*(AJ+AJ)-Y(2,J-1)*(J-1))*(AI+AI)
         DIJDDZ(1,J)=(Z(2,J+1)*(AJ+AJ)-Z(2,J-1)*(J-1))*(AI+AI)
         ENDDO
      ENDIF
      IF(LIT.GT.1) THEN
         DO I=2,LIT
         DIJDDX(I,1)=(X(I+1,2)*(AI+AI)-X(I-1,2)*(I-1))*(AJ+AJ)
         DIJDDY(I,1)=(Y(I+1,2)*(AI+AI)-Y(I-1,2)*(I-1))*(AJ+AJ)
         DIJDDZ(I,1)=(Z(I+1,2)*(AI+AI)-Z(I-1,2)*(I-1))*(AJ+AJ)
         ENDDO
         IF(LJT.GT.1) THEN
            DO I=2,LIT
               DO J=2,LJT
                  DIJDDX(I,J)=
     1      (X(I+1,J+1)*(AJ+AJ)-X(I+1,J-1)*(J-1))*(AI+AI)
     2     -(X(I-1,J+1)*(AJ+AJ)-X(I-1,J-1)*(J-1))*(I-1)
                  DIJDDY(I,J)=
     1      (Y(I+1,J+1)*(AJ+AJ)-Y(I+1,J-1)*(J-1))*(AI+AI)
     2     -(Y(I-1,J+1)*(AJ+AJ)-Y(I-1,J-1)*(J-1))*(I-1)
                  DIJDDZ(I,J)=
     1      (Z(I+1,J+1)*(AJ+AJ)-Z(I+1,J-1)*(J-1))*(AI+AI)
     2     -(Z(I-1,J+1)*(AJ+AJ)-Z(I-1,J-1)*(J-1))*(I-1)
               ENDDO
            ENDDO
         ENDIF
      ENDIF
C
C     ----- D2(IJ)/DX2 ... -----
C
      DO J=1,LJT
         DO I=1,LIT
            DDXG(I,J)=DIIDDX(I,J)+DIJDDX(I,J)
     1               +DIJDDX(I,J)+DJJDDX(I,J)
            DDYG(I,J)=DIIDDY(I,J)+DIJDDY(I,J)
     1               +DIJDDY(I,J)+DJJDDY(I,J)
            DDZG(I,J)=DIIDDZ(I,J)+DIJDDZ(I,J)
     1               +DIJDDZ(I,J)+DJJDDZ(I,J)
         ENDDO
      ENDDO
C
      ENDIF
C
      RETURN
      END
C*MODULE SVPCHG  *DECK SVP_ELDENC
      SUBROUTINE SVP_ELDENC(NPT,XYZPT,ELDEN,DAB)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (MXAO=8192, MXATM=2000, MXGTOT=20000, MXSH=5000)
      LOGICAL IANDJ
      LOGICAL NORM,DOUBLE
C
      COMMON /IJPAIR/ IA(MXAO)
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /NSHEL / EX(MXGTOT),CS(MXGTOT),CP(MXGTOT),CD(MXGTOT),
     *                CF(MXGTOT),CG(MXGTOT),CH(MXGTOT),CI(MXGTOT),
     *                KSTART(MXSH),KATOM(MXSH),KTYPE(MXSH),KNG(MXSH),
     *                KLOC(MXSH),KMIN(MXSH),KMAX(MXSH),NSHELL
      COMMON /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK
      COMMON/XYZDEN/XINT,YINT,ZINT,X0,Y0,Z0,XI,YI,ZI,XJ,YJ,ZJ,NI,NJ
C
      DIMENSION ELDEN(1),XYZPT(3,NPT),DAB(1)
      DIMENSION DIJ(225)
      DIMENSION XIN(5,5),YIN(5,5),ZIN(5,5)
      DIMENSION IJX(35),IJY(35),IJZ(35)
      DATA ZERO  /0.0D+00/
      DATA ONE   /1.0D+00/
      DATA RLN10 /2.30258D+00/
      DATA SQRT3 /1.73205080756888D+00/
      DATA SQRT5 /2.23606797749979D+00/
      DATA SQRT7 /2.64575131106459D+00/
      DATA IJX    / 1, 2, 1, 1, 3, 1, 1, 2, 2, 1,
     1              4, 1, 1, 3, 3, 2, 1, 2, 1, 2,
     2              5, 1, 1, 4, 4, 2, 1, 2, 1, 3,
     3              3, 1, 3, 2, 2/
      DATA IJY    / 1, 1, 2, 1, 1, 3, 1, 2, 1, 2,
     1              1, 4, 1, 2, 1, 3, 3, 1, 2, 2,
     2              1, 5, 1, 2, 1, 4, 4, 1, 2, 3,
     3              1, 3, 2, 3, 2/
      DATA IJZ    / 1, 1, 1, 2, 1, 1, 3, 1, 2, 2,
     1              1, 1, 4, 1, 2, 1, 2, 3, 3, 2,
     2              1, 1, 5, 1, 2, 1, 2, 4, 4, 1,
     3              3, 3, 2, 2, 3/
C
      TOL=RLN10*ITOL
      NORM=NORMF.NE.1.OR.NORMP.NE.1
C
      DO 10 IPT=1,NPT
   10 ELDEN(IPT)=ZERO
C
C     ----- ISHELL -----
C
      DO 9000 II=1,NSHELL
      I=KATOM(II)
      XI=C(1,I)
      YI=C(2,I)
      ZI=C(3,I)
      I1=KSTART(II)
      I2=I1+KNG(II)-1
      LIT=KTYPE(II)
      MINI=KMIN(II)
      MAXI=KMAX(II)
      LOCI=KLOC(II)-MINI
C
C     ----- JSHELL -----
C
      DO 8000 JJ=1,II
      J=KATOM(JJ)
      XJ=C(1,J)
      YJ=C(2,J)
      ZJ=C(3,J)
      J1=KSTART(JJ)
      J2=J1+KNG(JJ)-1
      LJT=KTYPE(JJ)
      MINJ=KMIN(JJ)
      MAXJ=KMAX(JJ)
      LOCJ=KLOC(JJ)-MINJ
C
      IANDJ=II.EQ.JJ
      RR=(XI-XJ)**2+(YI-YJ)**2+(ZI-ZJ)**2
C
      IJ=0
      DO 100 I=MINI,MAXI
      JMAX=MAXJ
      IF(IANDJ) JMAX=I
      DO 100 J=MINJ,JMAX
      IJ=IJ+1
  100 CONTINUE
C
C     ----- I PRIMITIVE -----
C
      DO 7000 IG=I1,I2
      AI=EX(IG)
      ARRI=AI*RR
      AXI=AI*XI
      AYI=AI*YI
      AZI=AI*ZI
      CSI=CS(IG)
      CPI=CP(IG)
      CDI=CD(IG)
      CFI=CF(IG)
      CGI=CG(IG)
C
C     ----- J PRIMITIVE -----
C
      JGMAX=J2
      IF(IANDJ) JGMAX=IG
      DO 6000 JG=J1,JGMAX
      AJ=EX(JG)
      AA=AI+AJ
      AA1=ONE/AA
      DUM=AJ*ARRI*AA1
      IF(DUM.GT.TOL) GO TO 6000
      FAC= EXP(-DUM)
      CSJ=CS(JG)
      CPJ=CP(JG)
      CDJ=CD(JG)
      CFJ=CF(JG)
      CGJ=CG(JG)
      AX=(AXI+AJ*XJ)*AA1
      AY=(AYI+AJ*YJ)*AA1
      AZ=(AZI+AJ*ZJ)*AA1
C
C     ----- DENSITY FACTOR -----
C
      DOUBLE=IANDJ.AND.IG.NE.JG
      IJ=0
      DO 360 I=MINI,MAXI
      GO TO (110,120,220,220,130,220,220,140,220,220,
     1       150,220,220,160,220,220,220,220,220,170,
     2       180,220,220,190,220,220,220,220,220,200,
     3       220,220,210,220,220),I
  110 DUM1=CSI*FAC
      GO TO 220
  120 DUM1=CPI*FAC
      GO TO 220
  130 DUM1=CDI*FAC
      GO TO 220
  140 IF(NORM) DUM1=DUM1*SQRT3
      GO TO 220
  150 DUM1=CFI*FAC
      GO TO 220
  160 IF(NORM) DUM1=DUM1*SQRT5
      GO TO 220
  170 IF(NORM) DUM1=DUM1*SQRT3
      GO TO 220
  180 DUM1=CGI*FAC
      GO TO 220
  190 IF(NORM) DUM1=DUM1*SQRT7
      GO TO 220
  200 IF(NORM) DUM1=DUM1*SQRT5/SQRT3
      GO TO 220
  210 IF(NORM) DUM1=DUM1*SQRT3
  220 CONTINUE
C
      JMAX=MAXJ
      IF(IANDJ) JMAX=I
      DO 360 J=MINJ,JMAX
      GO TO (230,250,350,350,260,350,350,270,350,350,
     1       280,350,350,290,350,350,350,350,350,300,
     2       310,350,350,320,350,350,350,350,350,330,
     3       350,350,340,350,350),J
  230 DUM2=DUM1*CSJ
      IF(.NOT.DOUBLE) GO TO 350
      IF(I.GT.1) GO TO 240
      DUM2=DUM2+DUM2
      GO TO 350
  240 DUM2=DUM2+CSI*CPJ*FAC
      GO TO 350
  250 DUM2=DUM1*CPJ
      IF(DOUBLE) DUM2=DUM2+DUM2
      GO TO 350
  260 DUM2=DUM1*CDJ
      IF(DOUBLE) DUM2=DUM2+DUM2
      GO TO 350
  270 IF(NORM) DUM2=DUM2*SQRT3
      GO TO 350
  280 DUM2=DUM1*CFJ
      IF(DOUBLE) DUM2=DUM2+DUM2
      GO TO 350
  290 IF(NORM) DUM2=DUM2*SQRT5
      GO TO 350
  300 IF(NORM) DUM2=DUM2*SQRT3
      GO TO 350
  310 DUM2=DUM1*CGJ
      IF(DOUBLE) DUM2=DUM2+DUM2
      GO TO 350
  320 IF(NORM) DUM2=DUM2*SQRT7
      GO TO 350
  330 IF(NORM) DUM2=DUM2*SQRT5/SQRT3
      GO TO 350
  340 IF(NORM) DUM2=DUM2*SQRT3
  350 CONTINUE
C
      IJ=IJ+1
  360 DIJ(IJ)=DUM2
C
C     ----- ELECTRON DENSITY -----
C
      DO 500 IPT=1,NPT
      X0 = XYZPT(1,IPT)
      Y0 = XYZPT(2,IPT)
      Z0 = XYZPT(3,IPT)
C
      DUM = AA*((X0-AX)**2+(Y0-AY)**2+(Z0-AZ)**2)
      IF(DUM.GT.TOL) GO TO 500
      FAC = EXP(-DUM)
C
C     ----- DENSITY VALUES -----
C
      DO 370 J=1,LJT
      NJ=J
      DO 370 I=1,LIT
      NI=I
      CALL DENXYZ
      XIN(I,J)=XINT
      YIN(I,J)=YINT
      ZIN(I,J)=ZINT
  370 CONTINUE
C
      IJ=0
      DO 390 I=MINI,MAXI
      IX=IJX(I)
      IY=IJY(I)
      IZ=IJZ(I)
      JMAX=MAXJ
      IF(IANDJ) JMAX=I
      DO 390 J=MINJ,JMAX
      JX=IJX(J)
      JY=IJY(J)
      JZ=IJZ(J)
      IJ=IJ+1
      ELD=FAC*DIJ(IJ)*XIN(IX,JX)*YIN(IY,JY)*ZIN(IZ,JZ)
      DEN=DAB(IA(LOCI+I)+(LOCJ+J))
      IF(.NOT.IANDJ.OR.J.NE.I) DEN=DEN+DEN
      ELDEN(IPT)=ELDEN(IPT)+ELD*DEN
  390 CONTINUE
C
  500 CONTINUE
C
 6000 CONTINUE
 7000 CONTINUE
C
 8000 CONTINUE
 9000 CONTINUE
C
      RETURN
      END
C*MODULE SVPCHG  *DECK DENXYZ
      SUBROUTINE DENXYZ
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/XYZDEN/XINT,YINT,ZINT,X0,Y0,Z0,XI,YI,ZI,XJ,YJ,ZJ,NI,NJ
      DATA ONE /1.0D+00/
C
      XINT=ONE
      YINT=ONE
      ZINT=ONE
      PTXI=X0-XI
      PTYI=Y0-YI
      PTZI=Z0-ZI
      PTXJ=X0-XJ
      PTYJ=Y0-YJ
      PTZJ=Z0-ZJ
      GO TO (7,6,5,4,3,2,1),NI
    1 XINT=XINT*PTXI
      YINT=YINT*PTYI
      ZINT=ZINT*PTZI
    2 XINT=XINT*PTXI
      YINT=YINT*PTYI
      ZINT=ZINT*PTZI
    3 XINT=XINT*PTXI
      YINT=YINT*PTYI
      ZINT=ZINT*PTZI
    4 XINT=XINT*PTXI
      YINT=YINT*PTYI
      ZINT=ZINT*PTZI
    5 XINT=XINT*PTXI
      YINT=YINT*PTYI
      ZINT=ZINT*PTZI
    6 XINT=XINT*PTXI
      YINT=YINT*PTYI
      ZINT=ZINT*PTZI
    7 GO TO (14,13,12,11,10,9,8),NJ
    8 XINT=XINT*PTXJ
      YINT=YINT*PTYJ
      ZINT=ZINT*PTZJ
    9 XINT=XINT*PTXJ
      YINT=YINT*PTYJ
      ZINT=ZINT*PTZJ
   10 XINT=XINT*PTXJ
      YINT=YINT*PTYJ
      ZINT=ZINT*PTZJ
   11 XINT=XINT*PTXJ
      YINT=YINT*PTYJ
      ZINT=ZINT*PTZJ
   12 XINT=XINT*PTXJ
      YINT=YINT*PTYJ
      ZINT=ZINT*PTZJ
   13 XINT=XINT*PTXJ
      YINT=YINT*PTYJ
      ZINT=ZINT*PTZJ
   14 CONTINUE
      RETURN
      END
C*MODULE SVPCHG  *DECK SVPEPF
      SUBROUTINE SVPEPF(DENS,IADDR,ILAST,NCAV,CAVC,CAVN,
     1                  CAVPOT,ELP,CAVFLD,ELF)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C     ----- GET SOLUTE POTENTIAL AND/OR NORMAL ELECTRIC FIELD AT SURFACE
C
      LOGICAL     DBUG
      LOGICAL     MORE
      LOGICAL     OUT
      LOGICAL     SOME
      LOGICAL     CAVPOT,CAVFLD
C
      COMMON /FMCOM / X(1)
      COMMON /IOFILE/ IR,IW,IP,IJK,IJKT,IDAF,NAV,IODA(950)
      COMMON/SVPDBG/IDBG
      DIMENSION   DENS(*),CAVC(3,*),CAVN(3,*),ELP(*),ELF(*)
C
      DBUG=.FALSE.
      DBUG=DBUG.OR.IDBG.GE.4
      MORE=.FALSE.
      MORE=MORE.OR.DBUG.OR.IDBG.GE.3
      OUT =.FALSE.
      OUT =OUT.OR.MORE.OR.IDBG.GE.2
      SOME=.FALSE.
      SOME=SOME.OR.OUT.OR.IDBG.GE.1
C
C     ----- SET POINTERS FOR PARTITIONING OF CORE -----
C
C     -SCRATCH SPACE FOR ALL 3 COMPONENTS OF ELECTRONIC PART OF ELF- AT
C
      IF(CAVFLD) THEN
         I10=IADDR
         I20=I10+3*NCAV
         LAST=I20-1
         IF(LAST.GT.ILAST) THEN
            WRITE(IW,*) 'NOT ENOUGH MEMORY FOR ELF. STOP'
            WRITE(IW,*) 'IADDR = ',IADDR
            WRITE(IW,*) 'ILAST = ',ILAST
            WRITE(IW,*) 'I10   = ',I10
            WRITE(IW,*) 'LAST  = ',LAST
            CALL ABRT
         ENDIF
      ENDIF
C
C     ----- GET THE POTENTIAL ON THE CAVITY SURFACE -----
C
      IF(CAVPOT) THEN
         CALL SVPELP(DENS,NCAV,CAVC,ELP)
      ENDIF
C
C     ----- GET THE NORMAL ELECTRIC FIELD ON THE CAVITY SURFACE -----
C
      IF(CAVFLD) THEN
         CALL SVPELF(DENS,NCAV,CAVC,CAVN,ELF,X(I10))
      ENDIF
C
      RETURN
      END
C*MODULE SVPCHG  *DECK SVPELP
      SUBROUTINE SVPELP(DENS,NCAV,CAVC,ELP)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C     ----- SOLUTE ELECTROSTATIC POTENTIAL ON CAVITY SURFACE -----
C
      PARAMETER (ZERO=0.0D+00)
      PARAMETER (MXATM=2000)
      LOGICAL SOME
      LOGICAL OUT
      LOGICAL DBUG
      COMMON /IOFILE/ IR,IW,IP,IJK,IJKT,IDAF,NAV,IODA(950)
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      DIMENSION   CAVC(3,*)
      DIMENSION   DENS(*)
      DIMENSION   ELP(*)
C
      DBUG=.FALSE.
      OUT =.FALSE.
      OUT =OUT.OR.DBUG
      SOME=.FALSE.
      SOME=SOME.OR.OUT
      IF(SOME) THEN
         WRITE(IW,9999)
         WRITE(IW,9998)
      ENDIF
C
C     ----- CALCULATE ELECTRONIC CONTRIBUTION -----
C
      CALL SVP_ELPOTC(NCAV,CAVC,ELP,DENS)
C
C     ----- COMPLETE ELECTROSTATIC POTENTIAL -----
C
      IF(DBUG) THEN
         WRITE(IW,9997)
      ENDIF
C
      DO JPT=1,NCAV
         XJ = CAVC(1,JPT)
         YJ = CAVC(2,JPT)
         ZJ = CAVC(3,JPT)
C
C     ----- NUCLEAR CONTRIBUTION ... -----
C
         ELPOTN = ZERO
         DO IAT = 1,NAT
            XJN = XJ - C(1,IAT)
            YJN = YJ - C(2,IAT)
            ZJN = ZJ - C(3,IAT)
            RJN = SQRT(XJN*XJN + YJN*YJN + ZJN*ZJN)
            DUM    = ZAN(IAT)/RJN
            ELPOTN = ELPOTN +           DUM
         ENDDO
C
C     ----- ELECTRON CONTRIBUTION ... -----
C
         DUME    = -ELP(JPT)
         DUMN    =  ELPOTN
         DUM     =  DUMN   + DUME
         ELP(JPT)=  DUM
         IF(DBUG) THEN
            WRITE(IW,9996) JPT,XJ,YJ,ZJ,DUM,DUMN,DUME
         ENDIF
      ENDDO
C
      IF(SOME) THEN
         WRITE(IW,9994)
      ENDIF
      CALL FLSHBF(IW)
C
      RETURN
 9999 FORMAT(/,10X,24('-'),/,10X,'-ELP- AT -SVP- SURFACE',
     1       /,10X,24('-'),/)
 9998 FORMAT(' 1 A.U. = 9.07618 ESU/CM ( OR STATVOLTS ) ')
 9997 FORMAT(3X,'POINT',6X,'X',9X,'Y',9X,'Z',5X,'POTENTIAL(A.U.)',/,
     1       83('-'))
 9996 FORMAT(1X,I5,2X,3F10.5,3F15.6)
 9994 FORMAT(' ...... END OF -SVPELP- ......')
      END
C*MODULE SVPCHG  *DECK SVPELF
      SUBROUTINE SVPELF(DENS,NCAV,CAVC,CAVN,ELFNOR,ELFXYZ)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C     ----- SOLUTE NORMAL ELECTRIC FIELD ON CAVITY SURFACE -----
C
      PARAMETER (ZERO=0.0D+00, TENM3=1.0D-03)
      PARAMETER (MXATM=2000)
      LOGICAL SOME
      LOGICAL OUT
      LOGICAL DBUG
      COMMON /IOFILE/ IR,IW,IP,IJK,IJKT,IDAF,NAV,IODA(950)
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      DIMENSION   CAVC(3,*),CAVN(3,*)
      DIMENSION   DENS(*)
      DIMENSION   ELFNOR(*),ELFXYZ(3,*)
C
      DBUG=.FALSE.
      OUT =.FALSE.
      OUT =OUT.OR.DBUG
      SOME=.FALSE.
      SOME=SOME.OR.OUT
      IF(SOME) THEN
         WRITE(IW,9999)
         WRITE(IW,9998)
      ENDIF
C
C     ----- CALCULATE ELECTRONIC CONTRIBUTION -----
C
      CALL SVP_ELFLDC(NCAV,CAVC,ELFXYZ,DENS)
      DO JPT=1,NCAV
         XNORJ=CAVN(1,JPT)
         YNORJ=CAVN(2,JPT)
         ZNORJ=CAVN(3,JPT)
         ELFNOR(JPT)=-XNORJ*ELFXYZ(1,JPT)-YNORJ*ELFXYZ(2,JPT)-
     1                ZNORJ*ELFXYZ(3,JPT)
      ENDDO
C
C     ----- COMPLETE ELECTRIC FIELD -----
C
      IF(DBUG) THEN
         WRITE(IW,9997)
      ENDIF
C
      DO JPT=1,NCAV
         XJ    = CAVC(1,JPT)
         YJ    = CAVC(2,JPT)
         ZJ    = CAVC(3,JPT)
         XNORJ = CAVN(1,JPT)
         YNORJ = CAVN(2,JPT)
         ZNORJ = CAVN(3,JPT)
C
C     ----- NUCLEAR CONTRIBUTION ... -----
C
         ELFLDN= ZERO
         DO IAT = 1,NAT
            XJN = XJ - C(1,IAT)
            YJN = YJ - C(2,IAT)
            ZJN = ZJ - C(3,IAT)
            RJN = SQRT(XJN*XJN + YJN*YJN + ZJN*ZJN)
            IF(RJN.GT.TENM3) THEN
               RJN3=RJN*RJN*RJN
               ELFLDN = ELFLDN + ZAN(IAT)*
     1                           (XNORJ*XJN+YNORJ*YJN+ZNORJ*ZJN)/RJN3
            ELSE
               WRITE(IW,9996) XJ,YJ,ZJ,IAT
            ENDIF
         ENDDO
C
C     ----- ELECTRON CONTRIBUTION ... -----
C
         DUME        = -ELFNOR(JPT)
         DUMN        =  ELFLDN
         DUM         =  DUMN   + DUME
         ELFNOR(JPT) =  DUM
         IF(DBUG) THEN
            WRITE(IW,9995) JPT,XJ,YJ,ZJ,DUM,DUMN,DUME
         ENDIF
      ENDDO
C
      IF(SOME) THEN
         WRITE(IW,9994)
      ENDIF
      CALL FLSHBF(IW)
C
      RETURN
 9999 FORMAT(/,10X,24('-'),/,10X,'-ELF- AT -SVP- SURFACE',
     1       /,10X,24('-'),/)
 9998 FORMAT(' 1 A.U. = 0.171524 10**(-8) DYN/ESU ',/)
 9997 FORMAT(3X,'POINT',6X,'X',9X,'Y',9X,'Z',5X,'FIELD(A.U.)',/,
     1       83('-'))
 9996 FORMAT(' --- WARNING - ELECTRIC FIELD AT ',
     1 3F10.5,' . CONTRIBUTION FROM  -IAT-  ',I3,' IGNORED')
 9995 FORMAT(1X,I5,2X,3F10.5,3F15.6)
 9994 FORMAT(' ...... END OF -SVPELF- ......')
      END
C*MODULE SVPCHG  *DECK SVP_ELPOTC
      SUBROUTINE SVP_ELPOTC(NPT,XYZPT,ELPOT,DAB)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (MXAO=8192, MXATM=2000, MXGTOT=20000, MXSH=5000)
      LOGICAL IANDJ
      LOGICAL NORM,DOUBLE
C
      COMMON /IJPAIR/ IA(MXAO)
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /NSHEL / EX(MXGTOT),CS(MXGTOT),CP(MXGTOT),CD(MXGTOT),
     *                CF(MXGTOT),CG(MXGTOT),CH(MXGTOT),CI(MXGTOT),
     *                KSTART(MXSH),KATOM(MXSH),KTYPE(MXSH),KNG(MXSH),
     *                KLOC(MXSH),KMIN(MXSH),KMAX(MXSH),NSHELL
      COMMON /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK
      COMMON /ROOT  / XX,U(13),W(13),NROOTS
      COMMON /STV   / XINT,YINT,ZINT,T,X0,Y0,Z0,XI,YI,ZI,XJ,YJ,ZJ,NI,NJ
C
      DIMENSION ELPOT(1),XYZPT(3,1),DAB(1)
      DIMENSION DIJ(225)
      DIMENSION XV(5,5,5),YV(5,5,5),ZV(5,5,5)
      DIMENSION IJX(35),IJY(35),IJZ(35)
      DATA ZERO  /0.0D+00/
      DATA ONE   /1.0D+00/
      DATA PI212 /1.1283791670955D+00/
      DATA RLN10 /2.30258D+00/
      DATA SQRT3 /1.73205080756888D+00/
      DATA SQRT5 /2.23606797749979D+00/
      DATA SQRT7 /2.64575131106459D+00/
      DATA IJX    / 1, 2, 1, 1, 3, 1, 1, 2, 2, 1,
     1              4, 1, 1, 3, 3, 2, 1, 2, 1, 2,
     2              5, 1, 1, 4, 4, 2, 1, 2, 1, 3,
     3              3, 1, 3, 2, 2/
      DATA IJY    / 1, 1, 2, 1, 1, 3, 1, 2, 1, 2,
     1              1, 4, 1, 2, 1, 3, 3, 1, 2, 2,
     2              1, 5, 1, 2, 1, 4, 4, 1, 2, 3,
     3              1, 3, 2, 3, 2/
      DATA IJZ    / 1, 1, 1, 2, 1, 1, 3, 1, 2, 2,
     1              1, 1, 4, 1, 2, 1, 2, 3, 3, 2,
     2              1, 1, 5, 1, 2, 1, 2, 4, 4, 1,
     3              3, 3, 2, 2, 3/
C
      TOL=RLN10*ITOL
      NORM=NORMF.NE.1.OR.NORMP.NE.1
C
      DO 10 IPT=1,NPT
   10 ELPOT(IPT)=ZERO
C
C     ----- ISHELL -----
C
      DO 9000 II=1,NSHELL
      I=KATOM(II)
      XI=C(1,I)
      YI=C(2,I)
      ZI=C(3,I)
      I1=KSTART(II)
      I2=I1+KNG(II)-1
      LIT=KTYPE(II)
      MINI=KMIN(II)
      MAXI=KMAX(II)
      LOCI=KLOC(II)-MINI
C
C     ----- JSHELL -----
C
      DO 8000 JJ=1,II
      J=KATOM(JJ)
      XJ=C(1,J)
      YJ=C(2,J)
      ZJ=C(3,J)
      J1=KSTART(JJ)
      J2=J1+KNG(JJ)-1
      LJT=KTYPE(JJ)
      MINJ=KMIN(JJ)
      MAXJ=KMAX(JJ)
      LOCJ=KLOC(JJ)-MINJ
C
      IANDJ=II.EQ.JJ
      RR=(XI-XJ)**2+(YI-YJ)**2+(ZI-ZJ)**2
      NROOTS=(LIT+LJT-2)/2+1
C
      IJ=0
      DO 100 I=MINI,MAXI
      JMAX=MAXJ
      IF(IANDJ) JMAX=I
      DO 100 J=MINJ,JMAX
      IJ=IJ+1
  100 CONTINUE
C
C     ----- I PRIMITIVE -----
C
      DO 7000 IG=I1,I2
      AI=EX(IG)
      ARRI=AI*RR
      AXI=AI*XI
      AYI=AI*YI
      AZI=AI*ZI
      CSI=CS(IG)
      CPI=CP(IG)
      CDI=CD(IG)
      CFI=CF(IG)
      CGI=CG(IG)
C
C     ----- J PRIMITIVE -----
C
      JGMAX=J2
      IF(IANDJ) JGMAX=IG
      DO 6000 JG=J1,JGMAX
      AJ=EX(JG)
      AA=AI+AJ
      AA1=ONE/AA
      DUM=AJ*ARRI*AA1
      IF(DUM.GT.TOL) GO TO 6000
      FAC= EXP(-DUM)
      CSJ=CS(JG)
      CPJ=CP(JG)
      CDJ=CD(JG)
      CFJ=CF(JG)
      CGJ=CG(JG)
      AX=(AXI+AJ*XJ)*AA1
      AY=(AYI+AJ*YJ)*AA1
      AZ=(AZI+AJ*ZJ)*AA1
C
C     ----- DENSITY FACTOR -----
C
      DOUBLE=IANDJ.AND.IG.NE.JG
      IJ=0
      DO 360 I=MINI,MAXI
      GO TO (110,120,220,220,130,220,220,140,220,220,
     1       150,220,220,160,220,220,220,220,220,170,
     2       180,220,220,190,220,220,220,220,220,200,
     3       220,220,210,220,220),I
  110 DUM1=CSI*FAC
      GO TO 220
  120 DUM1=CPI*FAC
      GO TO 220
  130 DUM1=CDI*FAC
      GO TO 220
  140 IF(NORM) DUM1=DUM1*SQRT3
      GO TO 220
  150 DUM1=CFI*FAC
      GO TO 220
  160 IF(NORM) DUM1=DUM1*SQRT5
      GO TO 220
  170 IF(NORM) DUM1=DUM1*SQRT3
      GO TO 220
  180 DUM1=CGI*FAC
      GO TO 220
  190 IF(NORM) DUM1=DUM1*SQRT7
      GO TO 220
  200 IF(NORM) DUM1=DUM1*SQRT5/SQRT3
      GO TO 220
  210 IF(NORM) DUM1=DUM1*SQRT3
  220 CONTINUE
C
      JMAX=MAXJ
      IF(IANDJ) JMAX=I
      DO 360 J=MINJ,JMAX
      GO TO (230,250,350,350,260,350,350,270,350,350,
     1       280,350,350,290,350,350,350,350,350,300,
     2       310,350,350,320,350,350,350,350,350,330,
     3       350,350,340,350,350),J
  230 DUM2=DUM1*CSJ
      IF(.NOT.DOUBLE) GO TO 350
      IF(I.GT.1) GO TO 240
      DUM2=DUM2+DUM2
      GO TO 350
  240 DUM2=DUM2+CSI*CPJ*FAC
      GO TO 350
  250 DUM2=DUM1*CPJ
      IF(DOUBLE) DUM2=DUM2+DUM2
      GO TO 350
  260 DUM2=DUM1*CDJ
      IF(DOUBLE) DUM2=DUM2+DUM2
      GO TO 350
  270 IF(NORM) DUM2=DUM2*SQRT3
      GO TO 350
  280 DUM2=DUM1*CFJ
      IF(DOUBLE) DUM2=DUM2+DUM2
      GO TO 350
  290 IF(NORM) DUM2=DUM2*SQRT5
      GO TO 350
  300 IF(NORM) DUM2=DUM2*SQRT3
      GO TO 350
  310 DUM2=DUM1*CGJ
      IF(DOUBLE) DUM2=DUM2+DUM2
      GO TO 350
  320 IF(NORM) DUM2=DUM2*SQRT7
      GO TO 350
  330 IF(NORM) DUM2=DUM2*SQRT5/SQRT3
      GO TO 350
  340 IF(NORM) DUM2=DUM2*SQRT3
  350 CONTINUE
C
      IJ=IJ+1
  360 DIJ(IJ)=DUM2
C
C     ----- ELECTROSTATIC POTENTIAL -----
C
      AAX=AA*AX
      AAY=AA*AY
      AAZ=AA*AZ
      DO 500 IPT=1,NPT
      ZNUC=ONE
      CX=XYZPT(1,IPT)
      CY=XYZPT(2,IPT)
      CZ=XYZPT(3,IPT)
      XX=AA*((AX-CX)**2+(AY-CY)**2+(AZ-CZ)**2)
      IF(NROOTS.LE.3) CALL RT123
      IF(NROOTS.EQ.4) CALL ROOT4
      IF(NROOTS.EQ.5) CALL ROOT5
      DO 420 IROOT=1,NROOTS
      UU=U(IROOT)*AA
      WW=W(IROOT)*ZNUC
      TT=ONE/(AA+UU)
      T= SQRT(TT)
      X0=(AAX+UU*CX)*TT
      Y0=(AAY+UU*CY)*TT
      Z0=(AAZ+UU*CZ)*TT
      DO 410 J=1,LJT
      NJ=J
      DO 410 I=1,LIT
      NI=I
      CALL STVINT
      XV(I,J,IROOT)=XINT
      YV(I,J,IROOT)=YINT
      ZV(I,J,IROOT)=ZINT*WW
  410 CONTINUE
  420 CONTINUE
C
      IJ=0
      DO 450 I=MINI,MAXI
      IX=IJX(I)
      IY=IJY(I)
      IZ=IJZ(I)
      JMAX=MAXJ
      IF(IANDJ) JMAX=I
      DO 440 J=MINJ,JMAX
      JX=IJX(J)
      JY=IJY(J)
      JZ=IJZ(J)
      DUM=ZERO
      DO 430 IROOT=1,NROOTS
  430 DUM=DUM+XV(IX,JX,IROOT)*YV(IY,JY,IROOT)*ZV(IZ,JZ,IROOT)
      DUM=DUM*(AA1*PI212)
      IJ=IJ+1
      DUM=DUM*DIJ(IJ)
      DEN=DAB(IA(LOCI+I)+(LOCJ+J))
      IF(.NOT.IANDJ.OR.J.NE.I) DEN=DEN+DEN
      ELPOT(IPT)=ELPOT(IPT)+DUM*DEN
  440 CONTINUE
  450 CONTINUE
C
  500 CONTINUE
C
 6000 CONTINUE
 7000 CONTINUE
C
 8000 CONTINUE
 9000 CONTINUE
C
      RETURN
      END
C*MODULE SVPCHG  *DECK SVP_ELFLDC
      SUBROUTINE SVP_ELFLDC(NPT,XYZPT,ELFLD,DAB)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (MXAO=8192, MXATM=2000, MXGTOT=20000, MXSH=5000)
      LOGICAL IANDJ
      LOGICAL NORM
      LOGICAL DOUBLE
      LOGICAL DBUG
      LOGICAL OUT
C
      COMMON /IOFILE/ IR,IW,IP,IJK,IJKT,IDAF,NAV,IODA(950)
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /NSHEL / EX(MXGTOT),CS(MXGTOT),CP(MXGTOT),CD(MXGTOT),
     *                CF(MXGTOT),CG(MXGTOT),CH(MXGTOT),CI(MXGTOT),
     *                KSTART(MXSH),KATOM(MXSH),KTYPE(MXSH),KNG(MXSH),
     *                KLOC(MXSH),KMIN(MXSH),KMAX(MXSH),NSHELL
      COMMON /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK
      COMMON /ROOT  / XX,U(13),W(13),NROOTS
      COMMON /IJPAIR/ IA(MXAO)
      COMMON/XYZDER/XINT,YINT,ZINT,T,X0,Y0,Z0,XI,YI,ZI,XJ,YJ,ZJ,NI,NJ
     1                              ,CX,CY,CZ
C
      DIMENSION ELFLD(3,1),XYZPT(3,1),DAB(1)
      DIMENSION DIJ(225)
      DIMENSION IJX(35),IJY(35),IJZ(35)
      DIMENSION  XV(5,5,5), YV(5,5,5), ZV(5,5,5)
      DIMENSION DXV(5,5,5),DYV(5,5,5),DZV(5,5,5)
C
      DATA MAXRYS /5/
      DATA RLN10  /2.30258D+00/
      DATA ZERO   /0.0D+00/
      DATA ONE    /1.0D+00/
      DATA PI212  /1.1283791670955D+00/
      DATA SQRT3  /1.73205080756888D+00/
      DATA SQRT5  /2.23606797749979D+00/
      DATA SQRT7  /2.64575131106459D+00/
      DATA IJX    / 1, 2, 1, 1, 3, 1, 1, 2, 2, 1,
     1              4, 1, 1, 3, 3, 2, 1, 2, 1, 2,
     2              5, 1, 1, 4, 4, 2, 1, 2, 1, 3,
     3              3, 1, 3, 2, 2/
      DATA IJY    / 1, 1, 2, 1, 1, 3, 1, 2, 1, 2,
     1              1, 4, 1, 2, 1, 3, 3, 1, 2, 2,
     2              1, 5, 1, 2, 1, 4, 4, 1, 2, 3,
     3              1, 3, 2, 3, 2/
      DATA IJZ    / 1, 1, 1, 2, 1, 1, 3, 1, 2, 2,
     1              1, 1, 4, 1, 2, 1, 2, 3, 3, 2,
     2              1, 1, 5, 1, 2, 1, 2, 4, 4, 1,
     3              3, 3, 2, 2, 3/
C
      DBUG=.FALSE.
      OUT =.FALSE.
      OUT =OUT.OR.NPRINT.EQ. 6.OR.DBUG
C
      TOL=RLN10*ITOL
      NORM=NORMF.NE.1.OR.NORMP.NE.1
C
      DO 10 IPT=1,NPT
      DO 10 I=1,3
   10 ELFLD(I,IPT)=ZERO
C
      NDER=1
C
C     ----- ISHELL -----
C
      DO 9000 II=1,NSHELL
      I=KATOM(II)
      XI=C(1,I)
      YI=C(2,I)
      ZI=C(3,I)
      I1=KSTART(II)
      I2=I1+KNG(II)-1
      LIT=KTYPE(II)
      MINI=KMIN(II)
      MAXI=KMAX(II)
      LOCI=KLOC(II)-MINI
C
C     ----- JSHELL -----
C
      DO 8000 JJ=1,II
      J=KATOM(JJ)
      XJ=C(1,J)
      YJ=C(2,J)
      ZJ=C(3,J)
      J1=KSTART(JJ)
      J2=J1+KNG(JJ)-1
      LJT=KTYPE(JJ)
      MINJ=KMIN(JJ)
      MAXJ=KMAX(JJ)
      LOCJ=KLOC(JJ)-MINJ
C
      IANDJ=II.EQ.JJ
      RR=(XI-XJ)**2+(YI-YJ)**2+(ZI-ZJ)**2
      NROOTS=(LIT+LJT+NDER-2)/2+1
      IF(NROOTS.GT.MAXRYS) THEN
         WRITE(IW,9997) MAXRYS,LIT,LJT,NROOTS
         CALL ABRT
      ENDIF
C
C     ----- I PRIMITIVE -----
C
      DO 7000 IG=I1,I2
      AI=EX(IG)
      ARRI=AI*RR
      AXI=AI*XI
      AYI=AI*YI
      AZI=AI*ZI
      CSI=CS(IG)
      CPI=CP(IG)
      CDI=CD(IG)
      CFI=CF(IG)
      CGI=CG(IG)
C
C     ----- J PRIMITIVE -----
C
      JGMAX=J2
      IF(IANDJ) JGMAX=IG
      DO 6000 JG=J1,JGMAX
      AJ=EX(JG)
      AA=AI+AJ
      AA1=ONE/AA
      DUM=AJ*ARRI*AA1
      IF(DUM.GT.TOL) GO TO 6000
      FAC= EXP(-DUM)
      CSJ=CS(JG)
      CPJ=CP(JG)
      CDJ=CD(JG)
      CFJ=CF(JG)
      CGJ=CG(JG)
      AX=(AXI+AJ*XJ)*AA1
      AY=(AYI+AJ*YJ)*AA1
      AZ=(AZI+AJ*ZJ)*AA1
C
C     ----- DENSITY FACTOR -----
C
      DOUBLE=IANDJ.AND.IG.NE.JG
      IJ=0
      DO 360 I=MINI,MAXI
      GO TO (110,120,220,220,130,220,220,140,220,220,
     1       150,220,220,160,220,220,220,220,220,170,
     2       180,220,220,190,220,220,220,220,220,200,
     3       220,220,210,220,220),I
  110 DUM1=CSI*FAC
      GO TO 220
  120 DUM1=CPI*FAC
      GO TO 220
  130 DUM1=CDI*FAC
      GO TO 220
  140 IF(NORM) DUM1=DUM1*SQRT3
      GO TO 220
  150 DUM1=CFI*FAC
      GO TO 220
  160 IF(NORM) DUM1=DUM1*SQRT5
      GO TO 220
  170 IF(NORM) DUM1=DUM1*SQRT3
      GO TO 220
  180 DUM1=CGI*FAC
      GO TO 220
  190 IF(NORM) DUM1=DUM1*SQRT7
      GO TO 220
  200 IF(NORM) DUM1=DUM1*SQRT5/SQRT3
      GO TO 220
  210 IF(NORM) DUM1=DUM1*SQRT3
  220 CONTINUE
C
      JMAX=MAXJ
      IF(IANDJ) JMAX=I
      DO 360 J=MINJ,JMAX
      GO TO (230,250,350,350,260,350,350,270,350,350,
     1       280,350,350,290,350,350,350,350,350,300,
     2       310,350,350,320,350,350,350,350,350,330,
     3       350,350,340,350,350),J
  230 DUM2=DUM1*CSJ
      IF(.NOT.DOUBLE) GO TO 350
      IF(I.GT.1) GO TO 240
      DUM2=DUM2+DUM2
      GO TO 350
  240 DUM2=DUM2+CSI*CPJ*FAC
      GO TO 350
  250 DUM2=DUM1*CPJ
      IF(DOUBLE) DUM2=DUM2+DUM2
      GO TO 350
  260 DUM2=DUM1*CDJ
      IF(DOUBLE) DUM2=DUM2+DUM2
      GO TO 350
  270 IF(NORM) DUM2=DUM2*SQRT3
      GO TO 350
  280 DUM2=DUM1*CFJ
      IF(DOUBLE) DUM2=DUM2+DUM2
      GO TO 350
  290 IF(NORM) DUM2=DUM2*SQRT5
      GO TO 350
  300 IF(NORM) DUM2=DUM2*SQRT3
      GO TO 350
  310 DUM2=DUM1*CGJ
      IF(DOUBLE) DUM2=DUM2+DUM2
      GO TO 350
  320 IF(NORM) DUM2=DUM2*SQRT7
      GO TO 350
  330 IF(NORM) DUM2=DUM2*SQRT5/SQRT3
      GO TO 350
  340 IF(NORM) DUM2=DUM2*SQRT3
  350 CONTINUE
C
      NN=IA(LOCI+I)+(LOCJ+J)
      DEN=DAB(NN)
      IF(.NOT.IANDJ.OR.J.NE.I) DEN=DEN+DEN
      IJ=IJ+1
  360 DIJ(IJ)=DUM2*DEN
C
C     ----- ELECTRIC FIELD TERM -----
C
      AAX=AA*AX
      AAY=AA*AY
      AAZ=AA*AZ
      DO 500 IPT=1,NPT
      ZNUC=ONE
      CX=XYZPT(1,IPT)
      CY=XYZPT(2,IPT)
      CZ=XYZPT(3,IPT)
      XX=AA*((AX-CX)**2+(AY-CY)**2+(AZ-CZ)**2)
      IF(NROOTS.LE.3) CALL RT123
      IF(NROOTS.EQ.4) CALL ROOT4
      IF(NROOTS.EQ.5) CALL ROOT5
      DO 420 IROOT=1,NROOTS
      UU=U(IROOT)*AA
      WW=W(IROOT)*ZNUC
      WW=WW*(UU+UU)
      TT=ONE/(AA+UU)
      T = SQRT(TT)
      X0=(AAX+UU*CX)*TT
      Y0=(AAY+UU*CY)*TT
      Z0=(AAZ+UU*CZ)*TT
      DO 410 J=1,LJT
      NJ=J
      DO 410 I=1,LIT
      NI=I
      CALL DS2XYZ
      XV(I,J,IROOT)=XINT
      YV(I,J,IROOT)=YINT
      ZV(I,J,IROOT)=ZINT*WW
      CALL DVXYZ
      DXV(I,J,IROOT)=XINT
      DYV(I,J,IROOT)=YINT
      DZV(I,J,IROOT)=ZINT*WW
  410 CONTINUE
  420 CONTINUE
C
      IJ=0
      DO 450 I=MINI,MAXI
      IX=IJX(I)
      IY=IJY(I)
      IZ=IJZ(I)
      JMAX=MAXJ
      IF(IANDJ) JMAX=I
      DO 440 J=MINJ,JMAX
      JX=IJX(J)
      JY=IJY(J)
      JZ=IJZ(J)
      DUMX=ZERO
      DUMY=ZERO
      DUMZ=ZERO
      DO 430 IROOT=1,NROOTS
      DUMX=DUMX+DXV(IX,JX,IROOT)* YV(IY,JY,IROOT)* ZV(IZ,JZ,IROOT)
      DUMY=DUMY+ XV(IX,JX,IROOT)*DYV(IY,JY,IROOT)* ZV(IZ,JZ,IROOT)
      DUMZ=DUMZ+ XV(IX,JX,IROOT)* YV(IY,JY,IROOT)*DZV(IZ,JZ,IROOT)
      IF(DBUG) THEN
         IF(II.EQ.1.AND.JJ.EQ.1) THEN
            WRITE(IW,9993)
     1       XV(IX,JX,IROOT), YV(IY,JY,IROOT), ZV(IZ,JZ,IROOT),
     2      DXV(IX,JX,IROOT),DYV(IY,JY,IROOT),DZV(IZ,JZ,IROOT)
         ENDIF
      ENDIF
  430 CONTINUE
      IJ=IJ+1
      DUM=PI212*AA1*DIJ(IJ)
      ELFLD(1,IPT)=ELFLD(1,IPT)+DUMX*DUM
      ELFLD(2,IPT)=ELFLD(2,IPT)+DUMY*DUM
      ELFLD(3,IPT)=ELFLD(3,IPT)+DUMZ*DUM
      IF(DBUG) THEN
         IF(II.EQ.1.AND.JJ.EQ.1) THEN
            WRITE(IW,9992)
            WRITE(IW,9996) II,JJ,IPT,I,J,
     1      (DUMX*AA1*PI212),(DUMY*AA1*PI212),(DUMZ*AA1*PI212),DIJ(IJ)
         ENDIF
      ENDIF
  440 CONTINUE
  450 CONTINUE
C
  500 CONTINUE
C
 6000 CONTINUE
 7000 CONTINUE
C
      IF(DBUG) THEN
         WRITE(IW,9995) II,JJ
         DO IPT=1,NPT
            WRITE(IW,9994) IPT,ELFLD(1,IPT),ELFLD(2,IPT),ELFLD(3,IPT)
         ENDDO
      ENDIF
C
 8000 CONTINUE
 9000 CONTINUE
C
      RETURN
 9997 FORMAT(' IN -ELFLDC- , THE RYS QUADRATURE IS NOT IMPLEMENTED',
     1       ' BEYOND -NROOTS- = ',I3,/,
     2       ' LIT,LJT,NROOTS= ',3I3)
 9996 FORMAT(' II,JJ,IPT,I,J= ',5I3,4F15.8)
 9995 FORMAT(' SHELLS II,JJ = ',2I5)
 9994 FORMAT(I5,3F15.8)
 9993 FORMAT(3F15.8,/,3F15.8)
 9992 FORMAT(' ELFLDC')
      END
C*MODULE SVPCHG  *DECK DS2XYZ
      SUBROUTINE DS2XYZ
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C     ----- GAUSS-HERMITE QUADRATURE USING MINIMUM POINT FORMULA -----
C
      COMMON /XYZDER/ XINT,YINT,ZINT,T,X0,Y0,Z0,XI,YI,ZI,XJ,YJ,ZJ,NI,NJ,
     *                CX,CY,CZ
      COMMON /HERMIT/ H1,H2(2),H3(3),H4(4),H5(5),H6(6),H7(7),
     *                H8(8),H9(9),H10(10)
      COMMON /WERMIT/ W1,W2(2),W3(3),W4(4),W5(5),W6(6),W7(7),
     *                W8(8),W9(9),W10(10)
      DIMENSION H(28),W(28),MIN(7),MAX(7)
      EQUIVALENCE (H(1),H1),(W(1),W1)
      DATA MIN  /1,2,4, 7,11,16,22/
      DATA MAX  /1,3,6,10,15,21,28/
      DATA ZERO /0.0D+00/
C
      XINT=ZERO
      YINT=ZERO
      ZINT=ZERO
      NPTS=(NI+NJ-2)/2+1
      IMIN=MIN(NPTS)
      IMAX=MAX(NPTS)
      DO 16 I=IMIN,IMAX
      DUM=W(I)
      PX=DUM
      PY=DUM
      PZ=DUM
      DUM=H(I)*T
      PTX=DUM+X0
      PTY=DUM+Y0
      PTZ=DUM+Z0
      AX=PTX-XI
      AY=PTY-YI
      AZ=PTZ-ZI
      BX=PTX-XJ
      BY=PTY-YJ
      BZ=PTZ-ZJ
      GO TO (7,6,5,4,3,2,1),NI
    1 PX=PX*AX
      PY=PY*AY
      PZ=PZ*AZ
    2 PX=PX*AX
      PY=PY*AY
      PZ=PZ*AZ
    3 PX=PX*AX
      PY=PY*AY
      PZ=PZ*AZ
    4 PX=PX*AX
      PY=PY*AY
      PZ=PZ*AZ
    5 PX=PX*AX
      PY=PY*AY
      PZ=PZ*AZ
    6 PX=PX*AX
      PY=PY*AY
      PZ=PZ*AZ
    7 GO TO (15,14,13,12,11,10,9,8),NJ
    8 PX=PX*BX
      PY=PY*BY
      PZ=PZ*BZ
    9 PX=PX*BX
      PY=PY*BY
      PZ=PZ*BZ
   10 PX=PX*BX
      PY=PY*BY
      PZ=PZ*BZ
   11 PX=PX*BX
      PY=PY*BY
      PZ=PZ*BZ
   12 PX=PX*BX
      PY=PY*BY
      PZ=PZ*BZ
   13 PX=PX*BX
      PY=PY*BY
      PZ=PZ*BZ
   14 PX=PX*BX
      PY=PY*BY
      PZ=PZ*BZ
   15 CONTINUE
      XINT=XINT+PX
      YINT=YINT+PY
      ZINT=ZINT+PZ
   16 CONTINUE
      RETURN
      END
C*MODULE SVPCHG  *DECK DVXYZ
      SUBROUTINE DVXYZ
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C     ----- GAUSS-HERMITE QUADRATURE USING MINIMUM POINT FORMULA -----
C
      COMMON /XYZDER/ XINT,YINT,ZINT,T,X0,Y0,Z0,XI,YI,ZI,XJ,YJ,ZJ,NI,NJ,
     *                CX,CY,CZ
      COMMON /HERMIT/ H1,H2(2),H3(3),H4(4),H5(5),H6(6),H7(7),
     *                H8(8),H9(9),H10(10)
      COMMON /WERMIT/ W1,W2(2),W3(3),W4(4),W5(5),W6(6),W7(7),
     *                W8(8),W9(9),W10(10)
      DIMENSION H(28),W(28),MIN(7),MAX(7)
      EQUIVALENCE (H(1),H1),(W(1),W1)
      DATA MIN  /1,2,4, 7,11,16,22/
      DATA MAX  /1,3,6,10,15,21,28/
      DATA ZERO /0.0D+00/
C
      XINT=ZERO
      YINT=ZERO
      ZINT=ZERO
      NPTS=(NI+NJ+1-2)/2+1
      IMIN=MIN(NPTS)
      IMAX=MAX(NPTS)
      DO 13 I=IMIN,IMAX
      DUM=H(I)*T
      PTX=DUM+X0
      PTY=DUM+Y0
      PTZ=DUM+Z0
      PX=PTX-CX
      PY=PTY-CY
      PZ=PTZ-CZ
      AX=PTX-XI
      AY=PTY-YI
      AZ=PTZ-ZI
      BX=PTX-XJ
      BY=PTY-YJ
      BZ=PTZ-ZJ
      GO TO (6,5,4,3,2,1),NI
    1 PX=PX*AX
      PY=PY*AY
      PZ=PZ*AZ
    2 PX=PX*AX
      PY=PY*AY
      PZ=PZ*AZ
    3 PX=PX*AX
      PY=PY*AY
      PZ=PZ*AZ
    4 PX=PX*AX
      PY=PY*AY
      PZ=PZ*AZ
    5 PX=PX*AX
      PY=PY*AY
      PZ=PZ*AZ
    6 GO TO (12,11,10,9,8,7),NJ
    7 PX=PX*BX
      PY=PY*BY
      PZ=PZ*BZ
    8 PX=PX*BX
      PY=PY*BY
      PZ=PZ*BZ
    9 PX=PX*BX
      PY=PY*BY
      PZ=PZ*BZ
   10 PX=PX*BX
      PY=PY*BY
      PZ=PZ*BZ
   11 PX=PX*BX
      PY=PY*BY
      PZ=PZ*BZ
   12 DUM=W(I)
      XINT=XINT+DUM*PX
      YINT=YINT+DUM*PY
      ZINT=ZINT+DUM*PZ
   13 CONTINUE
      RETURN
      END
*MODULE SVPCHG  *DECK SVP_ELDELPOT
      SUBROUTINE SVP_ELDELPOT(NPT,XYZPT,ELD,ELPOT,DAB)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C     --- EVALUATE ELECTRON DENSITY AND ELECTRON CONTIRBUTION TO ---
C     --- ELECTROSTATIC POTENTIAL AT A GIVEN SET OF GRID POINTS  ---
C     --- ADAPTED FROM SVP_ELDEND AND SVP_ELPOTC BY DMC JAN 2005 ---
C
      PARAMETER (MXAO=8192, MXATM=2000, MXGTOT=20000, MXSH=5000)
      LOGICAL IANDJ,NORM,DOUBLE
      LOGICAL DBUG,OUT
C
      COMMON /IJPAIR/ IA(MXAO)
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /NSHEL / EX(MXGTOT),CS(MXGTOT),CP(MXGTOT),CD(MXGTOT),
     *                CF(MXGTOT),CG(MXGTOT),CH(MXGTOT),CI(MXGTOT),
     *                KSTART(MXSH),KATOM(MXSH),KTYPE(MXSH),KNG(MXSH),
     *                KLOC(MXSH),KMIN(MXSH),KMAX(MXSH),NSHELL
      COMMON /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK
      COMMON /XYZDN/ XINTDN,YINTDN,ZINTDN,X0DN,Y0DN,Z0DN,XIDN,YIDN,ZIDN,
     *               XJDN,YJDN,ZJDN,NIDN,NJDN
C     MAKE XYZDN LOCALLY DISTINCT FROM STV TO ALLOW SIMULTANEOUS
C     CALCULATION OF BOTH DENSITY AND POTENTIAL - DMC 1/06
      COMMON /ROOT  / XX,U(13),W(13),NROOTS
      COMMON /STV   / XINT,YINT,ZINT,T,X0,Y0,Z0,XI,YI,ZI,XJ,YJ,ZJ,NI,NJ
C
      DIMENSION ELD(NPT),ELPOT(NPT),XYZPT(3,NPT),DAB(*)
      DIMENSION DIJ(225)
      DIMENSION     XG(7,7),    YG(7,7),    ZG(7,7)
      DIMENSION XV(5,5,5),YV(5,5,5),ZV(5,5,5)
      DIMENSION IJX(35),IJY(35),IJZ(35)
      DATA ZERO  /0.0D+00/
      DATA ONE   /1.0D+00/
      DATA PI212 /1.1283791670955D+00/
      DATA RLN10 /2.30258D+00/
      DATA SQRT3 /1.73205080756888D+00/
      DATA SQRT5 /2.23606797749979D+00/
      DATA SQRT7 /2.64575131106459D+00/
      DATA IJX    / 1, 2, 1, 1, 3, 1, 1, 2, 2, 1,
     1              4, 1, 1, 3, 3, 2, 1, 2, 1, 2,
     2              5, 1, 1, 4, 4, 2, 1, 2, 1, 3,
     3              3, 1, 3, 2, 2/
      DATA IJY    / 1, 1, 2, 1, 1, 3, 1, 2, 1, 2,
     1              1, 4, 1, 2, 1, 3, 3, 1, 2, 2,
     2              1, 5, 1, 2, 1, 4, 4, 1, 2, 3,
     3              1, 3, 2, 3, 2/
      DATA IJZ    / 1, 1, 1, 2, 1, 1, 3, 1, 2, 2,
     1              1, 1, 4, 1, 2, 1, 2, 3, 3, 2,
     2              1, 1, 5, 1, 2, 1, 2, 4, 4, 1,
     3              3, 3, 2, 2, 3/
C
      DBUG=.FALSE.
      OUT =.FALSE.
      OUT =OUT.OR.DBUG
      OUT =OUT.OR.NPRINT.EQ.6
C
      TOL=RLN10*ITOL
      NORM=NORMF.NE.1.OR.NORMP.NE.1
C
      DO IPT=1,NPT
         ELD(IPT)=ZERO
         ELPOT(IPT)=ZERO
      ENDDO
C
C     ----- ISHELL -----
C
      DO 9000 II=1,NSHELL
      I=KATOM(II)
      XI=C(1,I)
      YI=C(2,I)
      ZI=C(3,I)
      XIDN=XI
      YIDN=YI
      ZIDN=ZI
      I1=KSTART(II)
      I2=I1+KNG(II)-1
      LIT=KTYPE(II)
      MINI=KMIN(II)
      MAXI=KMAX(II)
      LOCI=KLOC(II)-MINI
C
C     ----- JSHELL -----
C
      DO 8000 JJ=1,II
      J=KATOM(JJ)
      XJ=C(1,J)
      YJ=C(2,J)
      ZJ=C(3,J)
      XJDN=XJ
      YJDN=YJ
      ZJDN=ZJ
      J1=KSTART(JJ)
      J2=J1+KNG(JJ)-1
      LJT=KTYPE(JJ)
      MINJ=KMIN(JJ)
      MAXJ=KMAX(JJ)
      LOCJ=KLOC(JJ)-MINJ
C
      IANDJ=II.EQ.JJ
      RR=(XI-XJ)**2+(YI-YJ)**2+(ZI-ZJ)**2
      NROOTS=(LIT+LJT-2)/2+1
C
      IJ=0
      DO 100 I=MINI,MAXI
      JMAX=MAXJ
      IF(IANDJ) JMAX=I
      DO 100 J=MINJ,JMAX
      IJ=IJ+1
  100 CONTINUE
C
C     ----- I PRIMITIVE -----
C
      DO 7000 IG=I1,I2
      AI=EX(IG)
      ARRI=AI*RR
      AXI=AI*XI
      AYI=AI*YI
      AZI=AI*ZI
      CSI=CS(IG)
      CPI=CP(IG)
      CDI=CD(IG)
      CFI=CF(IG)
      CGI=CG(IG)
C
C    ----- J PRIMITIVE -----
C
      JGMAX=J2
      IF(IANDJ) JGMAX=IG
      DO 6000 JG=J1,JGMAX
      AJ=EX(JG)
      AA=AI+AJ
      AA1=ONE/AA
      DUM=AJ*ARRI*AA1
      IF(DUM.GT.TOL) GO TO 6000
      FAC= EXP(-DUM)
      CSJ=CS(JG)
      CPJ=CP(JG)
      CDJ=CD(JG)
      CFJ=CF(JG)
      CGJ=CG(JG)
      AX=(AXI+AJ*XJ)*AA1
      AY=(AYI+AJ*YJ)*AA1
      AZ=(AZI+AJ*ZJ)*AA1
C
C    ----- DENSITY FACTOR -----
C
      DOUBLE=IANDJ.AND.IG.NE.JG
      IJ=0
      DO 360 I=MINI,MAXI
      GO TO (110,120,220,220,130,220,220,140,220,220,
     1       150,220,220,160,220,220,220,220,220,170,
     2       180,220,220,190,220,220,220,220,220,200,
     3       220,220,210,220,220),I
  110 DUM1=CSI*FAC
      GO TO 220
  120 DUM1=CPI*FAC
      GO TO 220
  130 DUM1=CDI*FAC
      GO TO 220
  140 IF(NORM) DUM1=DUM1*SQRT3
      GO TO 220
  150 DUM1=CFI*FAC
      GO TO 220
  160 IF(NORM) DUM1=DUM1*SQRT5
      GO TO 220
  170 IF(NORM) DUM1=DUM1*SQRT3
      GO TO 220
  180 DUM1=CGI*FAC
      GO TO 220
  190 IF(NORM) DUM1=DUM1*SQRT7
      GO TO 220
  200 IF(NORM) DUM1=DUM1*SQRT5/SQRT3
      GO TO 220
  210 IF(NORM) DUM1=DUM1*SQRT3
  220 CONTINUE
C
      JMAX=MAXJ
      IF(IANDJ) JMAX=I
      DO 360 J=MINJ,JMAX
      GO TO (230,250,350,350,260,350,350,270,350,350,
     1       280,350,350,290,350,350,350,350,350,300,
     2       310,350,350,320,350,350,350,350,350,330,
     3       350,350,340,350,350),J
  230 DUM2=DUM1*CSJ
      IF(.NOT.DOUBLE) GO TO 350
      IF(I.GT.1) GO TO 240
      DUM2=DUM2+DUM2
      GO TO 350
  240 DUM2=DUM2+CSI*CPJ*FAC
      GO TO 350
  250 DUM2=DUM1*CPJ
      IF(DOUBLE) DUM2=DUM2+DUM2
      GO TO 350
  260 DUM2=DUM1*CDJ
      IF(DOUBLE) DUM2=DUM2+DUM2
      GO TO 350
  270 IF(NORM) DUM2=DUM2*SQRT3
      GO TO 350
  280 DUM2=DUM1*CFJ
      IF(DOUBLE) DUM2=DUM2+DUM2
      GO TO 350
  290 IF(NORM) DUM2=DUM2*SQRT5
      GO TO 350
  300 IF(NORM) DUM2=DUM2*SQRT3
      GO TO 350
  310 DUM2=DUM1*CGJ
      IF(DOUBLE) DUM2=DUM2+DUM2
      GO TO 350
  320 IF(NORM) DUM2=DUM2*SQRT7
      GO TO 350
  330 IF(NORM) DUM2=DUM2*SQRT5/SQRT3
      GO TO 350
  340 IF(NORM) DUM2=DUM2*SQRT3
  350 CONTINUE
C
      IJ=IJ+1
  360 DIJ(IJ)=DUM2
C
C    ----- LOOP OVER GRID POINTS -----
C
      AAX=AA*AX
      AAY=AA*AY
      AAZ=AA*AZ
      DO IPT=1,NPT
         CX = XYZPT(1,IPT)
         CY = XYZPT(2,IPT)
         CZ = XYZPT(3,IPT)
         X0DN = CX
         Y0DN = CY
         Z0DN = CZ
         DUM = AA*((CX-AX)**2+(CY-AY)**2+(CZ-AZ)**2)
         IF(DUM.LE.TOL) THEN
            FAC = EXP(-DUM)
C
C    ----- CHARGE DENSITY -----
C
            DO J=1,LJT
               NJDN=J
               DO I=1,LIT
                  NIDN=I
                  CALL CHGXYZ
                  XG(I,J)=XINTDN
                  YG(I,J)=YINTDN
                  ZG(I,J)=ZINTDN
               ENDDO
            ENDDO
            IJ=0
            DO I=MINI,MAXI
               IX=IJX(I)
               IY=IJY(I)
               IZ=IJZ(I)
               JMAX=MAXJ
               IF(IANDJ) JMAX=I
               DO J=MINJ,JMAX
                  JX=IJX(J)
                  JY=IJY(J)
                  JZ=IJZ(J)
                  IJ=IJ+1
                  VAL  =  XG(IX,JX)*  YG(IY,JY)*  ZG(IZ,JZ)
                  ELDEN=DIJ(IJ)*VAL  *FAC
                  DEN=DAB(IA(LOCI+I)+(LOCJ+J))
                  IF(.NOT.IANDJ.OR.J.NE.I) DEN=DEN+DEN
                  ELD(IPT)=ELD(IPT)+DEN*ELDEN
               ENDDO
            ENDDO
         ENDIF
C
C    ----- ELECTROSTATIC POTENTIAL -----
C
         ZNUC=ONE
         XX=AA*((AX-CX)**2+(AY-CY)**2+(AZ-CZ)**2)
         IF(NROOTS.LE.3) CALL RT123
         IF(NROOTS.EQ.4) CALL ROOT4
         IF(NROOTS.EQ.5) CALL ROOT5
         DO IROOT=1,NROOTS
            UU=U(IROOT)*AA
            WW=W(IROOT)*ZNUC
            TT=ONE/(AA+UU)
            T= SQRT(TT)
            X0=(AAX+UU*CX)*TT
            Y0=(AAY+UU*CY)*TT
            Z0=(AAZ+UU*CZ)*TT
            DO J=1,LJT
               NJ=J
               DO I=1,LIT
                  NI=I
                  CALL STVINT
                  XV(I,J,IROOT)=XINT
                  YV(I,J,IROOT)=YINT
                  ZV(I,J,IROOT)=ZINT*WW
               ENDDO
            ENDDO
         ENDDO
C
         IJ=0
         DO I=MINI,MAXI
            IX=IJX(I)
            IY=IJY(I)
            IZ=IJZ(I)
            JMAX=MAXJ
            IF(IANDJ) JMAX=I
            DO J=MINJ,JMAX
               JX=IJX(J)
               JY=IJY(J)
               JZ=IJZ(J)
               DUM=ZERO
               DO IROOT=1,NROOTS
                 DUM=DUM+XV(IX,JX,IROOT)*YV(IY,JY,IROOT)*ZV(IZ,JZ,IROOT)
               ENDDO
               DUM=DUM*(AA1*PI212)
               IJ=IJ+1
               DUM=DUM*DIJ(IJ)
               DEN=DAB(IA(LOCI+I)+(LOCJ+J))
               IF(.NOT.IANDJ.OR.J.NE.I) DEN=DEN+DEN
               ELPOT(IPT)=ELPOT(IPT)+DUM*DEN
            ENDDO
         ENDDO
      ENDDO
C
 6000 CONTINUE
 7000 CONTINUE
C
 8000 CONTINUE
 9000 CONTINUE
C
C     ----- ADD IN NUCLEAR CONTRIBUTION TO ELECTROSTATIC POTENTIAL -----
C     ----- AND INSERT A MINUS SIGN FOR THE ELECTRON CONTRIBUTION  -----
C
      DO JPT=1,NPT
         XJ = XYZPT(1,JPT)
         YJ = XYZPT(2,JPT)
         ZJ = XYZPT(3,JPT)
         ELPOTN = ZERO
         DO IAT = 1,NAT
            XJN = XJ - C(1,IAT)
            YJN = YJ - C(2,IAT)
            ZJN = ZJ - C(3,IAT)
            RJN = SQRT(XJN*XJN + YJN*YJN + ZJN*ZJN)
            DUM    = ZAN(IAT)/RJN
            ELPOTN = ELPOTN +           DUM
         ENDDO
         ELPOT(JPT)=ELPOTN-ELPOT(JPT)
      ENDDO
C
      RETURN
      END
C*MODULE SVPCHG  *DECK SVPOUT
      SUBROUTINE SVPOUT(ETOT,ECHIP,NPRINT,WHERE)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      CHARACTER*6 WHERE
C
C     ----- PRINT SVP ENERGY CONTRIUTIONS -----
C
      PARAMETER (MXATM=2000)
      PARAMETER (MXCAV =5810)
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00, FOUR=4.0D+00, TEN3=1.0D+03)
      PARAMETER (TOANGS=0.52917724924D+00,TOBOHR=ONE/TOANGS)
      PARAMETER (TOKCAL=627.509451D+00)
      LOGICAL   OUT
      LOGICAL   SOME
      LOGICAL   IGAS
C
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /IOFILE/ IR,IW,IP,IJK,IJKT,IDAF,NAV,IODA(950)
      COMMON/SVPNRG/ATMSVP,ELCSVP,SVPSVP,SURSVP,VOLPLM,VOLSVP,RXNSVP
      COMMON/SVPFLT/RHOISO,TOLCAV,RSTART,RSPACE,RADSPH,RADSLV,TOLCHG,
     1              DIELST,DIELOP,ZIONP,ZIONM,TKELVN,ROTCAV(3),
     2              TRNCAV(3),CSDIAG,CVGLIN
      COMMON/SVPTGR/NVLPL,MTHSVP,IQORP,NSTAGE,IOPPRD,IRENRM,ISHAPE,
     1              ITRCAV,NDRCAV,ICVICK,IFRQUP,IRDRF,IONSTR,
     2              INTCAV,NPTLEB,NPTTHE,NPTPHI,IROTGR,ITRNGR,
     3              ICRD,LINEQ,IPNRF,IPRRF,IPNDN,IPRDN,IEX
      COMMON/SVPPAR/CAVC(3,MXCAV),CAVW(MXCAV),CAVQ(MXCAV),
     1              CAVN(3,MXCAV),SPHW(MXCAV),CAVP(MXCAV),
     2              CENCAV(3),RNTCAV(3),NCAV,IQP
      COMMON/SVPPRP/SURF,VOL,RHOEXT,CHGBAR,CHGRUL,CHGDEV,BTABAR
      COMMON/SVPCVG/CHGDF
C
      DATA SYMSVP,SYMSSV,SYMCOS,SYMSPE,SYMIEF
     *    /8H  SVPE  ,8HSS(V)PE ,8H COSMO  ,8H  SPE   ,8H  IEF   /
      DATA UNKNWN/8HUNKNOWN /
C
      OUT =.FALSE.
      SOME=.TRUE.
      SOME=SOME.OR.OUT
C     WHEN EGAS BECOMES AVAILABLE SET IGAS=.T.
      EGAS = 0.0D+00
      IGAS=.FALSE.
C
      PI=FOUR*ATAN(ONE)
      RADIAN=PI/180.0D+00
C
      SYMB=UNKNWN
      IF(NVLPL.EQ.0) THEN
         IF(MTHSVP.EQ.0) SYMB=SYMSSV
         IF(MTHSVP.EQ.1) SYMB=SYMCOS
         IF(MTHSVP.EQ.2) SYMB=SYMSPE
         IF(MTHSVP.EQ.3) SYMB=SYMIEF
      ENDIF
      IF(NVLPL.GT.0) SYMB=SYMSVP
      IF(IQORP.EQ.0) WRITE(IW,6000) SYMB
      IF(IQORP.EQ.1) WRITE(IW,6010) SYMB
C
      IF(IGAS) WRITE(6,6020) EGAS
      EINTNL=ETOT-RXNSVP
      IF(IGAS) DEINT=EINTNL-EGAS
      WRITE(IW,6030) EINTNL
      IF(IGAS) WRITE(6,6040) DEINT,DEINT*TOKCAL
      IF(NVLPL.GT.0) THEN
         WRITE(IW,6050) SURSVP,SURSVP*TOKCAL
         WRITE(IW,6052) VOLSVP,VOLSVP*TOKCAL
         WRITE(IW,6053) VOLPLM,VOLPLM*TOKCAL
      ENDIF
      WRITE(IW,6054) RXNSVP,RXNSVP*TOKCAL
      IF(IGAS) WRITE(6,6060) (DEINT+RXNSVP),(DEINT+RXNSVP)*TOKCAL
      WRITE(IW,6070) ETOT
C
C     ----- AREA, CHARGE PEN, EXPONENTIAL PARAM -----
C
      CALL SVPCOR(NCAV,CAVC,CAVW,CAVN,ELFTOT,ZETTOT,WGTTOT)
      AREA=WGTTOT
      RHOIN=ELFTOT/(FOUR*PI)
      RHOEXT=ICH-RHOIN
      ZETAVG=ZETTOT/WGTTOT
C     ASSUME THAT VOL IS AVAILABLE FROM ELSEWHERE, E. G. SVPISO
      IF(IQORP.EQ.0) THEN
         WRITE(IW,6100) SYMB
         WRITE(IW,6110) CHGDF
      ELSEIF(IQORP.EQ.1) THEN
         WRITE(IW,6105) SYMB
         WRITE(IW,6115) CHGDF
      ENDIF
      WRITE(IW,6120) AREA,AREA*TOANGS**2,VOL,VOL*TOANGS**3,RHOEXT
      IF (NVLPL.GT.0 .AND. DIELST.NE.ONE) THEN
         RXTBTA=-BTABAR*DIELST/(DIELST-ONE)
         WRITE(IW,6125) RXTBTA
         WRITE(IW,6127) RHOEXT-RXTBTA
      ENDIF
C
C     ----- SSC(V)PE ENERGY CORRECTION TERM -----
C
      IF(NVLPL.EQ.0 .AND. IQP.EQ.0 .AND. IEX.NE.0) THEN
         QTOT=ZERO
         DO I=1,NCAV
            QTOT=QTOT+CAVQ(I)
         ENDDO
         RHOTLD=ZERO
         FACEPS=(DIELST-ONE)/DIELST
         IF(MTHSVP.EQ.0 .OR. MTHSVP.EQ.1) THEN
            RHOTLD=-QTOT/FACEPS-RHOIN
         ELSEIF(MTHSVP.EQ.3) THEN
            RHOTLD=-QTOT-FACEPS*RHOIN
         ENDIF
         WRITE(IW,6130) QTOT
         IF(MTHSVP.EQ.0 .OR. MTHSVP.EQ.1 .OR. MTHSVP.EQ.3) THEN
            WRITE(IW,6140) RHOTLD
         ENDIF
         WRITE(IW,6150) ZETAVG,(ZETAVG*TOBOHR)
C        EVALUATE SSC(V)PE CORRECTION TERM IF SS(V)PE, COSMO, OR IEF
         IF(MTHSVP.EQ.0 .OR. MTHSVP.EQ.1 .OR. MTHSVP.EQ.3) THEN
            ECHIP=-FACEPS*PI*RHOEXT*RHOTLD/ZETTOT
            WRITE(IW,6160) ECHIP,(ECHIP*TOKCAL)
         ENDIF
C        INCLUDE SSC(V)PE CORRECTION TERM ONLY IF SS(V)PE/ISODEN
         IF(MTHSVP.EQ.0 .AND. ISHAPE.EQ.0) THEN
            RXSCVP=RXNSVP+ECHIP
            ETOTC=ETOT+ECHIP
            WRITE(IW,6170) RXSCVP,(RXSCVP*TOKCAL)
            IF(IGAS) THEN
               SOLEC=ETOTC-EGAS
               WRITE(IW,6180) SOLEC,(SOLEC*TOKCAL)
            ENDIF
            WRITE(IW,6190) ETOTC
         ENDIF
      ENDIF
C
C     ----- REPORT ANY TRANSLATION AND/OR ROTATION OF CAVITY -----
C
      IF(ISHAPE.LT.2.AND.ITRNGR.GE.1.AND.ITRNGR.LE.6) THEN
         WRITE(IW,6200)
         WRITE(IW,6210) (CENCAV(K),K=1,3),(CENCAV(K)*TOANGS,K=1,3)
      ENDIF
      IF(ISHAPE.LT.2.AND.IROTGR.GE.1.AND.IROTGR.LE.3) THEN
         WRITE(IW,6220) (ROTCAV(K)*RADIAN,K=1,3),(ROTCAV(K),K=1,3)
      ENDIF
C
C     ----- PRINT SOLUTE-CAVITY PROXIMITY ... -----
C
      IF(SOME) THEN
         WRITE(IW,6200)
         WRITE(IW,6230)
      ENDIF
      DO IAT=1,NAT
         DMIN=TEN3
         MIND=NCAV+1
         DO ICAV=1,NCAV
            DIST=SQRT((C(1,IAT)-CAVC(1,ICAV))**2+
     1                (C(2,IAT)-CAVC(2,ICAV))**2+
     2                (C(3,IAT)-CAVC(3,ICAV))**2)
            IF(DIST.LT.DMIN) THEN
               DMIN=DIST
               MIND=ICAV
            ENDIF
         ENDDO
         IF(SOME) THEN
            WRITE(IW,6240) IAT,MIND,DMIN,DMIN*TOANGS
         ENDIF
      ENDDO
C
C     ----- PRINT/PUNCH OF REACTION FIELD -----
C     ---- AND PROPERTIES ON CAVITY SURFACE ---
C
      IF(NPRINT.NE.-5) THEN
         IF(IPRRF.NE.0) THEN
            WRITE(IW,6250) WHERE
            CALL SVPWRF(IQORP,NCAV,CAVC,CAVQ,CAVW,CAVN,CAVP,NVLPL)
         ENDIF
         IF(IPNRF.NE.0) THEN
            WRITE(IP,7250) WHERE
            CALL SVPPRF(IQORP,NCAV,CAVC,CAVQ,CAVW,CAVN,CAVP,NVLPL)
         ENDIF
         CALL SVP_CAV_PUN
C        A HACK JUST TO BE SURE SVPIDN IS CALLED SOMEWHERE
         IF (IPNDN.EQ.99) THEN
            CALL SVPIDN(NPT,POT,FLD,RHO,DRN,ALP,WGT,DRG,OUT,DDN,DDL)
         ENDIF
         IF(ABS(IPRDN).NE.0.OR.IPNDN.NE.0) THEN
            CALL SVPODN(IPRDN,IPNDN,NCAV,CAVC,CAVW,CAVN,SPHW,CENCAV)
         ENDIF
      ENDIF
C
C     ----- FLUSH PUNCH AND PRINT BUFFERS -----
C
      CALL FLSHBF(IP)
      CALL FLSHBF(IW)
C
C
 6000 FORMAT(/,1X,A7,'  SOLVATION METHOD ENERGIES',/,
     1         1X,34('-'))
 6010 FORMAT(/,1X,A7,' DIPOLE  SOLVATION METHOD ENERGIES',/,
     1         1X,41('-'))
 6020 FORMAT(' GAS PHASE ENERGY                = ',F13.8)
 6030 FORMAT(' SOLUTE INTERNAL ENERGY          = ',F13.8)
 6040 FORMAT('   [CHANGE IN INTERNAL ENERGY]   = ',F13.8,
     1       ' (',F11.5,' KCAL/MOL )')
 6050 FORMAT('   [SURFACE POLARIZATION ENERGY] = ',F13.8,
     1       ' (',F11.5,' KCAL/MOL )')
 6052 FORMAT('   [VOLUME  POLARIZATION ENERGY] = ',F13.8,
     1       ' (',F11.5,' KCAL/MOL )')
 6053 FORMAT('   [VOL POL  OUTER LAYER ENERGY] = ',F13.8,
     1       ' (',F11.5,' KCAL/MOL )')
 6054 FORMAT(' REACTION FIELD FREE ENERGY      = ',F13.8,
     1       ' (',F11.5,' KCAL/MOL )')
 6060 FORMAT(' ELECTROSTATIC SOLVATION ENERGY  = ',F13.8,
     1       ' (',F11.5,' KCAL/MOL )')
 6070 FORMAT(' TOTAL FREE ENERGY IN SOLUTION   = ',F13.8)
C
 6100 FORMAT(/,1X,A7,'  SOLVATION METHOD PROPERTIES',/,
     1         1X,36('-'))
 6105 FORMAT(/,1X,A7,' DIPOLE  SOLVATION METHOD PROPERTIES',/,
     1         1X,43('-'))
 6110 FORMAT(' CONVERGENCE ON SURFACE CHARGES  = ',D17.6)
 6115 FORMAT(' CONVERGENCE ON SURFACE DIPOLES  = ',D17.6)
 6120 FORMAT(' CAVITY SURFACE AREA             = ',F13.3,
     1       ' ( ',F12.3,' ANG**2 )',/,
     2       ' CAVITY VOLUME                   = ',F13.3,
     3       ' ( ',F12.3,' ANG**3 )',/,
     4       ' CHARGE PENETRATION BY GAUSS LAW = ',F13.6)
 6125 FORMAT(' CHARGE PENETRATION FROM BETABAR = ',F13.6)
 6127 FORMAT(' CHARGE PENETRATION DISCREPANCY  = ',F13.6)
 6130 FORMAT(' TOTAL APPARENT SURFACE CHARGE Q = ',F13.6)
 6140 FORMAT(' WEIGHTED CHARGE PEN RHOTILDA    = ',F13.6)
 6150 FORMAT(' AVG EXPONENTIAL FIT PARAM ZETA  = ',F13.6,
     1       ' (',F11.5,' ANG**-1  )')
 6160 FORMAT(' VOL POL CORRECTION DIAGNOSTIC   = ',F13.8,
     1       ' (',F11.5,' KCAL/MOL )')
 6170 FORMAT(' SSC(V)PE FREE ENERGY CORRECTION = ',F13.8,
     1       ' (',F11.5,' KCAL/MOL )')
 6180 FORMAT(' CORRECTED ELECTROSTATIC SOLV EN = ',F13.8,
     1       ' (',F11.5,' KCAL/MOL )')
 6190 FORMAT(' CORRECTED TOTAL FREE ENERGY     = ',F13.8)
C
 6200 FORMAT(1H )
 6210 FORMAT(' CAVITY TRANSLATED TO XYZ (AU)   = ',1X,3F12.6/
     1       '                      XYZ (ANG)  = ',1X,3F12.6)
 6220 FORMAT(' CAVITY   ROTATED  BY TPC (RAD)  = ',1X,3F12.6/
     1       '                      TPC (DEG)  = ',1X,3F12.5)
 6230 FORMAT(' SOLUTE/CAVITY PROXIMITY',/,1X,23('-'))
 6240 FORMAT(' IAT = ',I5,' ICAV = ',I7,' DIST = ',F8.4,
     1       ' ( ',F8.4,'  ANG ) ')
 6250 FORMAT(/' ----- SVP REACTION FIELD FROM ',A6,' -----')
 7250 FORMAT( ' ----- SVP REACTION FIELD FROM ',A6,' -----')
C
      RETURN
      END
C*MODULE SVPCHG  *DECK SVPCOR
      SUBROUTINE SVPCOR(NCAV,CAVC,CAVW,CAVN,ELFTOT,ZETTOT,WGTTOT)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C     ----- INGREDIENTS FOR SSC(V)PE CORRECTION TERM -----
C
      PARAMETER (ZERO=0.0D+00)
      PARAMETER   (MXATM=2000)
      LOGICAL     DBUG
      LOGICAL     CAVPOT,CAVFLD
      COMMON /FMCOM / X(1)
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /IOFILE/ IR,IW,IP,IJK,IJKT,IDAF,NAV,IODA(950)
      DIMENSION CAVC(3,*),CAVW(*),CAVN(3,*)
C
      DBUG=.FALSE.
C
      L2=(NUM*(NUM+1))/2
C
C     ----- SET POINTERS FOR PARTITIONING OF CORE -----
C
C     -DMAT-   AT X(I10)
C     -ELP-    AT X(I20)
C     -ELF-    AT X(I30)
C     -RHO-    AT X(I40)
C     -DRHO-   AT X(I50)
C
C     --- GET FAST MEMORY -----
C
      CALL VALFM(LOADFM)
      I10=LOADFM+1
      I20=I10+L2
      I30=I20+NCAV
      I40=I30+NCAV
      I50=I40+NCAV
      I60=I50+3*NCAV
      LAST=I60+2
      NEED=LAST - LOADFM - 1
      CALL GETFM(NEED)
C
C     ----- GET TOTAL DENSITY MATRIX OVER AO'S -----
C
      CALL DENDD1(X(I10),X(I20),L2)
      IF(DBUG) THEN
         WRITE(IW,6010) L2
         WRITE(IW,6020) (X(I10+II),II=1,L2)
 6010    FORMAT('/ DEBUG PRINT OF DENSITY MATRIX IN SVPCOR, L2=',I5)
 6020    FORMAT(5X,12F10.6)
      ENDIF
C
C     ----- EVALUATE SOLUTE DENSITY PROPERTIES AT CAVITY SURFACE -----
C
C     ELP  = ELECTROSTATIC POTENTIAL
C     ELFN = NORMAL ELECTRIC FIELD
C     RHO  = ELECTRONIC DENSITY
C     DRN  = DERIVATIVE OF DENSITY IN NORMAL DIRECTION
C     ZETA = -DRN/RHO
C     WGT  = WEIGHT, I.E., SURFACE AREA
C
      CAVPOT=.TRUE.
      CAVFLD=.TRUE.
      IADDL=I50
      ILAST=I50+3*NCAV
C
C     --- GRAB THE AS YET UNUSED SPACE IN DRHO FOR SCRATCH IN SVPEPF ---
C
      CALL SVPEPF(X(I10),IADDL,ILAST,NCAV,CAVC,CAVN,
     1            CAVPOT,X(I20),CAVFLD,X(I30))
C
      NDER=1
      CALL SVP_ELDEND(NCAV,CAVC,X(I40),X(I50),XDUM,X(I10),NDER)
C
      ELFTOT=ZERO
      ZETTOT=ZERO
      WGTTOT=ZERO
      DO I=1,NCAV
         ELFN=X(I+I30-1)
         RHO=X(I+I40-1)
         DRHOX=X(1+3*(I-1)+I50-1)
         DRHOY=X(2+3*(I-1)+I50-1)
         DRHOZ=X(3+3*(I-1)+I50-1)
         XN=CAVN(1,I)
         YN=CAVN(2,I)
         ZN=CAVN(3,I)
         WGT=CAVW(I)
         DRN=XN*DRHOX+YN*DRHOY+ZN*DRHOZ
         ZETA=-DRN/RHO
         ELFTOT=ELFTOT+ELFN*WGT
         ZETTOT=ZETTOT+ZETA*WGT
         WGTTOT=WGTTOT+WGT
      ENDDO
C
C     ----- RESET FAST MEMORY -----
C
      CALL RETFM(NEED)
      RETURN
C
      END
