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,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,CITYP,DFTYPE,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/METHOD,IQORP,NSTAGE,IOPPRD,IRENRM,ISHAPE,ITRCAV,
     1       NDRCAV,ICVICK,IFRQUP,IRDRF,IONSTR,INTCAV,NPTLEB,NPTTHE,
     2       NPTPHI,IROTGR,ITRNGR,ICRD,LINEQ,IPNRF,IPRRF,IPNDN,IPRDN,
     3       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
      COMMON/SVPNRG/ATMSVP,ELCSVP,SVPSVP,ALLSVP,RXNSVP
      COMMON/SVPPRP/SURF,VOL,RHOEXT,CHGBAR,CHGRUL,CHGDEV
      COMMON/SVPDBG/IDBG
      COMMON/SVPCVG/CHGDF
C
      DIMENSION DA(*),DB(*)
C
      CHARACTER*4 KEYBLK,KEYFST,IFIRST
C
      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
      NFT17 = 26
      NFT18 = 27
      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
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
      ESVP=ZERO
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
            IF (ICVICK.GT.0) THEN
               CALL SVPICK(CENCAV,CAVC,X(I40),NCAV,RHOISO,DA,
     1                     X(I30),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
      IF(OUT) THEN
         WRITE(IW,*) '-IQORP-  = ',IQORP
         WRITE(IW,*) '-IUPRXN- = ',IUPRXN
         WRITE(IW,*) '-METHOD- = ',METHOD
         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(METHOD.EQ.0.OR.METHOD.EQ.1.OR.METHOD.EQ.3) CAVPOT=.TRUE.
         ENDIF
         IF(IQORP.EQ.0) THEN
            IF(METHOD.EQ.2.OR.METHOD.EQ.3) CAVFLD=.TRUE.
         ENDIF
      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(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 POINT CHARGES OR DIPOLES -----
C
      IADDL=I50
      IF(IUPRXN.EQ.2.AND.IQORP.EQ.0.AND.METHOD.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))
      ENDIF
      IF(IUPRXN.EQ.2.AND.IQORP.EQ.0.AND.METHOD.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.METHOD.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.METHOD.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.METHOD.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.METHOD.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.METHOD.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.METHOD.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     ----- CALCULATE ENERGY TERMS FROM -SVP- CHARGES OR DIPOLES -----
C
      IF(IUPRXN.EQ.0) THEN
         CALL SVPENR(NCAV0,IQP0,CAVC0,CAVQ0,CAVN0,CAVP0,
     1               X(I20),X(I30),ATMSVP,ELCSVP,SVPSVP,ALLSVP,RXNSVP)
      ENDIF
      IF(IUPRXN.GT.0) THEN
         CALL SVPENR(NCAV ,IQP ,CAVC ,CAVQ ,CAVN ,CAVP ,
     1               X(I20),X(I30),ATMSVP,ELCSVP,SVPSVP,ALLSVP,RXNSVP)
      ENDIF
      ESVP   = RXNSVP
C
      IF(OUT) THEN
         WRITE(IW,8769)
         WRITE(IW,8768) ATMSVP,ELCSVP,SVPSVP,RXNSVP,(RXNSVP*TOKCAL)
         WRITE(IW,8767)
         WRITE(IW,8766) SURF,SURF*TOANGS**2,VOL,VOL*TOANGS**3,RHOEXT
         IF(IQORP.EQ.0) THEN
            WRITE(IW,8765) 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 / SVP  ENERGY      = ',F16.6,/,
     1       ' ELC / SVP  ENERGY      = ',F16.6,/,
     2       ' SVP / SVP  ENERGY      = ',F16.6,/,
     3       ' RXN FIELD FREE ENERGY  = ',F16.6,
     4       ' ( ',F10.3,' KCAL/MOL ) ')
 8767 FORMAT(/,1X,'-SVP-  PROPERTIES',/,1X,17('-'))
 8766 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)
 8765 FORMAT(' TOTAL SURFACE CHARGE Q = ',F16.6/
     1       ' CHGRUL= -Q*EPS/(EPS-1) = ',F16.6/
     2       ' SOLUTE CHARGE - CHGRUL = ',F16.6)
      END
C*MODULE SVPCHG  *DECK SVPENR
      SUBROUTINE SVPENR(NCAV,IQP,CAVC,CAVQ,CAVN,CAVP,ELP,ELF,
     1                  ATMSVP,ELCSVP,SVPSVP,ALLSVP,RXNSVP)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C     ----- REACTION FIELD FREE 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
      ALLSVP=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)
            ALLSVP=ALLSVP+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)
            ALLSVP=ALLSVP-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 = ALLSVP-ATMSVP
      RXNSVP = ALLSVP/TWO
C
 9988 FORMAT(' --- WARNING - ELECTRIC FIELD AT ',
     1 3F10.5,' . CONTRIBUTION FROM  -IAT-  ',I3,' IGNORED')
      RETURN
      END
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
      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
      ALPHA=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
               ALPHAI=ALPHA
               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
                     ALPHAI=ALPHA
                  ELSEIF(ITER.GT.1) THEN
                     DRHOI=(RHOI-DRHO(2,I))/(RI-DRHO(1,I))
                     ALPHAI=-DRHOI/RHOI
                  ENDIF
               ELSEIF(NDER.EQ.1) THEN
                  DRHOI=(DRHO(1,I)*XI+DRHO(2,I)*YI+DRHO(3,I)*ZI)/RI
                  ALPHAI=-DRHOI/RHOI
               ENDIF
               IF(ALPHAI.EQ.ZERO) THEN
                  WRITE(IW,*) 'EFFECTIVE EXPONENTIAL ALPHA = ZERO. STOP'
                  WRITE(IW,*) 'ITER,I,X,Y,Z,R,RHO,DRHO =',
     1                         ITER,I,XI,YI,ZI,RI,RHOI,DRHOI
                  CALL ABRT
               ELSEIF(ALPHAI.LT.ZERO) THEN
                  NMNEGA=NMNEGA+1
               ENDIF
C
C     ASSUME EXPONENTIAL RADIAL DENSITY TO PREDICT ISODENSITY P
C
               IF(ALPHAI.GT.ZERO.OR.
     1           (ALPHAI.LT.ZERO.AND.RHOI.GT.RHOISO)) THEN
                  DELR=(ONE/ALPHAI)*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 ALPHA AT SMALL RHO
C
               IF(ALPHAI.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 ALPHA'S -----
C
      IF(NMNEGA.GT.0) THEN
         WRITE(IW,*) 'APPARENTLY CONVERGED ISODENSITY SURFACE REJECTED'
         WRITE(IW,*) 'DUE TO NEGATIVE EXPONENTIAL ALPHA: 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
         ALPHAI=-DRHOI/RHOI
C
C     NEGATIVE HERE BECAUSE CHARGE IS DUE TO ELECTRONS
C
         RHOEXI=-(RI**2/ALPHAI+TWO*RI/ALPHAI**2+TWO/ALPHAI**3)*RHOI
         RHOEXT=RHOEXT+RHOEXI*SPHW(I)
      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*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 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 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--C*MODULE SVPCHG  *DECK SVPDAF
C--      SUBROUTINE SVPDAF(IVIB)
C--      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C--      PARAMETER (MXCAV=5810)
C--      COMMON /FMCOM / X(1)
C--      COMMON /IOFILE/ IR,IW,IP,IJK,IJKT,IDAF,NAV,IODA(950)
C--      COMMON/SVPPAR/CAVC(3,MXCAV),CAVW(MXCAV),CAVQ(MXCAV),
C--     1              CAVN(3,MXCAV),SPHW(MXCAV),CAVP(MXCAV),
C--     2              CENCAV(3),RNTCAV(3),NCAV,IQP
C--C
C--      LENDAF=10*NCAV+6
C--C
C--C     ----- SET POINTERS FOR PARTITIONING OF CORE -----
C--C
C--      CALL VALFM(LOADFM)
C--      I10  = LOADFM + 1
C--      LAST = I10    + LENDAF
C--      NEED = LAST - LOADFM - 1
C--      CALL GETFM(NEED)
C--C
C--      IF(IVIB.GT.0) GO TO 20
C--C
C--C     --- WRITE CONTENTS OF COMMON/SVPPAR IN RECORD 260 OF -IDAF- ---
C--C
C--      LOFF=0
C--      DO I=1,NCAV
C--         DO K=1,3
C--            LOFF=LOFF+1
C--            X(I10+LOFF-1)=CAVC(K,I)
C--         ENDDO
C--      ENDDO
C--      DO I=1,NCAV
C--         LOFF=LOFF+1
C--         X(I10+LOFF-1)=CAVW(I)
C--      ENDDO
C--      DO I=1,NCAV
C--         LOFF=LOFF+1
C--         X(I10+LOFF-1)=CAVQ(I)
C--      ENDDO
C--      DO I=1,NCAV
C--         DO K=1,3
C--            LOFF=LOFF+1
C--            X(I10+LOFF-1)=CAVN(K,I)
C--         ENDDO
C--      ENDDO
C--      DO I=1,NCAV
C--         LOFF=LOFF+1
C--         X(I10+LOFF-1)=SPHW(I)
C--      ENDDO
C--      DO I=1,NCAV
C--         LOFF=LOFF+1
C--         X(I10+LOFF-1)=CAVP(I)
C--      ENDDO
C--      DO I=1,3
C--         LOFF=LOFF+1
C--         X(I10+LOFF-1)=CENCAV(I)
C--      ENDDO
C--      DO I=1,3
C--         LOFF=LOFF+1
C--         X(I10+LOFF-1)=RNTCAV(I)
C--      ENDDO
C--      CALL DAWRIT(IDAF,IODA,X(I10),LENDAF,260,0)
C--      GO TO 30
C--C
C--C     -- READ CONTENTS OF COMMON/SVPPAR FROM RECORD 260 OF -IDAF- ---
C--C
C--   20 CONTINUE
C--      CALL DAREAD(IDAF,IODA,X(I10),LENDAF,260,0)
C--      LOFF=0
C--      DO I=1,NCAV
C--         DO K=1,3
C--            LOFF=LOFF+1
C--            CAVC(K,I)=X(I10+LOFF-1)
C--         ENDDO
C--      ENDDO
C--      DO I=1,NCAV
C--         LOFF=LOFF+1
C--         CAVW(I)=X(I10+LOFF-1)
C--      ENDDO
C--      DO I=1,NCAV
C--         LOFF=LOFF+1
C--         CAVQ(I)=X(I10+LOFF-1)
C--      ENDDO
C--      DO I=1,NCAV
C--         DO K=1,3
C--            LOFF=LOFF+1
C--            CAVN(K,I)=X(I10+LOFF-1)
C--         ENDDO
C--      ENDDO
C--      DO I=1,NCAV
C--         LOFF=LOFF+1
C--         SPHW(I)=X(I10+LOFF-1)
C--      ENDDO
C--      DO I=1,NCAV
C--         LOFF=LOFF+1
C--         CAVP(I)=X(I10+LOFF-1)
C--      ENDDO
C--      DO I=1,3
C--         LOFF=LOFF+1
C--         CENCAV(I)=X(I10+LOFF-1)
C--      ENDDO
C--      DO I=1,3
C--         LOFF=LOFF+1
C--         RNTCAV(I)=X(I10+LOFF-1)
C--      ENDDO
C--   30 CONTINUE
C--C
C--      CALL GETFM(NEED)
C--      RETURN
C--      END
C*MODULE SVPCHG  *DECK SVPHAM
      SUBROUTINE SVPHAM(NCAV,CAVC,CAVQ,CAVN,CAVP,IQP,H0,HSVP,L2)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      LOGICAL     DBUG
      LOGICAL     OUT
      COMMON /IOFILE/ IR,IW,IP,IJK,IJKT,IDAF,NAV,IODA(950)
      DIMENSION CAVC(3,*),CAVQ(*),CAVN(3,*),CAVP(*)
      DIMENSION   H0(L2)
      DIMENSION HSVP(L2)
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
      IF(IQP.EQ.0.OR.IQP.EQ.2) THEN
C
C     ----- HAMILTONIAN OPERATOR DUE TO -SVP- CHARGES -----
C
         CALL SVPEFC(NCAV,CAVC,CAVQ,HSVP,H0)
      ENDIF
      IF(IQP.EQ.1.OR.IQP.EQ.2) THEN
C
C     ----- HAMILTONIAN OPERATOR DUE TO -SVP- DIPOLES -----
C
         CALL SVPEFD(NCAV,CAVC,CAVN,CAVP,HSVP,H0)
      ENDIF
C
      RETURN
 9999 FORMAT(/,10X,30('-'),
     1       /,10X,'-SVP- POINT CHARGE HAMILTONIAN',
     2       /,10X,30('-'))
 9998 FORMAT(/,10X,30('-'),
     1       /,10X,'-SVP- POINT DIPOLE HAMILTONIAN',
     2       /,10X,30('-'))
 9997 FORMAT(/,10X,37('-'),
     1       /,10X,'-SVP- POINT CHARGE+DIPOLE HAMILTONIAN',
     2       /,10X,37('-'))
 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)
      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     -----  ADD -HSVP- TO -H0-  -----
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
      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 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 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
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 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,ALLSVP,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/METHOD,IQORP,NSTAGE,IOPPRD,IRENRM,ISHAPE,ITRCAV,
     1       NDRCAV,ICVICK,IFRQUP,IRDRF,IONSTR,INTCAV,NPTLEB,NPTTHE,
     2       NPTPHI,IROTGR,ITRNGR,ICRD,LINEQ,IPNRF,IPRRF,IPNDN,IPRDN,
     3       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
      COMMON/SVPCVG/CHGDF
C
      DATA SYMSVP,SYMCOS,SYMSPE,SYMIEF
     *    /8HSS(V)PE ,8HCOSMO   ,8H  SPE   ,8H  IEF   /
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=SYMSVP
      IF(METHOD.EQ.1) SYMB=SYMCOS
      IF(METHOD.EQ.2) SYMB=SYMSPE
      IF(METHOD.EQ.3) SYMB=SYMIEF
      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
      WRITE(IW,6050) 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
C
C     ----- SSC(V)PE ENERGY CORRECTION TERM -----
C
      IF(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(METHOD.EQ.0 .OR. METHOD.EQ.1) THEN
            RHOTLD=-QTOT/FACEPS-RHOIN
         ELSEIF(METHOD.EQ.3) THEN
            RHOTLD=-QTOT-FACEPS*RHOIN
         ENDIF
         WRITE(IW,6130) QTOT
         IF(METHOD.EQ.0 .OR. METHOD.EQ.1 .OR. METHOD.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(METHOD.EQ.0 .OR. METHOD.EQ.1 .OR. METHOD.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(METHOD.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)
         ENDIF
         IF(IPNRF.NE.0) THEN
            WRITE(IP,7250) WHERE
            CALL SVPPRF(IQORP,NCAV,CAVC,CAVQ,CAVW,CAVN,CAVP)
         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,'-  ENERGIES',/,1X,19('-'))
 6010 FORMAT(/,1X,'-',A7,' DIPOLE-  ENERGIES',/,1X,26('-'))
 6020 FORMAT(' GAS PHASE ENERGY                = ',F12.6)
 6030 FORMAT(' SOLUTE INTERNAL ENERGY          = ',F12.6)
 6040 FORMAT(' CHANGE IN INTERNAL ENERGY       = ',F12.6,
     1       ' ( ',F10.3,' KCAL/MOL ) ')
 6050 FORMAT(' REACTION FIELD FREE ENERGY / 2  = ',F12.6,
     1       ' ( ',F10.3,' KCAL/MOL ) ')
 6060 FORMAT(' ELECTROSTATIC SOLVATION ENERGY  = ',F12.6,
     1       ' ( ',F10.3,' KCAL/MOL ) ')
 6070 FORMAT(' TOTAL FREE ENERGY IN SOLUTION   = ',F12.6)
C
 6100 FORMAT(/,1X,'-',A7,'-  PROPERTIES',/,1X,21('-'))
 6105 FORMAT(/,1X,'-',A7,' DIPOLE-  PROPERTIES',/,1X,28('-'))
 6110 FORMAT(' CONVERGENCE ON SURFACE CHARGES  = ',D16.6)
 6115 FORMAT(' CONVERGENCE ON SURFACE DIPOLES  = ',D16.6)
 6120 FORMAT(' CAVITY SURFACE AREA             = ',F12.3,
     1       ' ( ',F12.3,' ANG**2 ) ',/,
     2       ' CAVITY VOLUME                   = ',F12.3,
     3       ' ( ',F12.3,' ANG**3 ) ',/,
     4       ' CHARGE PENETRATION BY GAUSS LAW = ',F12.6)
 6130 FORMAT(' TOTAL APPARENT SURFACE CHARGE Q = ',F12.6)
 6140 FORMAT(' WEIGHTED CHARGE PEN RHOTILDA    = ',F12.6)
 6150 FORMAT(' AVG EXPONENTIAL FIT PARAM ZETA  = ',F12.6,
     1       ' ( ',F10.6,'  ANG**-1 ) ')
 6160 FORMAT(' VOL POL CORRECTION DIAGNOSTIC   = ',F12.6,
     1       ' ( ',F10.3,' KCAL/MOL ) ')
 6170 FORMAT(' SSC(V)PE FREE ENERGY CORRECTION = ',F12.6,
     1       ' ( ',F10.3,' KCAL/MOL ) ')
 6180 FORMAT(' CORRECTED ELECTROSTATIC SOLV EN = ',F12.6,
     1       ' ( ',F10.3,' KCAL/MOL ) ')
 6190 FORMAT(' CORRECTED TOTAL FREE ENERGY     = ',F12.6)
C
 6200 FORMAT(1H )
 6210 FORMAT(' CAVITY TRANSLATED TO XYZ (AU)  =',3F15.6/
     1       '                      XYZ (ANG) =',3F15.6)
 6220 FORMAT(' CAVITY   ROTATED  BY TPC (RAD) =',3F15.6/
     1       '                      TPC (DEG) =',3F15.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
