C     GRASP0.f                 v9.9                      nrb 30 Jun 2021 
c
c     GRASP0.f                 v8.5                      phn 30 May 2006
c
c     v9.9: Bug-fix COULG did not re-initialize L-spinor 
c           flag to .false. for l>0 for any non-L-spinors - cpb
c     v9.8: Bug-fix OSCL/PRINTA E1 vel/len divide by zero - nrb
c           All level dimensions i4,and interfacing with 
c           grasp.adf04/grasprad                          - cpb
c     v9.7: OSCL 4 gives magnetic sub-level resolution    - cpb
c     v9.6: Pure SCF option when no MCP.DAT (& ANG 8)     - nrb
c     v9.5: Diagonalize each H(Jp) separately             - nrb
c     v9.4: L-spinor basis for use with DARC DRMPS        - nrb
c
      PROGRAM GRASP
C ======================================================================
C
C DARC, the Dirac Atomic R-matrix Codes.
C homepage: http://www.am.qub.ac.uk/DARC/
C GRASP0 module
C
C ======================================================================
C
C Any inquiries or comments on the code can be directed to Dr Patrick
C Norrington at :
C
C Department of Applied Mathematics and Theoretical Physics
C The Queen's University of Belfast
C Belfast
C Northern Ireland
C BT7 1NN
C United Kingdom
C
C email     : p.norrington@qub.ac.uk
C homepage  : http://www.am.qub.ac.uk/users/p.norrington
C
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
C
C  Local variables
C
      CHARACTER*60 AUT,DAT,REV,SOU
C
C  Common variables
C
      INTEGER IPUNCH,IREAD,IWRITE
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
C
      DOUBLE PRECISION XCON1
      DOUBLE PRECISION XCON2
      DOUBLE PRECISION XCON3
      DOUBLE PRECISION XCON4
      DOUBLE PRECISION XCL
      DOUBLE PRECISION XPI
      DOUBLE PRECISION XTAU
      COMMON / XCONS / XCON1, XCON2, XCON3, XCON4, XCL, XPI, XTAU
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C
C  Conversion factors for units and constants
C
C    XCON1 is the electron mass in amu
C    XCON2 is the Hartree energy in cm-1
C    XCON3 is the Hartree energy in eV
C    XCON4 converts from cm-1 to Angstrom
C    XCL is the speed of light in a.u. or 1/fine-structure constant
C    XPI is pi
C    XTAU is the atomic unit of time in seconds
C
      XCON1 = 9.10938188D-31/1.66053873D-27
      XCON2 = 2.194746313710D5
      XCON3 = 27.2113834D0
      XCON4 = 1.D8
      XCL = 137.03599976D0
      XPI = 3.141592653589793D0
      XTAU = 2.418884326500D-17
C-----------------------------------------------------------------------
C
C  Set the stream numbers for :
C
C  (1) reading from input data (IREAD)
C  (2) writing to lineprinter  (IWRITE)
C  (3) further output stream   (IPUNCH)
C
      IREAD = 5
      IWRITE = 7
      IPUNCH = 8
C
      OPEN (UNIT=IWRITE,FILE='GRASP.OUT',STATUS='UNKNOWN')
      OPEN (UNIT=IPUNCH,FILE='GRASP.PUN',STATUS='UNKNOWN')
C-----------------------------------------------------------------------
      WRITE (IWRITE,4002)
 4002 FORMAT(/' NJSYM version')
C-----------------------------------------------------------------------
      SOU = '$Source: /home/badnell/grasp0 '
      AUT = '$Author: nrb'
      DAT = '$Date: Fri May 27 17:02:04 BST 2011 $'
      REV = "$Revision: 9.8, derived from phn's 8.5 $ "
C
      PRINT 3000,SOU,AUT,DAT,REV
      WRITE (IWRITE,3000) SOU,AUT,DAT,REV
      WRITE (IPUNCH,3000) SOU,AUT,DAT,REV
C-----------------------------------------------------------------------
      CALL AA
C-----------------------------------------------------------------------
 3000 FORMAT (/1X,71('*')/1X,A60/1X,A60/1X,A60/1X,A60/1X,71('*')//
     +' DARC, the Dirac Atomic R-matrix Codes.'/
     +' homepage: http://www.am.qub.ac.uk/DARC/'/
     +' GRASP0 module'/' Coded in double precision FORTRAN'
     +//' Any inquiries or comments on the code can be directed to'/
     +' Dr Patrick Norrington at :'//
     +' Department of Applied Mathematics and Theoretical Physics'/
     +' The Queens University of Belfast'/' Belfast'/' Northern Ireland'
     +/' BT7 1NN'/' United Kingdom'//
     +' email     : p.norrington@qub.ac.uk'/
     +' homepage  : http://www.am.qub.ac.uk/users/p.norrington'//1X,71(
     +'*'))
      END
C
C                             *******************
C
      SUBROUTINE AA
C
C-----------------------------------------------------------------------
C
C  This routine directs control to each section in turn.
C
C  After processing one problem it loops back indefinitely to start a
C  new problem, unless label STOP has been read.
C
C       AA
C           BENA
C           CALEN
C           DATAIN
C           DIMPRT
C           DIMSET
C           MCDF
C           MCP
C           OSCL
C           QUARTZ
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  Parameter variables
C
      DOUBLE PRECISION EPS10
      PARAMETER (EPS10=1.D-10)
      INTEGER N10
      PARAMETER (N10=MXNX*MXNC)
      INTEGER N11
      PARAMETER (N11=MXNP+10)
      INTEGER N18
      PARAMETER (N18=MXNC*(MXNC+1)/2)
      INTEGER MANGM
      PARAMETER (MANGM=60)
      INTEGER MTRIAD
      PARAMETER (MTRIAD=20)
      INTEGER NPLX
      PARAMETER (NPLX=14)
C
C  Local variables
C
      CHARACTER EMPTY,INPREC(80)
      DOUBLE PRECISION TIM1,TIM2,TIM3,TIM4
      DOUBLE PRECISION TIMT1,TIMT2,TIMT3,TIMT4
      INTEGER I,INPUNI,IO1,IO2
      INTEGER IO3,IO4,IO5,IO6
      INTEGER IO7,IO8,IP2,IP3
      INTEGER IR1,IR2,IR3,ISTOP
      INTEGER LENREC
      LOGICAL EX,TBENA,TMCDF,TMCP
      LOGICAL TMCT
C
C  Common variables
C
      INTEGER J1(MANGM),J2(MTRIAD,3)
      INTEGER J3(MTRIAD,3),MMOM,NMOM
      LOGICAL FREE(MANGM)
      COMMON / ANG00  / MMOM,NMOM,J1,J2,J3,FREE
C
C  Common variables
C
      INTEGER IBREIT,ICOUL,IEXCH
      COMMON / ANG01  / ICOUL,IBREIT,IEXCH
C
C  Common variables
C
      INTEGER NOUT1
      COMMON / ANG02  / NOUT1
C
C  Common variables
C
      INTEGER ITOT(9),JTOT(9),KTOT(9)
      COMMON / ANG03  / ITOT,JTOT,KTOT
C
C  Common variables
C
      INTEGER IME,JA,JB,NWA
      COMMON / ANG04  / IME,JA,JB,NWA
C
C  Common variables
C
      INTEGER ICORE(MXNW)
      COMMON / ANG05  / ICORE
C
C  Common variables
C
      INTEGER JBQ1(3,MXNW),JBQ2(3,MXNW)
      INTEGER JTQ1(3),JTQ2(3)
      COMMON / ANG08  / JBQ1,JBQ2,JTQ1,JTQ2
C
C  Common variables
C
      INTEGER J2S(MTRIAD,3),J3S(MTRIAD,3)
      COMMON / ANG09  / J2S,J3S
C
C  Common variables
C
      INTEGER JJC1(NPLX),JJC2(NPLX)
      COMMON / ANG10  / JJC1,JJC2
C
C  Common variables
C
      INTEGER NQ1(MXNW),NQ2(MXNW)
      COMMON / ANG11  / NQ1,NQ2
C
C  Common variables
C
      INTEGER JJQ1(3,MXNW),JJQ2(3,MXNW)
      COMMON / ANG12  / JJQ1,JJQ2
C
C  Common variables
C
      INTEGER JLIST(NPLX),KLIST(MXNW),NCORE,NPEEL
      COMMON / ANG13  / JLIST,KLIST,NPEEL,NCORE
C
C  Common variables
C
      DOUBLE PRECISION ATW,FACTAN,FACTCM,FACTEV
      DOUBLE PRECISION FACTRY
      COMMON / ATOM   / ATW,FACTRY,FACTCM,FACTEV,FACTAN
C
C  Common variables
C
      DOUBLE PRECISION BESSJ(2,2,MXNP),BESSN(2,2,MXNP)
      DOUBLE PRECISION WIJ(2)
      COMMON / BESS1  / WIJ,BESSJ,BESSN
C
C  Common variables
C
      DOUBLE PRECISION COUVEC(MXNC,MXNC)
      COMMON / BRET1  / COUVEC
C
C  Common variables
C
      DOUBLE PRECISION BREVEC(MXNC,MXNC)
      COMMON / BRET2  / BREVEC
C
C  Common variables
C
      INTEGER LABEL
      COMMON / CARD   / LABEL
C
C  Common variables
C
      DOUBLE PRECISION TIME1,TIME2
      COMMON / CASIO  / TIME1,TIME2
C
C  Common variables
C
      DOUBLE PRECISION HALF,ONE,TEN,TENTH
      DOUBLE PRECISION THREE,TWO,ZERO
      COMMON / CONS   / ZERO,HALF,TENTH,ONE,TWO,THREE,TEN
C
C  Common variables
C
      DOUBLE PRECISION XCAX
      COMMON / CONVG  / XCAX
C
C  Common variables
C
      INTEGER IDN(5),IDNL(16,5),IDNS(16,5)
      INTEGER IDNV(16,5)
      COMMON / CSFD   / IDNV,IDNS,IDNL,IDN
C
C  Common variables
C
      INTEGER IBUG1,IBUG2,IBUG3,IBUG4
      INTEGER IBUG5,IBUG6
      COMMON / DEBUG  / IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6
C
C  Common variables
C
      DOUBLE PRECISION ACCY,C,EPH,H
      DOUBLE PRECISION RNT,Z
      INTEGER N,NCPRIN,NW1
      COMMON / DEF01  / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN
C
C  Common variables
C
      DOUBLE PRECISION CHECK
      INTEGER NITIT
      COMMON / DEF04  / CHECK,NITIT
C
C  Common variables
C
      DOUBLE PRECISION WT(MXNC)
      INTEGER ITY
      COMMON / DEF05  / WT,ITY
C
C  Common variables
C
      INTEGER ICCMIN(MXNC),NCMIN
      COMMON / DEF07  / NCMIN,ICCMIN
C
C  Common variables
C
      DOUBLE PRECISION BREENG(MXNC),COUENG(MXNC)
      COMMON / ENRG1  / COUENG,BREENG
C
C  Common variables
C
      DOUBLE PRECISION SFENG(MXNC),VPENG(MXNC)
      COMMON / ENRG2  / VPENG,SFENG
C
C  Common variables
C
      DOUBLE PRECISION PZ(MXNW),QZ(MXNW)
      COMMON / EXCO   / PZ,QZ
C
C  Common variables
C
      INTEGER JFIX(MXNW)
      COMMON / FIXD   / JFIX
C
C  Common variables
C
      DOUBLE PRECISION RGRID(MXNP)
      COMMON / GRID   / RGRID
C
C  Common variables
C
      DOUBLE PRECISION EAV,UCF(MXNW)
      COMMON / HMAT   / EAV,UCF
C
C  Common variables
C
      INTEGER IPUNCH,IREAD,IWRITE
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
C
C  Common variables
C
      DOUBLE PRECISION P(MXNP),PC(MXNP),Q(MXNP)
      DOUBLE PRECISION QC(MXNP)
      COMMON / INT2   / P,Q,PC,QC
C
C  Common variables
C
      DOUBLE PRECISION XF(MXNP),XG(MXNP),XR(MXNP)
      DOUBLE PRECISION XS(MXNP),XU(MXNP),XV(MXNP)
      COMMON / INT3   / XU,XV,XR,XS,XF,XG
C
C  Common variables
C
      INTEGER LEVELS(MXNC),NLEV
      COMMON / LEVL   / NLEV,LEVELS
C
C  Common variables
C
      DOUBLE PRECISION ENLEV(MXNC),GAUGE1,GAUGE2
      COMMON / LEVM   / ENLEV,GAUGE1,GAUGE2
C
C  Common variables
C
      INTEGER MAXDIM(20),NAXDIM(20)
      COMMON / MAXDIM / MAXDIM,NAXDIM
C
C  Common variables
C
      DOUBLE PRECISION XSLDR(MXNM)
      INTEGER ISLDR(MXNM),NMCP
      COMMON / MCPA   / XSLDR,ISLDR,NMCP
C
C  Common variables
C
      INTEGER NNLDR(N18),NSLDF(N18)
      COMMON / MCPB   / NNLDR,NSLDF
C
C  Common variables
C
      DOUBLE PRECISION CXCF(MXNE)
      INTEGER JXCF(MXNE),NSCF,NSCFY
      COMMON / MCPC   / CXCF,JXCF,NSCF,NSCFY
C
C  Common variables
C
      INTEGER IOPAR,KA
      COMMON / MCTA   / KA,IOPAR
C
C  Common variables
C
      INTEGER NBPAR,NCPAR,NMOTYP
      COMMON / MPAR1  / NMOTYP,NBPAR,NCPAR
C
C  Common variables
C
      DOUBLE PRECISION APAR,BBPAR(4),BPAR(4)
      DOUBLE PRECISION CCPAR(4),CPAR(4)
      COMMON / MPAR2  / APAR,BPAR,BBPAR,CPAR,CCPAR
C
C  Common variables
C
      DOUBLE PRECISION PARM(4),Z1
      INTEGER NPARM,NUCTYP
      COMMON / NPAR   / PARM,Z1,NUCTYP,NPARM
C
C  Common variables
C
      DOUBLE PRECISION ZZ(MXNP)
      COMMON / NPOT   / ZZ
C
C  Common variables
C
      DOUBLE PRECISION TC(MXNC,MXNC)
      COMMON / NRD00  / TC
C
C  Common variables
C
      INTEGER JPOS(4),MLX(4),MQX(4),NOPEN
      COMMON / NRD01  / MLX,MQX,JPOS,NOPEN
C
C  Common variables
C
      INTEGER LSVT(5,16,4),NTERM(4)
      COMMON / NRD02  / NTERM,LSVT
C
C  Common variables
C
      INTEGER NLX(MXNW),NPX(MXNW),NQX(MXNW,MXNC)
      COMMON / NRD03  / NPX,NLX,NQX
C
C  Common variables
C
      INTEGER IPOS(MXNW),KPOS(4,MXNC)
      INTEGER NPOS(MXNC)
      COMMON / NRD04  / IPOS,NPOS,KPOS
C
C  Common variables
C
      INTEGER JSCUP(8,MXNC)
      COMMON / NRD05  / JSCUP
C
C  Common variables
C
      INTEGER LSV(5,4,MXNC)
      COMMON / NRD06  / LSV
C
C  Common variables
C
      INTEGER JFX(MXNC),KOPEN(MXNC)
      COMMON / NRD08  / JFX,KOPEN
C
C  Common variables
C
      DOUBLE PRECISION ECV(MXNO)
      INTEGER IECC(MXNO),NEC
      COMMON / OFFD   / ECV,IECC,NEC
C
C  Common variables
C
      INTEGER ITC(50)
      COMMON / OPT01  / ITC
C
C  Common variables
C
      INTEGER JTC(20)
      COMMON / OPT02  / JTC
C
C  Common variables
C
      INTEGER KTC(20)
      COMMON / OPT03  / KTC
C
C  Common variables
C
      INTEGER LTC(20)
      COMMON / OPT04  / LTC
C
C  Common variables
C
      CHARACTER*2 NH(MXNW)
      COMMON / ORB00  / NH
C
C  Common variables
C
      DOUBLE PRECISION E(MXNW)
      COMMON / ORB01  / E
C
C  Common variables
C
      DOUBLE PRECISION GAMA(MXNW),XAM(MXNW)
      COMMON / ORB02  / GAMA,XAM
C
C  Common variables
C
      DOUBLE PRECISION CXP(MXNW)
      COMMON / ORB03  / CXP
C
C  Common variables
C
      INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF
      INTEGER NP(MXNW),NW
      COMMON / ORB04  / NW,NCF,NP,NAK,IQ
C
C  Common variables
C
      INTEGER NKJ(MXNW),NKL(MXNW)
      COMMON / ORB05  / NKL,NKJ
C
C  Common variables
C
      INTEGER ICHOP(MXNW,MXNC),IEXC
      INTEGER JCUP(10,MXNC),JQS(3,MXNW,MXNC)
      COMMON / ORB06  / JQS,JCUP,ICHOP,IEXC
C
C  Common variables
C
      INTEGER ISPAR(MXNC),ITJPO(MXNC)
      COMMON / ORB07  / ITJPO,ISPAR
C
C  Common variables
C
      INTEGER IASPAR(MXNC),IATJPO(MXNC)
      COMMON / OSC1   / IATJPO,IASPAR
C
C  Common variables
C
      INTEGER KK,LK
      COMMON / OSC2   / LK,KK
C
C  Common variables
C
      INTEGER LEV(MXNC)
      COMMON / PAT1   / LEV
C
C  Common variables
C
      INTEGER LORDER(MXNC)
      COMMON / PAT2   / LORDER
C
C  Common variables
C
      CHARACTER*14 NRCSF(MXNC)
      COMMON / PATX   / NRCSF
C
C  Common variables
C
      INTEGER MPOIN(MXNW),MPOS(MXNW)
      COMMON / PATY   / MPOIN,MPOS
C
C  Common variables
C
      DOUBLE PRECISION CUTOFF
      COMMON / PATZ   / CUTOFF
C
C  Common variables
C
      DOUBLE PRECISION XTP(MXNP),XTQ(MXNP),YP(MXNP)
      DOUBLE PRECISION YQ(MXNP)
      COMMON / POTE   / YP,YQ,XTP,XTQ
C
C  Common variables
C
      INTEGER NPOTYP
      COMMON / PPAR1  / NPOTYP
C
C  Common variables
C
      DOUBLE PRECISION POLPAR(2)
      COMMON / PPAR2  / POLPAR
C
C  Common variables
C
      INTEGER NUMC,NUMR,NUMSTO
      COMMON / RACAHV / NUMC,NUMR,NUMSTO
C
C  Common variables
C
      INTEGER JCHOP(MXNW,MXNC)
      COMMON / SAVE2  / JCHOP
C
C  Common variables
C
      DOUBLE PRECISION CCR(N10),CHK(N10)
      COMMON / SEMI   / CHK,CCR
C
C  Common variables
C
      DOUBLE PRECISION TA(N11),TB(N11)
      COMMON / TATB   / TA,TB
C
C  Common variables
C
      INTEGER ICD2(3,3,3),ICD3(5,5,6),ICD4(8,8,7)
      INTEGER ICD5(10,10,7),JJDN(10,7,3)
      INTEGER LSDN(10,7,3),NCD2(3),NCD3(6)
      INTEGER NCD4(7),NCD5(7),NDN(7,3)
      COMMON / TCD    / ICD2,NCD2,ICD3,NCD3,ICD4,NCD4,ICD5,NCD5,NDN,JJDN!
     +                  ,LSDN
C
C  Common variables
C
      INTEGER ICP2(2,2),ICP3(3,3)
      COMMON / TCP    / ICP2,ICP3
C
C  Common variables
C
      INTEGER ITAB(16),JTAB(16),NROWS
      INTEGER NTAB(255)
      COMMON / TERMS  / NROWS,ITAB,JTAB,NTAB
C
C  Common variables
C
      CHARACTER*80 IHED
      CHARACTER*20 RECORD
      COMMON / TITL   / IHED,RECORD
C
C  Common variables
C
      DOUBLE PRECISION PF(MXNG),QF(MXNG)
      COMMON / WAVE   / PF,QF
C
C  Common variables
C
      DOUBLE PRECISION WFACT
      COMMON / WFAC   / WFACT
C
C  Common variables
C
      INTEGER ILO(MXNW),IWO(MXNW),NWO
      COMMON / WRO    / NWO,IWO,ILO
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      DATA TIMT1,TIMT2,TIMT3,TIMT4/0.D0,0.D0,0.D0,0.D0/
      DATA TIM1,TIM2,TIM3,TIM4/0.D0,0.D0,0.D0,0.D0/
      DATA EMPTY/' '/
C-----------------------------------------------------------------------
      CALL QUARTZ(-1)
      CALL CALEN(IWRITE,IPUNCH,RECORD)
      CALL DIMSET(IWRITE)
      CALL DIMSET(IPUNCH)
C
      INQUIRE (FILE='GRASP.INP',EXIST=EX)
      IF (.NOT.EX) THEN
        PRINT 3170
        STOP
      ENDIF
      OPEN (UNIT=IREAD,FILE='GRASP.INP',STATUS='OLD',FORM='FORMATTED')
C
      INPUNI = 9
      OPEN (UNIT=INPUNI,STATUS='SCRATCH',FORM='FORMATTED',ACCESS='SEQUEN!
     +TIAL')
      WRITE (IWRITE,3020)
      WRITE (IPUNCH,3020)
   10 CONTINUE
      READ (IREAD,3000,END=30) INPREC
      DO I = 80,1,-1
        IF (INPREC(I).NE.EMPTY) THEN
          LENREC = I
          GOTO 20
        ENDIF
      ENDDO
      LENREC = 1
   20 CONTINUE
      WRITE (INPUNI,3000) (INPREC(I),I=1,LENREC)
      WRITE (IWRITE,3010) (INPREC(I),I=1,LENREC)
      WRITE (IPUNCH,3010) (INPREC(I),I=1,LENREC)
      GOTO 10
   30 CONTINUE
      REWIND INPUNI
      WRITE (IWRITE,3030)
      WRITE (IPUNCH,3030)
      IREAD = INPUNI
C-----------------------------------------------------------------------
      NUMC = 0
      NUMR = 0
      NUMSTO = 0
C-----------------------------------------------------------------------
   40 CONTINUE
      IO1 = -1
      IO2 = -1
      IO3 = -1
      IR1 = -1
      IR2 = -1
      IP2 = -1
      IR3 = -1
      IP3 = -1
      IO4 = -1
      IO5 = -1
      IO6 = -1
      IO7 = -1
      IO8 = -1
      TMCP = .FALSE.
      TMCT = .FALSE.
      TMCDF = .FALSE.
      TBENA = .FALSE.
C
      PRINT 3180
      CALL DATAIN(ISTOP,IO1,IO2,IO3,IR2,IR3,IP3)
C-----------------------------------------------------------------------
C
C   JTC(J) J=10,20  control which programs are called.
C
C   10 - CFOUT called
C   11 - switch set on ANG input record to control calls to all
C        angular packages
C   12 - MCP  called
C   13 - MCDF called
C   14 - MCT  called
C   15 - MCBP called
C   16 - BENA called
C   17 - OSCL called
C
C-----------------------------------------------------------------------
C
C   MCP/MCT/MCBP sections
C
      IF (JTC(12).EQ.1 .OR. JTC(15).EQ.1) THEN
        IF (IO1.GT.0 .OR. IO3.GT.0) THEN
          IF (IO1.GT.0) IO1 = 21
          IF (IO3.GT.0) IO3 = 21
          OPEN (UNIT=21,FILE='MCP.DAT',FORM='UNFORMATTED',STATUS='UNKNOW!
     +N')
          TMCP = .TRUE.
        ENDIF
      ENDIF
C
      IF (JTC(14).EQ.1) THEN
        IF (IO2.GT.0) THEN
          IO2 = 22
          OPEN (UNIT=IO2,FILE='MCT.DAT',FORM='UNFORMATTED',STATUS='UNKNO!
     +WN')
          TMCT = .TRUE.
        ENDIF
      ENDIF
C
      IF (JTC(12).EQ.1 .OR. JTC(15).EQ.1 .OR. JTC(14).EQ.1) THEN
        PRINT 3050
        CALL MCP(IO1,IO2,IO3)
        CALL QUARTZ(0)
        TIM1 = TIME2
        TIMT1 = TIMT1+TIM1
      ENDIF
C-----------------------------------------------------------------------
C
C   MCDF section
C
      IF (JTC(13).EQ.1) THEN
C
        IR1 = 21
        INQUIRE (FILE='MCP.DAT',EXIST=EX)
        IF (.NOT.EX) THEN
          if(ncmin.eq.0)then                !pure SCF run - nrb 25/09/09
            ir1=0
            jtc(13)=0
            jtc(16)=0
            jtc(17)=0
            go to 50
          else
            WRITE (IWRITE,3070)
            WRITE (IPUNCH,3070)
            PRINT 3070
            STOP
          endif
        ENDIF
        IF (TMCP) THEN
          REWIND 21
        ELSE
          OPEN (UNIT=21,FILE='MCP.DAT',FORM='UNFORMATTED',STATUS='UNKNOW!
     +N')
          TMCP = .TRUE.
        ENDIF
C
   50   IF (IR2.GT.0) THEN
          IR2 = 24
          INQUIRE (FILE='MCDF.DMP',EXIST=EX)
          IF (.NOT.EX) THEN
            WRITE (IWRITE,3080)
            WRITE (IPUNCH,3080)
            PRINT 3080
            STOP
          ENDIF
          OPEN (UNIT=IR2,FILE='MCDF.DMP',FORM='UNFORMATTED',STATUS='UNKN!
     +OWN')
        ENDIF
C
        IP2 = 25
        OPEN (UNIT=IP2,FILE='MCDF.DAT',FORM='UNFORMATTED',STATUS='UNKNOW!
     +N')
        TMCDF = .TRUE.
C
        IF (IR3.GT.0) THEN
          IR3 = 26
          INQUIRE (FILE='ORBIN.DAT',EXIST=EX)
          IF (.NOT.EX) THEN
            WRITE (IWRITE,3090)
            WRITE (IPUNCH,3090)
            PRINT 3090
            STOP
          ENDIF
          OPEN (UNIT=IR3,FILE='ORBIN.DAT',FORM='UNFORMATTED',STATUS='UNK!
     +NOWN')
        ENDIF
C
        IF (IP3.GT.0) THEN
          IP3 = 27
          OPEN (UNIT=IP3,FILE='ORBOUT.DAT',FORM='UNFORMATTED',STATUS='UN!
     +KNOWN')
        ENDIF
C
        PRINT 3060
        CALL MCDF(IR1,IR2,IP2,IR3,IP3)
        CALL QUARTZ(0)
        TIM2 = TIME2
        TIMT2 = TIMT2+TIM2
C
      ENDIF
C-----------------------------------------------------------------------
C
C   BENA section
C
      IF (JTC(16).EQ.1) THEN
C
        IO4 = 21
        INQUIRE (FILE='MCP.DAT',EXIST=EX)
        IF (.NOT.EX) THEN
          WRITE (IWRITE,3110)
          WRITE (IPUNCH,3110)
          PRINT 3110
          STOP
        ENDIF
        IF (TMCP) THEN
          REWIND 21
        ELSE
          OPEN (UNIT=21,FILE='MCP.DAT',FORM='UNFORMATTED',STATUS='UNKNOW!
     +N')
          TMCP = .TRUE.
        ENDIF
C
        IO5 = 25
        INQUIRE (FILE='MCDF.DAT',EXIST=EX)
        IF (.NOT.EX) THEN
          WRITE (IWRITE,3120)
          WRITE (IPUNCH,3120)
          PRINT 3120
          STOP
        ENDIF
        IF (TMCDF) THEN
          REWIND 25
        ELSE
          OPEN (UNIT=25,FILE='MCDF.DAT',FORM='UNFORMATTED',STATUS='UNKNO!
     +WN')
          TMCDF = .TRUE.
        ENDIF
C
        IO6 = 30
        OPEN (UNIT=IO6,FILE='BENA.DAT',FORM='UNFORMATTED',STATUS='UNKNOW!
     +N')
        TBENA = .TRUE.
C
        PRINT 3100
        CALL BENA(IO4,IO5,IO6)
        CALL QUARTZ(0)
        TIM3 = TIME2
        TIMT3 = TIMT3+TIM3
C
      ENDIF
C-----------------------------------------------------------------------
C
C   OSCL section
C
      IF (JTC(17).EQ.1) THEN
C
        IO7 = 22
        INQUIRE (FILE='MCT.DAT',EXIST=EX)
        IF (.NOT.EX) THEN
          WRITE (IWRITE,3140)
          WRITE (IPUNCH,3140)
          PRINT 3140
          STOP
        ENDIF
        IF (TMCT) THEN
          REWIND 22
        ELSE
          OPEN (UNIT=22,FILE='MCT.DAT',FORM='UNFORMATTED',STATUS='UNKNOW!
     +N')
          TMCT = .TRUE.
        ENDIF
C
        IO8 = 30
        INQUIRE (FILE='BENA.DAT',EXIST=EX)
        IF (.NOT.EX) THEN
          WRITE (IWRITE,3150)
          WRITE (IPUNCH,3150)
          PRINT 3150
          IO8 = 25
          INQUIRE (FILE='MCDF.DAT',EXIST=EX)
          IF (.NOT.EX) THEN
            WRITE (IWRITE,3160)
            WRITE (IPUNCH,3160)
            PRINT 3160
            STOP
          ENDIF
          IF (TMCDF) THEN
            REWIND 25
          ELSE
            OPEN (UNIT=25,FILE='MCDF.DAT',FORM='UNFORMATTED',STATUS='UNK!
     +NOWN')
            TMCDF = .TRUE.
          ENDIF
        ELSE
          IF (TBENA) THEN
            REWIND 30
          ELSE
            OPEN (UNIT=30,FILE='BENA.DAT',FORM='UNFORMATTED',STATUS='UNK!
     +NOWN')
            TBENA = .TRUE.
          ENDIF
        ENDIF
C
        PRINT 3130
        CALL OSCL(IO7,IO8)
        CALL QUARTZ(0)
        TIM4 = TIME2
        TIMT4 = TIMT4+TIM4
C
      ENDIF
C-----------------------------------------------------------------------
      WRITE (IWRITE,3040)
      WRITE (IWRITE,3210)
C
      IF (TIMT1.GT.EPS10) THEN
        WRITE (IWRITE,3220) TIM1,TIMT1
      ENDIF
C
      IF (TIMT2.GT.EPS10) THEN
        WRITE (IWRITE,3230) TIM2,TIMT2
      ENDIF
C
      IF (TIMT3.GT.EPS10) THEN
        WRITE (IWRITE,3240) TIM3,TIMT3
      ENDIF
C
      IF (TIMT4.GT.EPS10) THEN
        WRITE (IWRITE,3250) TIM4,TIMT4
      ENDIF
C
      IF (NUMC+NUMR.GT.0) THEN
        WRITE (IWRITE,3040)
        WRITE (IWRITE,3200) NUMC,NUMR,NUMC + NUMR,NUMSTO
      ENDIF
C
      IF (IR2.GT.0) CLOSE (24)
      IF (IR3.GT.0) CLOSE (26)
      IF (IP3.GT.0) CLOSE (27)
      IF (TMCP) CLOSE (21)
      IF (TMCT) CLOSE (22)
      IF (TMCDF) CLOSE (25)
      IF (TBENA) CLOSE (30)
C
      WRITE (IWRITE,3040)
C
      IF (ISTOP.EQ.1) THEN
        CALL DIMPRT
        PRINT 3190
      ELSE
        GOTO 40
      ENDIF
C-----------------------------------------------------------------------
 3000 FORMAT (80A1)
 3010 FORMAT (1X,80A1)
 3020 FORMAT (/1X,71('*')/' Input data follows'/1X,71('*'))
 3030 FORMAT (1X,71('*'))
 3040 FORMAT (/1X,71('*'))
 3050 FORMAT (/' calling routine MCP')
 3060 FORMAT (/' calling routine MCDF')
 3070 FORMAT (/' MCP.DAT does not exist : STOPPING (MCDF section)')
 3080 FORMAT (/' MCDF.DMP does not exist : STOPPING (MCDF section)')
 3090 FORMAT (/' ORBIN.DAT does not exist : STOPPING (MCDF section)')
 3100 FORMAT (/' calling routine BENA')
 3110 FORMAT (/' MCP.DAT does not exist : STOPPING (BENA section)')
 3120 FORMAT (/' MCDF.DAT does not exist : STOPPING (BENA section)')
 3130 FORMAT (/' calling routine OSCL')
 3140 FORMAT (/' MCT.DAT does not exist : STOPPING (OSCL section)')
 3150 FORMAT (/' BENA.DAT does not exist : try MCDF.DAT (OSCL section)')
 3160 FORMAT (/' MCDF.DAT does not exist : STOPPING (OSCL section)')
 3170 FORMAT (/' GRASP.INP does not exist : STOPPING')
 3180 FORMAT (/' reading input in routine DATAIN')
 3190 FORMAT (/' STOPPING normally')
 3200 FORMAT (/' Racah coefficients calculated = ',I7/                  !
     +' Racah coefficients from table = ',I7/                           !
     +' Racah coefficients total      = ',I7/                           !
     +' Racah coefficients stored     = ',I7)
 3210 FORMAT (/' calculation time for this problem and total'/)
 3220 FORMAT (' angular coefficients          : ',F10.2,2X,F10.2)
 3230 FORMAT (' MCDF calculation              : ',F10.2,2X,F10.2)
 3240 FORMAT (' BENA calculation              : ',F10.2,2X,F10.2)
 3250 FORMAT (' OSCL calculation              : ',F10.2,2X,F10.2)
      END
C
C                             *******************
C
      SUBROUTINE BENA(IO4,IO5,IO6)
C
C-----------------------------------------------------------------------
C
C  This routine controls the main sequence of routine calls
C  for the calculation of the transverse Breit and QED
C  corrections to the MCDF energy levels.
C
C  Tree of subprogram calls:
C    (no main program found)
C      BENA
C          BREMAT
C              BREMT1
C                  BESSEL
C                  BRRA
C              BREMT2
C                  RS
C              MATOUT
C          COUMAT
C              COUMT1
C                  RINTI
C                  SLATER
C              COUMT2
C                  RS
C              MATOUT
C          DUMPB
C          LOAD
C          QED
C          READA
C          SUMMRY
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  Parameter variables
C
      DOUBLE PRECISION ZERO
      PARAMETER (ZERO=0.D0)
      DOUBLE PRECISION EPS10
      PARAMETER (EPS10=1.D-10)
C
C  Argument variables
C
      INTEGER IO4,IO5,IO6
C
C  Local variables
C
      INTEGER I,IBREIT,ICOUL,J
C
C  Common variables
C
      DOUBLE PRECISION ATW,FACTAN,FACTCM,FACTEV
      DOUBLE PRECISION FACTRY
      COMMON / ATOM   / ATW,FACTRY,FACTCM,FACTEV,FACTAN
C
C  Common variables
C
      DOUBLE PRECISION BREVEC(MXNC,MXNC)
      COMMON / BRET2  / BREVEC
C
C  Common variables
C
      DOUBLE PRECISION BREENG(MXNC),COUENG(MXNC)
      COMMON / ENRG1  / COUENG,BREENG
C
C  Common variables
C
      DOUBLE PRECISION SFENG(MXNC),VPENG(MXNC)
      COMMON / ENRG2  / VPENG,SFENG
C
C  Common variables
C
      INTEGER IPUNCH,IREAD,IWRITE
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
C
C  Common variables
C
      INTEGER KTC(20)
      COMMON / OPT03  / KTC
C
C  Common variables
C
      INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF
      INTEGER NP(MXNW),NW
      COMMON / ORB04  / NW,NCF,NP,NAK,IQ
C
C  Common variables
C
      CHARACTER*80 IHED
      CHARACTER*20 RECORD
      COMMON / TITL   / IHED,RECORD
C
C  Common variables
C
      DOUBLE PRECISION WFACT
      COMMON / WFAC   / WFACT
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
      PRINT 3000,IHED(1:40),IHED(41:80),RECORD
      WRITE (IWRITE,3000) IHED(1:40),IHED(41:80),RECORD
      WRITE (IPUNCH,3000) IHED(1:40),IHED(41:80),RECORD
C
C  Zeroise the energy arrays
C
      DO I = 1,MXNC
        COUENG(I) = ZERO
        BREENG(I) = ZERO
        VPENG(I) = ZERO
        SFENG(I) = ZERO
      ENDDO
C
C  Load dumped wavefunctions
C
      CALL LOAD(IO5)
      REWIND IO5
C
      IF (ABS(ATW).LT.EPS10) THEN
        WRITE (IWRITE,3030) WFACT
      ELSE
        WRITE (IWRITE,3040) WFACT,ATW
      ENDIF
C
C  Check the MCP/MCBP dump.
C
      CALL READA(IO4,ICOUL,IBREIT)
C
C  Evaluate the Coulomb matrix
C
      CALL COUMAT(ICOUL,IO4)
C
C  Write a BENA dump.
C
      CALL DUMPB(IO6)
C
C  Evaluate the Breit matrix
C
      CALL BREMAT(IBREIT,IO4)
C
C  Evaluate vacuum polarization and self energy contributions.
C
      IF (KTC(9).EQ.1) WRITE (IWRITE,3020)
C
      CALL QED
C
C  Obtain final summary of contributions to energy levels.
C
      IF (KTC(10).EQ.0) THEN
        WRITE (IWRITE,3050)
        CALL SUMMRY(IWRITE)
        CALL SUMMRY(IPUNCH)
      ENDIF
C
C  Complete the BENA dump.
C
      IF (IBREIT.EQ.1) THEN
C
        DO I = 1,NCF
          BREENG(I) = COUENG(I)+BREENG(I)
        ENDDO
C
        DO I = 1,NCF
          COUENG(I) = BREENG(I)+VPENG(I)+SFENG(I)
        ENDDO
C
        WRITE (IO6) ((BREVEC(I,J),J=1,NCF),I=1,NCF)
        WRITE (IO6) (BREENG(I),I=1,NCF)
        WRITE (IO6) (COUENG(I),I=1,NCF)
C
      ENDIF
C
      REWIND IO6
      WRITE (IWRITE,3010)
      WRITE (IPUNCH,3010)
C-----------------------------------------------------------------------
 3000 FORMAT (/1X,71('*')/                                              !
     +' routine BENA : calculate Breit and QED corrections'/1X,71('*')/ !
     +' Title  : ',A40/'          ',A40/' Run at : ',A20/1X,71('*'))
 3010 FORMAT (/1X,71('*'))
 3020 FORMAT (/20X,' *****************************************'/20X,    !
     +' *          QED            effects       *'/20X,                 !
     +' *****************************************')
 3030 FORMAT (/' WFACT (factor used to multiply frequency) = ',1P,E10.3/!
     +' atomic weight has been set to infinity')
 3040 FORMAT (/' WFACT (factor used to multiply frequency) = ',1P,E10.3/!
     +' ATW   (atomic weight)                     = ',0P,F10.4)
 3050 FORMAT (/                                                         !
     +' These energies are relative to the groundstate except for the ',!
     +'ground-'/                                                        !
     +' state which is absolute. * indicates a level which may have sw',!
     +'itched '/                                                        !
     +' when Breit is added. The level order is that of the Coulomb en',!
     +'ergies. '/                                                       !
     +' Level assignment, i.e. the J and parity and the dominant CSF a',!
     +'nd mixing '/' coefficient, is based on the Coulomb eigenvectors.'!
     +/                                                                 !
     +' CSF mixing coefficients larger than .1 in magnitude are printe',!
     +'d.')
      END
C
C                             *******************
C
      SUBROUTINE BESSEL(NWLAB,KEEP,IA,IB,IK,IW,K)
C
C-----------------------------------------------------------------------
C
C  This routine evaluates the functions related to the Bessel functions
C  J(K; WAB*R) and N(K; WAB*R) for R=0 to infinity where
C  WAB = ABS( E(IA)-E(IB) )/C and E(I) is the eigenvalue for orbital I.
C  The values of the function at the grid points are loaded into the
C  arrays BESSJ(IK,IW,L) and BESSN(IK,IW,L) L=1,N as requested in the
C  argument list. A note of the contents of these arrays is kept in
C  KEEP(IK,IW) by coding IA,IB and K to a unique integer (symmetric
C  in IA, IB). If a request is made for a fuction that is already
C  stored a simple copy is made of the relevant array.
C
C  The routine uses the equations 10.1.2 and 10.1.3 for small W*R and
C  10.1.8 and 10.1.9 for large W*R of M. Abromawitz and I.A.Stegun to
C  evaluate the fuctions.
C
C  NOTE:  These are not the usual Bessel functions.
C  ----   See the long write up for their definition.
C
C  No subroutines called.
C
C  Common block BESS1:
C    Elements set but never used: WIJ
C  Common block DEF01:
C    Elements used but never set: RNT EPH C N
C    Elements never used, never set: Z H ACCY NW1 NCPRIN
C  Common block INFORM:
C    Elements used but never set: IWRITE
C    Elements never used, never set: IREAD IPUNCH
C  Common block OPT03:
C    Elements used but never set: all
C  Common block ORB00:
C    Elements used but never set: all
C  Common block ORB01:
C    Elements used but never set: all
C  Common block ORB04:
C    Elements used but never set: NP
C    Elements never used, never set: NW NCF NAK IQ
C  Common block WFAC:
C    Elements used but never set: all
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  Parameter variables
C
      DOUBLE PRECISION EPS5
      PARAMETER (EPS5=1.D-5)
      DOUBLE PRECISION ZERO
      PARAMETER (ZERO=0.D0)
      DOUBLE PRECISION HALF
      PARAMETER (HALF=.5D0)
      DOUBLE PRECISION ONE
      PARAMETER (ONE=1.D0)
      DOUBLE PRECISION TWO
      PARAMETER (TWO=2.D0)
C
C  Argument variables
C
      INTEGER IA,IB,IK,IW
      INTEGER K,KEEP(2,2),NWLAB
C
C  Local variables
C
      DOUBLE PRECISION B,CN,DFN,DFNM
      DOUBLE PRECISION S1,S2,SCN,SKEEP
      DOUBLE PRECISION SN,SSN,W,WA
      DOUBLE PRECISION XBESS1,XBESS2
      INTEGER I,ICODE,IEND,IKKP
      INTEGER IPROD,ISWAP,IWKP,J
      INTEGER JCHAN,L,NGRID,NN
C
C  Common variables
C
      DOUBLE PRECISION BESSJ(2,2,MXNP),BESSN(2,2,MXNP)
      DOUBLE PRECISION WIJ(2)
      COMMON / BESS1  / WIJ,BESSJ,BESSN
C
C  Common variables
C
      DOUBLE PRECISION ACCY,C,EPH,H
      DOUBLE PRECISION RNT,Z
      INTEGER N,NCPRIN,NW1
      COMMON / DEF01  / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN
C
C  Common variables
C
      INTEGER IPUNCH,IREAD,IWRITE
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
C
C  Common variables
C
      INTEGER KTC(20)
      COMMON / OPT03  / KTC
C
C  Common variables
C
      CHARACTER*2 NH(MXNW)
      COMMON / ORB00  / NH
C
C  Common variables
C
      DOUBLE PRECISION E(MXNW)
      COMMON / ORB01  / E
C
C  Common variables
C
      INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF
      INTEGER NP(MXNW),NW
      COMMON / ORB04  / NW,NCF,NP,NAK,IQ
C
C  Common variables
C
      DOUBLE PRECISION WFACT
      COMMON / WFAC   / WFACT
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
C
C  Form unique label symm. in IA,IB
C
      ICODE = MAX(IA,IB)+NWLAB*(MIN(IA,IB)+NWLAB*K)
C
C  Check if already stored to save evaluation
C
      IF (ICODE.EQ.KEEP(IK,IW)) RETURN
C
      NGRID = N
      W = WFACT*ABS(E(IA)-E(IB))/C
      WIJ(IW) = W
C
      DO IWKP = 1,2
        DO IKKP = 1,2
          IF (KEEP(IKKP,IWKP).EQ.ICODE) THEN
C
C  Copy function to new position
C
            KEEP(IK,IW) = ICODE
            IF (KTC(11).EQ.1) WRITE (IWRITE,3010) NP(IA),NH(IA),NP(IB),N!
     +H(IB),K,IKKP,IWKP,IK,IW
            DO L = 1,NGRID
              BESSJ(IK,IW,L) = BESSJ(IKKP,IWKP,L)
              BESSN(IK,IW,L) = BESSN(IKKP,IWKP,L)
            ENDDO
            RETURN
C
          ENDIF
C
        ENDDO
      ENDDO
C
C  New calculation
C
      IF (KTC(11).EQ.1) WRITE (IWRITE,3000) NP(IA),NH(IA),NP(IB),NH(IB),!
     +K,IK,IW
C
      KEEP(IK,IW) = ICODE
      NN = K
C
      IF (NN.EQ.0) THEN
        DFNM = ONE
        DFN = ONE
      ELSE
        IEND = NN+NN-1
        IPROD = 1
        DO I = 1,IEND,2
          IPROD = IPROD*I
        ENDDO
        DFNM = DBLE(IPROD)
        DFN = DBLE(IPROD*(NN+NN+1))
      ENDIF
C
C  Use power series for low W*R
C
      WA = -(RNT*W)**2*HALF
C
      DO J = 1,NGRID
        XBESS1 = ONE
        XBESS2 = ONE
        S1 = ZERO
        S2 = ZERO
        DO I = 1,4
          XBESS1 = XBESS1*WA/DBLE(I*(2*(NN+I)+1))
          XBESS2 = XBESS2*WA/DBLE(I*(2*(I-NN)-1))
          S1 = S1+XBESS1
          S2 = S2+XBESS2
          IF (ABS(XBESS1).GE.ABS(S1)*EPS5) GOTO 10
          IF (ABS(XBESS2).GE.ABS(S2)*EPS5) GOTO 10
          GOTO 20
   10     CONTINUE
        ENDDO
        JCHAN = J
        WA = SQRT(-TWO*WA)
        GOTO 30
   20   CONTINUE
        BESSJ(IK,IW,J) = S1
        BESSN(IK,IW,J) = S2
        WA = WA*EPH*EPH
      ENDDO
C
C  If code reaches here then it has calculated the whole
C  array using power series. Hence return
C
      RETURN
C
C
   30 CONTINUE
C
C.....Use SIN/COS expansion when power series takes longer
C.....than 4 terms to converge
C
      ISWAP = 0
      IF (((NN-1)/4)*4- (NN-1)) 50,40,50
C
C.....NN=1,5,9,...
C
   40 CONTINUE
      SSN = -ONE
      SCN = ONE
      ISWAP = 1
      GOTO 100
C
   50 CONTINUE
      IF (((NN-2)/4)*4- (NN-2)) 70,60,70
C
C.....N=2,6,10,....
C
   60 CONTINUE
      SSN = -ONE
      SCN = -ONE
      GOTO 100
C
   70 CONTINUE
      IF (((NN-3)/4)*4- (NN-3)) 90,80,90
C
C.....NN=3,7,11,...
C
   80 CONTINUE
      SSN = ONE
      SCN = -ONE
      ISWAP = 1
      GOTO 100
C
C.....NN=0,4,8,...
C
   90 CONTINUE
      SSN = ONE
      SCN = ONE
C
C-----------------------------------------------------------------------
C
  100 CONTINUE
C
      DO J = JCHAN,NGRID
C
        IF (ISWAP.GT.0) THEN
          SN = SSN*COS(WA)
          CN = SCN*SIN(WA)
        ELSE
          SN = SSN*SIN(WA)
          CN = SCN*COS(WA)
        ENDIF
C
        I = -1
        S1 = ZERO
        S2 = ZERO
C
  110   CONTINUE
        I = I+1
C
        IF (I.GT.NN) GOTO 150
C
        IF (I) 130,120,130
  120   CONTINUE
        B = ONE/WA
        GOTO 140
  130   CONTINUE
        B = B*DBLE((NN+I)*(NN-I+1))/DBLE(2*I)/WA
C
  140   CONTINUE
        S1 = S1+B*SN
        S2 = S2+B*CN
        SKEEP = SN
        SN = CN
        CN = -SKEEP
        GOTO 110
C
  150   CONTINUE
        S1 = S1*DFN/(WA**NN)-ONE
        S2 = S2*(WA**(NN+1))/DFNM-ONE
        BESSJ(IK,IW,J) = S1
        BESSN(IK,IW,J) = S2
        WA = WA*EPH
C
      ENDDO
C
 3000 FORMAT (1X,2(I2,A2,1X),10X,I4,6X,2X,'new',6X,'(',I2,',',I2,')')
 3010 FORMAT (1X,2(I2,A2,1X),10X,I4,6X,2X,'(',I2,',',I2,')',2X,'(',I2,  !
     +',',I2,')')
      END
C
C                             *******************
C
      SUBROUTINE BESSJ(W,L)
C
C-----------------------------------------------------------------------
C
C  This routine evaluates Bessel fuctions J K ( W*R/C ) at the grid
C  points for K=L-1.L.L+1 and stores them in the arrays BJ(1,..),
C  BJ(2,..),BJ(3,..) respectively. It uses a power series expansion
C  for small R and switches to SIN/COS expansion when more than 4 terms
C  in power series are required.
C
C  No subroutines called.
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  Parameter variables
C
      DOUBLE PRECISION EPS5
      PARAMETER (EPS5=1.D-5)
      DOUBLE PRECISION EPS30
      PARAMETER (EPS30=1.D-30)
C
C  Argument variables
C
      DOUBLE PRECISION W
      INTEGER L
C
C  Local variables
C
      DOUBLE PRECISION B,CN,DFN,R
      DOUBLE PRECISION S1,SCN,SKEEP,SN
      DOUBLE PRECISION SSN,WA,XBESS1
      INTEGER I,IEND,IPROD,ISWAP
      INTEGER IW,J,JCHAN,NN
C
C  Common variables
C
      DOUBLE PRECISION BJ(6,MXNP),DUM(2),TC(MXNP)
      DOUBLE PRECISION TD(MXNP)
      COMMON / BESS1  / DUM,BJ,TC,TD
C
C  Common variables
C
      DOUBLE PRECISION HALF,ONE,TEN,TENTH
      DOUBLE PRECISION THREE,TWO,ZERO
      COMMON / CONS   / ZERO,HALF,TENTH,ONE,TWO,THREE,TEN
C
C  Common variables
C
      DOUBLE PRECISION ACCY,C,EPH,H
      DOUBLE PRECISION RNT,Z
      INTEGER N,NCPRIN,NW1
      COMMON / DEF01  / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN
C
C  Common variables
C
      INTEGER LTC(20)
      COMMON / OPT04  / LTC
C
C  Common variables
C
      INTEGER KK,LK
      COMMON / OSC2   / LK,KK
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
      IW = 1
      NN = L-1
      IF (KK.EQ.0) GOTO 10
      IW = 2
      NN = L
C
   10 CONTINUE
      IEND = 2*NN+1
      IPROD = 1
      DO I = 1,IEND,2
        IPROD = IPROD*I
      ENDDO
      DFN = DBLE(IPROD)
C
      R = RNT*W
      JCHAN = N
      DO J = 1,N
C
        S1 = ONE
        IF (LTC(18).EQ.1) GOTO 20
C
        XBESS1 = ONE
        WA = -R*R*HALF
        DO I = 1,4
          XBESS1 = XBESS1*WA/(I*(2*(NN+I)+1))
          S1 = S1+XBESS1
          IF (ABS(XBESS1).LT.ABS(S1)*EPS5) GOTO 20
        ENDDO
        JCHAN = J
        GOTO 30
C
   20   CONTINUE
        IF (ABS(R).LT.EPS30) THEN
          BJ(IW,J) = ZERO
        ELSE
          BJ(IW,J) = S1*(R**NN)/DFN
        ENDIF
C
        R = R*EPH
C
      ENDDO
C-----------------------------------------------------------------------
C
C   use SIN/COS expansion when power series takes longer than 4 terms
C   to converge
C
   30 CONTINUE
      IF (JCHAN.GE.N) GOTO 180
      ISWAP = 0
      IF (((NN-1)/4)*4- (NN-1)) 50,40,50
C
C  NN=1,5,9,..
C
   40 CONTINUE
      SSN = -ONE
      SCN = ONE
      ISWAP = 1
      GOTO 100
C
   50 CONTINUE
      IF (((NN-2)/4)*4- (NN-2)) 70,60,70
C
C  N=2,6,10,..
C
   60 CONTINUE
      SSN = -ONE
      SCN = -ONE
      GOTO 100
C
   70 CONTINUE
      IF (((NN-3)/4)*4- (NN-3)) 90,80,90
C
C  NN=3,7,11,..
C
   80 CONTINUE
      SSN = ONE
      SCN = -ONE
      ISWAP = 1
      GOTO 100
C
C  NN=0,4,8,..
C
   90 CONTINUE
      SSN = ONE
      SCN = ONE
C
  100 CONTINUE
      DO J = JCHAN,N
        IF (ISWAP.GT.0) GOTO 110
        SN = SSN*SIN(R)
        CN = SCN*COS(R)
        GOTO 120
C
  110   CONTINUE
        SN = SSN*COS(R)
        CN = SCN*SIN(R)
C
  120   CONTINUE
        I = -1
        S1 = ZERO
  130   CONTINUE
        I = I+1
        IF (I.GT.NN) GOTO 170
        IF (I) 150,140,150
  140   CONTINUE
        B = ONE/R
        GOTO 160
C
  150   CONTINUE
        B = B*((NN+I)*(NN-I+1))/(2*I)/R
  160   CONTINUE
        S1 = S1+B*SN
        SKEEP = SN
        SN = CN
        CN = -SKEEP
        GOTO 130
C
  170   CONTINUE
        BJ(IW,J) = S1
        R = R*EPH
      ENDDO
C
  180 CONTINUE
      IF (NN.GE.L+1 .OR. KK.EQ.1) RETURN
      NN = NN+1
      IW = IW+1
      GOTO 10
C
      END
C
C                             *******************
C
      BLOCK DATA BLGRSP
C
C-----------------------------------------------------------------------
C
C Sets up tables of quantum numbers of terms which can be
C formed by configurations J**Q. Symmetry of the table for
C particle/hole configurations is used to compress it.
C
C Sets up commonly used constants.
C
C Sets up arrays used in the transformation JJ to LS.
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
C
C  Common variables
C
      DOUBLE PRECISION HALF,ONE,TEN,TENTH
      DOUBLE PRECISION THREE,TWO,ZERO
      COMMON / CONS   / ZERO,HALF,TENTH,ONE,TWO,THREE,TEN
C
C  Common variables
C
      INTEGER IDN(5),IDNL(16,5),IDNS(16,5)
      INTEGER IDNV(16,5)
      COMMON / CSFD   / IDNV,IDNS,IDNL,IDN
C
C  Common variables
C
      INTEGER ICD2(3,3,3),ICD3(5,5,6),ICD4(8,8,7)
      INTEGER ICD5(10,10,7),JJDN(10,7,3)
      INTEGER LSDN(10,7,3),NCD2(3),NCD3(6)
      INTEGER NCD4(7),NCD5(7),NDN(7,3)
      COMMON / TCD    / ICD2,NCD2,ICD3,NCD3,ICD4,NCD4,ICD5,NCD5,NDN,JJDN!
     +                  ,LSDN
C
C  Common variables
C
      INTEGER ICP2(2,2),ICP3(3,3)
      COMMON / TCP    / ICP2,ICP3
C
C  Common variables
C
      INTEGER ITAB(16),JTAB(16),NROWS
      INTEGER NTAB(255)
      COMMON / TERMS  / NROWS,ITAB,JTAB,NTAB
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      DATA NROWS/16/
      DATA ITAB/1,1,1,2,1,3,3,1,4,6,8,1,5,10,18,20/
      DATA JTAB/0,3,6,9,15,18,27,36,39,51,69,93,96,111,141,195/
      DATA NTAB/0,0,1,1,0,2,1,0,4,0,0,1,2,0,5,1,0,6,0,0,1,2,0,5,2,0,9,1,!
     +0,6,3,0,4,3,0,10,1,0,8,0,0,1,2,0,5,2,0,9,2,0,13,1,0,8,3,0,4,3,0,6,!
     +3,0,10,3,0,12,3,0,16,0,0,1,2,0,5,2,0,9,2,0,13,4,0,5,4,0,9,4,0,11,4!
     +,0,17,1,0,10,0,0,1,2,0,5,2,0,9,2,0,13,2,0,17,1,0,10,3,0,4,3,0,6,3,!
     +0,8,3,0,10,3,0,12,3,0,14,3,0,16,3,0,18,3,0,22,0,0,1,2,0,5,2,0,9,2,!
     +0,13,2,0,17,4,0,1,4,0,5,4,0,7,4,0,9,4,1,9,4,0,11,4,0,13,4,1,13,4,0!
     +,15,4,0,17,4,0,19,4,0,21,4,0,25,1,0,10,3,0,4,3,0,6,3,0,8,3,0,10,3,!
     +0,12,3,0,14,3,0,16,3,0,18,3,0,22,5,0,2,5,0,6,5,0,8,5,0,10,5,0,12,5!
     +,0,14,5,0,16,5,0,18,5,0,20,5,0,26/
C
      DATA ZERO,HALF,TENTH/0.0D0,0.5D0,0.1D0/
      DATA ONE,TWO,THREE/1.0D0,2.0D0,3.0D0/
      DATA TEN/10.0D0/
C
      DATA IDN/1,5,8,16,16/
      DATA IDNL/5,15*0,7,3,9,5,1,11*0,7,3,11,9,7,5,5,3,8*0,5,11,9,7,7,5,!
     +3,3,13,9,9,7,5,5,1,1,1,9,7,5,3,13,11,9,9,7,7,5,5,5,3,1/
      DATA IDNS/2,15*0,3,3,1,1,1,11*0,4,4,6*2,8*0,5,7*3,8*1,6,4*4,11*2/
      DATA IDNV/1,15*-1,4*2,0,11*-1,5*3,1,2*3,8*-1,3*4,2,4,4,2,4,4,2,4,4!
     +,2,4,0,4,5,5,3,5,3,5,3,3,5,3,5,1,3,5,3,5/
C
      DATA ICP2/2,1,-1,2/,ICP3/-4,10,4,9,0,9,5,8,-5/
C
      DATA ICD2/4,1,0,-1,4,4*0,-9,32,84,56,63,-6,60,-30,35,-2,0,3,3,0,2,!
     +3*0/,NCD2/5,125,5/
C
      DATA ICD3/-7,-8,3*0,-8,7,18*0,48,-240,168,540,-504,-252,-560,32,-5!
     +60,-96,0,0,1125,0,375,-480,600,105,0,-315,-720,-100,-70,400,210,-3!
     +92,726,-240,3500,-392,-1008,-3024,-210,0,-1008,-980,540,2400,-350,!
     +-980,-2625,0,0,0,2625,245,-960,2400,1400,245,200,-24,56,0,0,5,-135!
     +,-140,0,0,75,121,-84,12*0,-60,55,10,0,0,-11,-48,66,0,0,-54,-22,-49!
     +,12*0,-1,24*0/
      DATA NCD3/15,1500,5250,280,125,1/
C
      DATA ICD4/-48,-42,-420,96,-144,3*0,-400,0,0,50,300,3*0,-56,324,90,!
     +112,-168,3*0,225,0,0,450,75,3*0,-21,-384,240,42,-63,27*0,-36,-21,-!
     +21,-72,4*0,0,75,-75,5*0,-100,0,0,50,4*0,-14,54,54,-28,36*0,420,-42!
     +0,-105,2880,-375,0,-210,-840,-126,-896,0,0,0,3528,-252,448,-504,-2!
     +24,-2016,6,1800,0,252,-448,-1260,-560,315,-240,-1125,0,630,-1120,7!
     +84,-1764,0,0,0,-252,1568,882,-896,126,1134,1944,450,0,448,252,840,!
     +840,0,0,0,1470,1680,-420,-420,420,-1680,180,-1500,0,210,840,-12600!
     +,-1176,336,12600,-336,-2352,0,0,-15,-2835,5760,-2160,12960,-5670,0!
     +,0,0,-19600,3*0,9800,0,0,4725,-49,-8064,8400,8064,-98,0,0,10800,-2!
     +800,1800,1200,-7200,-5600,0,0,1260,2940,13440,5040,840,5880,18*0,4!
     +032,-9240,-504,3960,240,-2016,-1008,0,1232,3360,2464,5760,2640,-61!
     +6,4928,0,2688,3465,-1701,-2640,5760,-1344,-3402,0,5600,0,-2800,0,0!
     +,11200,1400,0,-3584,1155,-2023,7920,480,1792,-4046,0,1400,0,11200,!
     +0,0,2800,-5600,0,-2464,-3780,308,-720,11880,1232,616,9*0,-9,-16,6*!
     +0,16,-9,54*0,3,2,6*0,2,-3,54*0/
      DATA NCD4/750,150,5250,29400,21000,25,5/
C
      DATA ICD5/3,0,-24,-3,6*0,-7,16,0,-7,6*0,-8,-14,0,-8,6*0,12,0,6,-12!
     +,66*0,-60,168,-270,0,24,-60,-168,3*0,300,0,0,-150,0,-300,4*0,-140,!
     +32,280,0,-126,-140,-32,3*0,0,375,4*0,375,3*0,150,105,0,0,-240,150,!
     +-105,3*0,-75,0,0,-600,0,75,4*0,-25,-70,-200,0,-360,-25,70,33*0,-70!
     +56,42336,2940,-70560,0,-1470,-7056,-42336,-2940,-7056,-10584,-1512!
     +9,-29160,-17340,0,-46080,-10584,15129,29160,-10584,13720,12705,-42!
     +00,0,-122500,0,0,12705,-4200,-13720,-19600,-600,30375,36000,0,-270!
     +00,-19600,600,-30375,-19600,35280,-52920,-3675,4*0,-52920,-3675,-3!
     +5280,34300,9450,42000,0,12250,0,0,9450,42000,-34300,6860,25410,-84!
     +00,28350,0,-67200,6860,-25410,8400,6860,30625,5*0,-122500,0,0,3062!
     +5,-8575,-16800,42000,0,-49000,0,0,-16800,42000,8575,17150,-8400,21!
     +000,-31500,0,-42000,17150,8400,-21000,17150,-10952,-5400,-21296,0,!
     +-4800,10952,5400,3*0,21000,-2520,0,-11760,0,21000,-2520,3*0,-12960!
     +,-480,31680,0,240,12960,480,3*0,525,-14175,0,29400,0,525,-14175,3*!
     +0,385,-10395,-280,0,36960,-385,10395,3*0,7875,12705,0,17640,0,7875!
     +,12705,3*0,5103,-13125,5544,0,-16800,-5103,13125,33*0,-125,-500,0,!
     +0,125,5*0,165,0,-60,-360,165,5*0,-144,0,-396,-66,-144,5*0,-66,0,29!
     +4,-324,-66,5*0,250,-250,0,0,-250,55*0,-12,-26,12,7*0,13,-24,-13,7*!
     +0,-25,0,-25,77*0,-1,99*0/
      DATA NCD5/30,750,183750,58800,750,50,1/
C
      DATA NDN/2,5,5,3,3,1,0,5,4,8,6,7,2,2,4,7,10,7,5,3,1/
C
      DATA JJDN/1425,2516,8*0,134,1425,1421,2516,3401,5*0,136,1429,1425,!
     +2516,2116,5*0,1429,1425,2516,7*0,140,1429,2516,7*0,1429,19*0,141,1!
     +434,2525,2121,4101,5*0,1436,1434,2525,3416,6*0,145,1436,1434,2529,!
     +2525,2521,2125,3416,0,0,1440,1436,1434,2529,2525,3416,4*0,149,1440!
     +,1436,2529,2525,2129,3416,3*0,1440,2529,8*0,1440,2529,8*0,1445,253!
     +6,2534,3425,6*0,1445,1441,2536,2534,2134,3425,3421,3*0,156,1449,14!
     +45,2540,2536,2534,2136,3429,3425,4116,1449,1445,2540,2536,2534,342!
     +9,3425,3*0,1449,2540,2536,2140,3429,5*0,1449,2540,3429,7*0,2540,9*!
     +0/
C
      DATA LSDN/343,323,8*0,347,343,125,325,323,5*0,347,343,327,125,325,!
     +5*0,347,329,327,7*0,347,331,329,7*0,331,19*0,455,233,433,11,411,5*!
     +0,455,435,233,433,6*0,455,237,437,435,233,433,215,415,0,0,455,439,!
     +237,437,435,417,4*0,455,441,439,237,437,219,419,3*0,441,439,8*0,44!
     +1,423,8*0,545,343,323,521,6*0,347,545,343,125,325,525,323,3*0,561,!
     +549,347,545,343,327,527,125,325,525,549,347,545,329,529,327,527,3*!
     +0,549,347,331,329,529,5*0,549,533,331,7*0,533,9*0/
C
      END
C
C                             *******************
C
      SUBROUTINE BREID(JA1,IPCA,JB1)
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  External functions
C
      EXTERNAL CLRX,ITRIG
      DOUBLE PRECISION CLRX
      INTEGER ITRIG
C
C  Parameter variables
C
      DOUBLE PRECISION ZERO
      PARAMETER (ZERO=0.D0)
      DOUBLE PRECISION TWO
      PARAMETER (TWO=2.D0)
      INTEGER NPLX
      PARAMETER (NPLX=14)
      INTEGER IDIM
      PARAMETER (IDIM=20)
C
C  Argument variables
C
      INTEGER IPCA,JA1,JB1
C
C  Local variables
C
      DOUBLE PRECISION COEF,CONE(7,IDIM),CONST
      DOUBLE PRECISION GAM,PROC,PROD,S(12)
      INTEGER I,IA1,IB1,IBRD
      INTEGER IBRE,ID1,ID2,IP
      INTEGER IPP,ISG,ITYPE,JS(4)
      INTEGER K,KAP1,KAPS(4),KK
      INTEGER KS(4),MU,N,NE1
      INTEGER NE2,NQS1,NQS2,NU
      INTEGER NUP1
C
C  Common variables
C
      INTEGER IME,JA,JB,NWA
      COMMON / ANG04  / IME,JA,JB,NWA
C
C  Common variables
C
      INTEGER ICORE(MXNW)
      COMMON / ANG05  / ICORE
C
C  Common variables
C
      INTEGER NQ1(MXNW),NQ2(MXNW)
      COMMON / ANG11  / NQ1,NQ2
C
C  Common variables
C
      INTEGER JLIST(NPLX),KLIST(MXNW),NCORE,NPEEL
      COMMON / ANG13  / JLIST,KLIST,NPEEL,NCORE
C
C  Common variables
C
      INTEGER IBUG1,IBUG2,IBUG3,IBUG4
      INTEGER IBUG5,IBUG6
      COMMON / DEBUG  / IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6
C
C  Common variables
C
      INTEGER IPUNCH,IREAD,IWRITE
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
C
C  Common variables
C
      INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF
      INTEGER NP(MXNW),NW
      COMMON / ORB04  / NW,NCF,NP,NAK,IQ
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
      IF (IPCA.EQ.2) THEN
        IA1 = KLIST(JA1)
      ELSE
        IA1 = JLIST(JA1)
      ENDIF
      IB1 = KLIST(JB1)
C-----------------------------------------------------------------------
      ISG = 1
C-----------------------------------------------------------------------
      IF (JA.NE.JB) GOTO 10
      IF (ICORE(IA1).EQ.0 .OR. ICORE(IB1).EQ.0) GOTO 10
C-----------------------------------------------------------------------
      IF (JA.GT.1) RETURN
      ISG = -1
C-----------------------------------------------------------------------
   10 CONTINUE
      JS(1) = IA1
      JS(2) = IB1
      JS(3) = IA1
      JS(4) = IB1
      NQS1 = NQ1(IA1)
      NQS2 = NQ2(IB1)
      DO I = 1,4
        KAPS(I) = 2*NAK(JS(I))
        KS(I) = ABS(KAPS(I))
      ENDDO
C-----------------------------------------------------------------------
      CONST = NQS1*NQS2
C-----------------------------------------------------------------------
      IF (IBUG2.EQ.1) WRITE (IWRITE,3000) IA1,IB1
C-----------------------------------------------------------------------
      CALL SNRC(JS,KAPS,KS,ID1,ID2,NE1,NE2,IBRD,IBRE)
C-----------------------------------------------------------------------
      IF (IBUG2.EQ.1) WRITE (IWRITE,3010) ID1,ID2,NE1,NE2,IBRD,IBRE
C-----------------------------------------------------------------------
      IF (IA1.EQ.IB1) THEN
        DO N = 1,ID2
          NU = ID1+2*(N-1)
          K = NU
          IF (MOD(K,2).NE.1) RETURN
          KAP1 = KAPS(1)/2
          GAM = CLRX(KAP1,NU,KAP1)
          COEF = CONST*TWO*(KS(1)*KS(1))*GAM*GAM/(NU*(NU+1))
          IF (IBUG2.GT.0) WRITE (IWRITE,3020) NU,GAM,COEF
          ITYPE = ISG*4
          CALL SPEAKG(0,ITYPE,IA1,IA1,IA1,IA1,NU,COEF)
        ENDDO
        RETURN
C
      ENDIF
C-----------------------------------------------------------------------
      IF (IBRE.LT.0) RETURN
C-----------------------------------------------------------------------
      IF (NE2.GT.IDIM) THEN
        WRITE (IWRITE,3030)
        WRITE (IPUNCH,3030)
        STOP
C
      ENDIF
C-----------------------------------------------------------------------
      DO N = 1,NE2
        DO MU = 1,7
          CONE(MU,N) = ZERO
        ENDDO
      ENDDO
C-----------------------------------------------------------------------
      PROC = -CONST/(KS(1)*KS(2))
C
      DO N = 1,NE2
        NU = NE1+2*(N-1)
C
        K = NU
        IP = (KS(1)-KS(2))/2+K
        IPP = IP+1
        IF (NU.EQ.0) GOTO 30
C
        KK = K+K+1
        IF (ITRIG(KS(1),KS(2),KK).EQ.0) GOTO 20
C
        PROD = PROC
        IF (MOD(IP,2).NE.0) PROD = -PROD
        CALL CXK(S,JS,KAPS,NU,K,IBRE,2)
        IF (IBUG2.GT.0) WRITE (IWRITE,3040) PROD, (S(MU),MU=1,3)
        DO MU = 1,3
          CONE(MU,N) = CONE(MU,N)+PROD*S(MU)
        ENDDO
C
   20   CONTINUE
        K = NU-1
        KK = K+K+1
        IF (ITRIG(KS(1),KS(2),KK).EQ.0) GOTO 30
C
        PROD = PROC
        IF (MOD(IPP,2).NE.0) PROD = -PROD
        CALL CXK(S,JS,KAPS,NU,K,IBRE,2)
        IF (IBUG2.GT.0) WRITE (IWRITE,3040) PROD, (S(MU),MU=1,3)
        DO MU = 1,3
          CONE(MU,N) = CONE(MU,N)+PROD*S(MU)
        ENDDO
C
   30   CONTINUE
        IF (N.NE.NE2) THEN
          K = NU+1
          KK = K+K+1
          PROD = PROC
          IF (MOD(IPP,2).NE.0) PROD = -PROD
          CALL CXK(S,JS,KAPS,NU,K,IBRE,2)
          IF (IBUG2.GT.0) WRITE (IWRITE,3040) PROD, (S(MU),MU=1,7)
          DO MU = 1,7
            CONE(MU,N) = CONE(MU,N)+PROD*S(MU)
          ENDDO
        ENDIF
C
      ENDDO
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
      DO N = 1,NE2
        NU = NE1+2*(N-1)
        ITYPE = ISG*5
        CALL SPEAKG(0,ITYPE,IB1,IA1,IB1,IA1,NU,CONE(1,N))
        CALL SPEAKG(0,ITYPE,IA1,IB1,IB1,IA1,NU,CONE(2,N))
        CALL SPEAKG(0,ITYPE,IA1,IB1,IA1,IB1,NU,CONE(3,N))
        IF (N.EQ.NE2) GOTO 40
        NUP1 = NU+1
        ITYPE = ISG*6
        CALL SPEAKG(0,ITYPE,IA1,IB1,IA1,IB1,NUP1,CONE(4,N))
        CALL SPEAKG(0,ITYPE,IB1,IA1,IB1,IA1,NUP1,CONE(5,N))
        CALL SPEAKG(0,ITYPE,IA1,IB1,IB1,IA1,NUP1,CONE(6,N))
        CALL SPEAKG(0,ITYPE,IB1,IA1,IA1,IB1,NUP1,CONE(7,N))
   40   CONTINUE
      ENDDO
C-----------------------------------------------------------------------
 3000 FORMAT (' BREID called : orbitals = ',2I4)
 3010 FORMAT (' BREID called : ID1 ID2 NE1 NE2 IBRD IBRE = ',6I5)
 3020 FORMAT (' AAAA contribution : NU,GAM,COEF = ',I5,1P,2E13.5)
 3030 FORMAT (/' BREID called : dimension ERROR for IDIM')
 3040 FORMAT (' BREID called : PROD = ',1P,E12.4/                       !
     +' BREID called :    S = ',4E12.4/' BREID called :    S = ',3E12.4)
      END
C
C                             *******************
C
      SUBROUTINE BREMAT(IBREIT,IO4)
C
C-----------------------------------------------------------------------
C
C  This routine controls the calculation of the Breit matrix.
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  Argument variables
C
      INTEGER IBREIT,IO4
C
C  Local variables
C
      DOUBLE PRECISION AM,EAU,ERY
      INTEGER I,IJ,IP,J
C
C  Common variables
C
      DOUBLE PRECISION BREVEC(MXNC,MXNC)
      COMMON / BRET2  / BREVEC
C
C  Common variables
C
      DOUBLE PRECISION ACCY,C,EPH,H
      DOUBLE PRECISION RNT,Z
      INTEGER N,NCPRIN,NW1
      COMMON / DEF01  / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN
C
C  Common variables
C
      DOUBLE PRECISION BREENG(MXNC),COUENG(MXNC)
      COMMON / ENRG1  / COUENG,BREENG
C
C  Common variables
C
      INTEGER IPUNCH,IREAD,IWRITE
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
C
C  Common variables
C
      INTEGER KTC(20)
      COMMON / OPT03  / KTC
C
C  Common variables
C
      INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF
      INTEGER NP(MXNW),NW
      COMMON / ORB04  / NW,NCF,NP,NAK,IQ
C
C  Common variables
C
      INTEGER ISPAR(MXNC),ITJPO(MXNC)
      COMMON / ORB07  / ITJPO,ISPAR
C
C  Common variables
C
      INTEGER LEV(MXNC)
      COMMON / PAT1   / LEV
C
C  Common variables
C
      INTEGER LORDER(MXNC)
      COMMON / PAT2   / LORDER
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
      IF (IBREIT.EQ.0) RETURN
C
      WRITE (IWRITE,3010)
      PRINT 3010
C
C  Evaluate the Breit matrix
C
      CALL BREMT1(IO4)
C
      IF ((KTC(4)+KTC(5)+KTC(6)).GT.0) WRITE (IWRITE,3000)
C-----------------------------------------------------------------------
C
C  Print Breit matrix if option 4 is set.
C
      IF (KTC(4).EQ.1) CALL MATOUT(IWRITE,BREVEC,NCF,NCF,MXNC,MXNC,1)
C-----------------------------------------------------------------------
C
C  Diagonalise the Breit matrix
C
      CALL BREMT2
C-----------------------------------------------------------------------
C
C  Print Breit energies if option 5 is set.
C
      IF (KTC(5).EQ.1) THEN
        WRITE (IWRITE,3020)
        DO J = 1,NCPRIN
          EAU = BREENG(J)+COUENG(J)
          IF (J.GT.1) EAU = EAU - (BREENG(1) + COUENG(1))
          ERY = EAU+EAU
          I = LEV(J)
          IJ = ITJPO(I)-1
          IP = ISPAR(I)
          AM = BREVEC(I,J)
C
          IF (MOD(IJ,2).EQ.0) THEN
            IJ = IJ/2
            IF (IP.EQ.1) THEN
              IF (LORDER(J).EQ.0) THEN
                WRITE (IWRITE,3090) J,IJ,I,AM,EAU,ERY
              ELSE
                WRITE (IWRITE,3100) J,IJ,I,AM,EAU,ERY
              ENDIF
            ELSE
              IF (LORDER(J).EQ.0) THEN
                WRITE (IWRITE,3070) J,IJ,I,AM,EAU,ERY
              ELSE
                WRITE (IWRITE,3080) J,IJ,I,AM,EAU,ERY
              ENDIF
            ENDIF
          ELSE
            IF (IP.EQ.1) THEN
              IF (LORDER(J).EQ.0) THEN
                WRITE (IWRITE,3050) J,IJ,I,AM,EAU,ERY
              ELSE
                WRITE (IWRITE,3060) J,IJ,I,AM,EAU,ERY
              ENDIF
            ELSE
              IF (LORDER(J).EQ.0) THEN
                WRITE (IWRITE,3030) J,IJ,I,AM,EAU,ERY
              ELSE
                WRITE (IWRITE,3040) J,IJ,I,AM,EAU,ERY
              ENDIF
            ENDIF
          ENDIF
C
        ENDDO
      ENDIF
C-----------------------------------------------------------------------
C
C  Print Breit vectors if option 6 is set.
C
      IF (KTC(6).GT.0) CALL MATOUT(IWRITE,BREVEC,NCF,NCPRIN,MXNC,MXNC,3)
C-----------------------------------------------------------------------
 3000 FORMAT (/20X,' *****************************************'/20X,    !
     +' *         Breit           matrix        *'/20X,                 !
     +' *****************************************')
 3010 FORMAT (/' >>>> routine BREMAT called')
 3020 FORMAT (/' Breit              dominant'/                          !
     +' level  J   parity  CSF   mix           a.u.                Ryd.'!
     +/)
 3030 FORMAT (1X,I4,2X,I4,'/2 odd     ',I4,2X,F5.3,3X,1P,2E20.8)
 3040 FORMAT (1X,I4,2X,I4,'/2 odd  ** ',I4,2X,F5.3,3X,1P,2E20.8)
 3050 FORMAT (1X,I4,2X,I4,'/2 even    ',I4,2X,F5.3,3X,1P,2E20.8)
 3060 FORMAT (1X,I4,2X,I4,'/2 even ** ',I4,2X,F5.3,3X,1P,2E20.8)
 3070 FORMAT (1X,I4,2X,I4,'   odd     ',I4,2X,F5.3,3X,1P,2E20.8)
 3080 FORMAT (1X,I4,2X,I4,'   odd  ** ',I4,2X,F5.3,3X,1P,2E20.8)
 3090 FORMAT (1X,I4,2X,I4,'   even    ',I4,2X,F5.3,3X,1P,2E20.8)
 3100 FORMAT (1X,I4,2X,I4,'   even ** ',I4,2X,F5.3,3X,1P,2E20.8)
      END
C
C                             *******************
C
      SUBROUTINE BREMT1(IO4)
C
C-----------------------------------------------------------------------
C
C  Routine for evaluating the Breit matrix.
C
C  IO4 - stream for MCBP coefficients.
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  External functions
C
      EXTERNAL BRRA
      DOUBLE PRECISION BRRA
C
C  Parameter variables
C
      DOUBLE PRECISION EPS10
      PARAMETER (EPS10=1.D-10)
      DOUBLE PRECISION ZERO
      PARAMETER (ZERO=0.D0)
C
C  Argument variables
C
      INTEGER IO4
C
C  Local variables
C
      CHARACTER IBL,ILAB,IST
      DOUBLE PRECISION COEF,CONTR,ELMNT,ELSTO
      DOUBLE PRECISION XINT,XLAB
      INTEGER I,IA,IB,IC
      INTEGER ICOD,ICOD1,ICOD2,ICOD3
      INTEGER ICOD4,ID,IPRNT,ISTOR
      INTEGER ISTORE,ITYP,ITYPE,J
      INTEGER JA,JAP,JB,JBP
      INTEGER K,KEEP(2,2),NCFP,NSTART
      INTEGER NUM,NUMEL,NUMINT,NUMSTO
      INTEGER NUMTOT,NUMX,NWA,NWP
      INTEGER NWS
C
C  Common variables
C
      DOUBLE PRECISION BREVEC(MXNC,MXNC)
      COMMON / BRET2  / BREVEC
C
C  Common variables
C
      INTEGER IPUNCH,IREAD,IWRITE
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
C
C  Common variables
C
      INTEGER KTC(20)
      COMMON / OPT03  / KTC
C
C  Common variables
C
      CHARACTER*2 NH(MXNW)
      COMMON / ORB00  / NH
C
C  Common variables
C
      INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF
      INTEGER NP(MXNW),NW
      COMMON / ORB04  / NW,NCF,NP,NAK,IQ
C
C  Common variables
C
      INTEGER MPOIN(MXNW),MPOS(MXNW)
      COMMON / PATY   / MPOIN,MPOS
C
C  Common variables
C
      DOUBLE PRECISION PF(MXNG),QF(MXNG)
      COMMON / WAVE   / PF,QF
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      DATA IBL,IST/' ','S'/
C-----------------------------------------------------------------------
C
C  Zeroise the KEEP array
C
      DO I = 1,2
        DO J = 1,2
          KEEP(I,J) = 0
        ENDDO
      ENDDO
C
      NSTART = MPOIN(NW)+MPOS(NW)-1
      NUMX = MXNG-NSTART
C
      NUMINT = 0
      NUMSTO = 0
      NUMTOT = 0
      NUMEL = 0
C
      ELSTO = ZERO
C
      IPRNT = 0
      IF (KTC(8).EQ.1) IPRNT = IPRNT + 1
      IF (KTC(11).EQ.1) IPRNT = IPRNT + 2
C-----------------------------------------------------------------------
C
C  Position stream IO4 which reads in MCBP coefficients.
C
      REWIND IO4
      READ (IO4)
      READ (IO4) NCFP,NWP
      NWA = NWP+1
      NWS = NWA*NWA
      DO I = 1,7
        READ (IO4)
      ENDDO
C-----------------------------------------------------------------------
      DO JA = 1,NCF
        DO JB = JA,NCF
C
C  Read coefficients for configuration pair JA,JB.
C
          ELMNT = ZERO
          READ (IO4) JAP,JBP
          NUM = 0
C
C  Coefficients stored as : ISTORE,ITYP,COEF
C  Need to decode ISTORE.
C
   10     CONTINUE
          READ (IO4) ISTORE,ITYP,COEF
          IF (ISTORE.EQ.0) GOTO 100
          ITYPE = ABS(ITYP)
          IF (ITYPE.GT.6) GOTO 10
C
          ISTOR = ISTORE
          ID = MOD(ISTOR,NWA)
          ISTOR = ISTOR/NWA
          IC = MOD(ISTOR,NWA)
          ISTOR = ISTOR/NWA
          IB = MOD(ISTOR,NWA)
          ISTOR = ISTOR/NWA
          IA = MOD(ISTOR,NWA)
          K = ISTOR/NWA
C
          IF (NUM.GT.0 .OR. IPRNT.EQ.0) GOTO 20
          IF (IPRNT.EQ.1) WRITE (IWRITE,3010) JA,JB
          IF (IPRNT.EQ.2) WRITE (IWRITE,3040)
          IF (IPRNT.EQ.3) WRITE (IWRITE,3050) JA,JB
C
C  Check if the radial integral has been stored.
C
   20     CONTINUE
          NUM = NUM+1
C
          XLAB = ISTORE*10+ITYPE
          IF (NUMSTO.GT.0) THEN
            DO I = NSTART+1,NSTART+NUMSTO
              IF (ABS(XLAB-PF(I)).LT.EPS10) THEN
                XINT = QF(I)
                ILAB = IST
                GOTO 90
              ENDIF
            ENDDO
          ENDIF
C
C  Evaluate Bessel functions in this section.
C
          ILAB = IBL
          GOTO (30,60,50,80,40,70),ITYPE
C
C  Type 1 and 5 integrals require J(K),N(K) Bessel fuctions.
C  Type 5 integrals only require W=WAB Bessel functions.
C
   30     CONTINUE
          IF (IA.EQ.IC .AND. IB.EQ.ID) GOTO 40
          IF (IA.EQ.ID .AND. IC.EQ.IB) GOTO 40
          CALL BESSEL(NWA,KEEP,IC,ID,1,2,K)
   40     CONTINUE
          CALL BESSEL(NWA,KEEP,IA,IB,1,1,K)
          GOTO 80
C
C  TYPE 3 integrals require J(K),N(K) Bessel functions for either
C  W=WAB or W=CD whichever is non-zero.
C
   50     CONTINUE
          IF (IA.NE.IB) CALL BESSEL(NWA,KEEP,IA,IB,1,1,K)
          IF (IC.NE.ID) CALL BESSEL(NWA,KEEP,IC,ID,1,2,K)
          GOTO 80
C
C  Type 2 and 6 integrals require J(K),N(K) and J(K+2),N(K+2)
C  Bessel fuctions
C  Type 6 integrals only require W=WAB Bessel functions.
C
   60     CONTINUE
          IF (IA.EQ.IC .AND. IB.EQ.ID) GOTO 70
          IF (IA.EQ.ID .AND. IC.EQ.IB) GOTO 70
C
          ICOD = MAX(IC,ID)+NWA*MIN(IC,ID)
          ICOD1 = ICOD+NWS*(K-1)
          ICOD2 = ICOD+NWS*(K+1)
          ICOD = MAX(IA,IB)+NWA*MIN(IA,IB)
          ICOD3 = ICOD+NWS*(K-1)
          ICOD4 = ICOD+NWS*(K+1)
          IF (ICOD1.EQ.KEEP(1,2) .AND. ICOD2.EQ.KEEP(2,2) .AND.ICOD3.EQ.!
     +KEEP(1,1) .AND. ICOD4.EQ.KEEP(2,1)) GOTO 80
          IF (ICOD1.EQ.KEEP(1,1) .AND. ICOD2.EQ.KEEP(2,1) .AND.ICOD3.EQ.!
     +KEEP(1,2) .AND. ICOD4.EQ.KEEP(2,2)) GOTO 80
C
          CALL BESSEL(NWA,KEEP,IC,ID,1,2,K-1)
          CALL BESSEL(NWA,KEEP,IC,ID,2,2,K+1)
   70     CONTINUE
          CALL BESSEL(NWA,KEEP,IA,IB,1,1,K-1)
          CALL BESSEL(NWA,KEEP,IA,IB,2,1,K+1)
C
C  Multiply coefficient by integral.
C
   80     CONTINUE
          XINT = BRRA(ITYPE,IA,IB,IC,ID,K)
C
C  Store radial integral.
C
          NUMINT = NUMINT+1
          IF (NUMSTO.LT.NUMX) THEN
            NUMSTO = NUMSTO+1
            PF(NSTART+NUMSTO) = XLAB
            QF(NSTART+NUMSTO) = XINT
          ENDIF
C
   90     CONTINUE
          CONTR = COEF*XINT
          ELMNT = ELMNT+CONTR
C
C  Sum core contributions.
C
          IF (ITYP.LT.0) THEN
            ELSTO = ELSTO+CONTR
            NUMEL = NUMEL+1
          ENDIF
C
C  Write out contributions if requested - option 8 set.
C
          IF (KTC(8).EQ.1) WRITE (IWRITE,3020) NP(IA),NH(IA),NP(IB),NH(I!
     +B),NP(IC),NH(IC),NP(ID),NH(ID),K,ITYP,COEF,XINT,CONTR,ILAB
          GOTO 10
C
C  Store total in BREVEC array.
C  Write out total if requested - option 8 set.
C
  100     CONTINUE
          NUMTOT = NUMTOT+NUM
C
          IF (NUM.GT.0 .AND. KTC(8).EQ.1) WRITE (IWRITE,3030) ELMNT
C
          BREVEC(JA,JB) = ELMNT
          BREVEC(JB,JA) = ELMNT                    !for new BREMT2 - nrb
C
C  Add in core contribution if applicable.
C  Write out contribution if option 8 is set.
C
          IF (JA.EQ.JB .AND. JA.GT.1 .AND. NUMEL.GT.0) THEN
            BREVEC(JA,JA) = BREVEC(JA,JA)+ELSTO
            IF (KTC(8).EQ.1) THEN
              WRITE (IWRITE,3060) ELSTO
              WRITE (IWRITE,3030) BREVEC(JA,JA)
            ENDIF
          ENDIF
C
          IF (JA.EQ.JB) PRINT 3000,JA,JA,ELSTO,BREVEC(JA,JA)
C
        ENDDO
      ENDDO
C-----------------------------------------------------------------------
      REWIND IO4
C-----------------------------------------------------------------------
      WRITE (IWRITE,3070) NUMTOT
      WRITE (IWRITE,3080) NUMEL
      WRITE (IWRITE,3090) NUMINT
      WRITE (IWRITE,3100) NUMSTO
      PRINT 3070,NUMTOT
      PRINT 3080,NUMEL
      PRINT 3090,NUMINT
      PRINT 3100,NUMSTO
C-----------------------------------------------------------------------
 3000 FORMAT (' BREMT1 : ',2I5,1P,2E12.4)
 3010 FORMAT (/' contributions to matrix element (',I2,',',I2,')'//     !
     +'   A    B    C    D    K  ITYPE  coeff.           integral     ',!
     +'   contribution'/)
 3020 FORMAT (1X,4(I2,A2,1X),I4,2X,I4,1X,1P,3E16.8,1X,A1)
 3030 FORMAT (1X,62X,'---------------'/1X,62X,1P,E15.8)
 3040 FORMAT (/' Bessel functions evaluated'//                          !
     +'   A    B              K        source  destination'/)
 3050 FORMAT (/' contribution to matrix element (',I2,',',I2,')'/       !
     +' Bessel functions evaluated'//                                   !
     +'   A    B    C    D    K  ITYPE  coeff.           integral     ',!
     +'   contribution'/                                                !
     +'   A    B              K        source  destination'/)
 3060 FORMAT (1X,'core contribution = ',48X,1P,E15.8)
 3070 FORMAT (/1X,I5,' MCBP (Breit) angular coefficients read')
 3080 FORMAT (1X,I5,' core (Breit) angular coefficients read')
 3090 FORMAT (/1X,I5,' radial integrals evaluated')
 3100 FORMAT (1X,I5,' radial integrals stored')
      END
C
C                             *******************
C
      SUBROUTINE BREMT2
C
C-----------------------------------------------------------------------
C
C  This subroutine forms the first-order Coulomb + Breit Hamiltonian  
C  matrix and diagonalises it. It then orders the eigenvalues and 
C  eigenvectors so they are compatible with the zero-order matrix's.
C
C  Subroutine called: DSYEV
C
C  Diagonalisation is now by Jp - nrb 17/09/08
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  Parameter variables
C
      DOUBLE PRECISION EPS10
      PARAMETER (EPS10=1.D-10)
      DOUBLE PRECISION ZERO
      PARAMETER (ZERO=0.D0)
      INTEGER LWORK
      PARAMETER (LWORK=MXNC*3-1)
C
C  Local variables
C
      DOUBLE PRECISION A,AMAX,AOVLAP(MXNC),EAV,am,eau
      DOUBLE PRECISION WORK(LWORK),XXX
      INTEGER I,IMAX,INFO
      INTEGER IORDER(MXNC),J,L
      INTEGER MAX
      integer ij,ip,itr,jtr,k
      LOGICAL LSWAP
C
C  Common variables
C
      DOUBLE PRECISION COUVEC(MXNC,MXNC)
      COMMON / BRET1  / COUVEC
C
C  Common variables
C
      DOUBLE PRECISION BREVEC(MXNC,MXNC)
      COMMON / BRET2  / BREVEC
C
C  Common variables
C
      DOUBLE PRECISION ACCY,C,EPH,H
      DOUBLE PRECISION RNT,Z
      INTEGER N,NCPRIN,NW1
      COMMON / DEF01  / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN
C
C  Common variables
C
      DOUBLE PRECISION BREENG(MXNC),COUENG(MXNC)
      COMMON / ENRG1  / COUENG,BREENG
C
C  Common variables
C
      DOUBLE PRECISION SFENG(MXNC),VPENG(MXNC)
      COMMON / ENRG2  / VPENG,SFENG
C
C  Common variables
C
      INTEGER IPUNCH,IREAD,IWRITE
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
C
C  Common variables
C
      INTEGER ITC(50)
      COMMON / OPT01  / ITC
C
C  Common variables
C
      INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF
      INTEGER NP(MXNW),NW
      COMMON / ORB04  / NW,NCF,NP,NAK,IQ
C
C  Common variables
C
      INTEGER ISPAR(MXNC),ITJPO(MXNC)
      COMMON / ORB07  / ITJPO,ISPAR
C
C  Common variables
C
      INTEGER LORDER(MXNC)
      COMMON / PAT2   / LORDER
C
C  Common variables
C
      double precision tmpvec(mxnc,mxnc)
      double precision tmpeng(mxnc),ee,t
      integer itmp(mxnc),jtmp(mxnc),ncf0,nsym
      common /nrbtmp/ tmpvec,tmpeng,ee,t
     x               ,itmp,jtmp,ncf0,nsym
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
      LSWAP = .FALSE.
      WRITE (IWRITE,3000)
C
C  add zero-order and Breit matrix - upper triangle only
C
      DO I = 1,NCF
        DO J = I,NCF
          XXX = ZERO
          DO L = 1,NCF
            XXX = XXX+COUVEC(I,L)*COUVEC(J,L)*COUENG(L)
          ENDDO
          IF (ABS(XXX).LT.EPS10) XXX = ZERO
          BREVEC(I,J) = BREVEC(I,J)+XXX
        ENDDO
      ENDDO
C
C  ----- Hamiltonian evaluated -----
C
C  Print Hamiltonian matrix if option 5 is set
C
      IF (ITC(5).EQ.1) THEN
        WRITE (IWRITE,3070)
        CALL MATOUT(IWRITE,BREVEC,NCF,NCF,MXNC,MXNC,1)
      ENDIF
C
C  calculate the average energy and subtract from diagonal
C
      EAV = ZERO
      DO I = 1,NCF
        EAV = EAV+BREVEC(I,I)
      ENDDO
      EAV = EAV/DBLE(NCF)
      WRITE (IWRITE,3060) EAV
      PRINT 3060,EAV
      DO I = 1,NCF
        BREVEC(I,I) = BREVEC(I,I)-EAV
      ENDDO
C
C-----------------------------------------------------------------------
C
C  Diagonalise the Hamiltonian by Jp sub-block (nrb)
C
C-----------------------------------------------------------------------
c
      WRITE (IWRITE,3030)
c
c  Initialize
c
      nsym=0
      do itr=1,ncf
        itmp(itr)=0
      enddo
c
c  First, find a symmetry
c
  40  ncf0=0
      do itr=1,ncf
        if(itmp(itr).eq.0)then                       !we have a new one
          nsym=nsym+1
          do jtr=1,ncf                               !find all
            if(itjpo(itr).eq.itjpo(jtr).and.
     x         ispar(itr).eq.ispar(jtr))then
              ncf0=ncf0+1
              jtmp(ncf0)=jtr
              itmp(jtr)=nsym
            endif
          enddo
          go to 50                                   !go diagonalize
        endif
      enddo
c
      go to 60                                       !we are done
c        
  50  do j=1,ncf0                                    !transfer Jp block
        jtr=jtmp(j)
        do i=1,j
          itr=jtmp(i)
          tmpvec(i,j)=brevec(itr,jtr)
        enddo
      enddo
C
C  use a LAPACK routine
C
      ij=itjpo(jtmp(1))-1
      ip=ispar(jtmp(1))
c
      write(iwrite,*)'Diagonalizing symmetry:',nsym,' 2J=',ij,' P=',ip
c
      CALL DSYEV ('V','U',ncf0,tmpvec,MXNC,tmpeng,WORK,LWORK,INFO)
c
      IF (INFO.NE.0) THEN
        WRITE (IWRITE,3010)
        STOP
      ENDIF
c
c  Transfer back
c
      do j=1,ncf0
        jtr=jtmp(j)
        vpeng(jtr)=tmpeng(j)
        do i=1,ncf0
          itr=jtmp(i)
          brevec(itr,jtr)=tmpvec(i,j)
        enddo
      enddo
c
c  Go look for another symmetry
c
      go to 40
C-----------------------------------------------------------------------
C
C  Diagonalisation of the Hamiltonian complete
C
C-----------------------------------------------------------------------
c
c  Sort into ascending energy order
c
  60  do i=1,ncf
        k=i
        ee=vpeng(k)
        do j=i+1,ncf
          if(vpeng(j).lt.ee)then
            k=j
            ee=vpeng(j)
          endif
        enddo
        if(k.ne.i)then
          vpeng(k)=vpeng(i)
          vpeng(i)=ee
          do j=1,ncf
            t=brevec(j,i)
            brevec(j,i)=brevec(j,k)
            brevec(j,k)=t
          enddo
        endif
      enddo
C
C  Add back the average energy
C
      DO I = 1,NCF
        VPENG(I) = VPENG(I)+EAV
      ENDDO
C-----------------------------------------------------------------------
C
C  Order new Breit eigenvectors and eigenvalues consistently
C  with the zero-order Coulomb ones.
C
      DO I = 1,NCF
C
C  Find equivalent new vector that is (approx) normal
C  to the I-th zero-order vector.
C
        MAX = 0
        AMAX = ZERO
C
C  Find MAX element of vector.
C
        DO J = 1,NCF
          A = ZERO
          DO L = 1,NCF
            A = A+COUVEC(L,I)*BREVEC(L,J)
          ENDDO
          A = ABS(A)
          AOVLAP(J) = A
          IF (A.GE.AMAX) THEN
            MAX = J
            AMAX = A
          ENDIF
        ENDDO
C
        IF (AMAX.LT.0.9D0) THEN
          WRITE (IWRITE,3020) I,AMAX,MAX,(AOVLAP(J),J=1,NCF)
        ENDIF
C
C  MAX-th vector is (approx) equivalent
C
        BREENG(I) = VPENG(MAX)-COUENG(I)
C
        IF (I.NE.MAX) THEN
          LSWAP = .TRUE.
          LORDER(I) = 1
          WRITE (IWRITE,3040) I,MAX
          WRITE (IPUNCH,3050) I,MAX
          PRINT 3050,I,MAX
        ELSE
          LORDER(I) = 0
        ENDIF
C
C  use same phase for vector as used for coulomb vector
C
        AMAX = ZERO
        IMAX = 0
C
        DO L = 1,NCF
          A = ABS(BREVEC(L,MAX))
          IF (A.LT.EPS10) THEN
            BREVEC(L,MAX) = ZERO
          ELSE
            IF (A.GT.AMAX) THEN
              AMAX = A
              IMAX = L
            ENDIF
          ENDIF
        ENDDO
C
C  make sign of largest element positive
C
        IF (BREVEC(IMAX,MAX).LT.ZERO) THEN
          DO L = 1,NCF
            BREVEC(L,MAX) = -BREVEC(L,MAX)
          ENDDO
        ENDIF
C
        IORDER(I) = MAX
        itmp(i)=imax
C
      ENDDO
C
C  Print eigenvalues and eigenvectors if option 6 is set
C  (Breit ordering here.)
C
      IF (ITC(6).EQ.1) THEN
C
        WRITE (IWRITE,3080)
C
        DO J = 1,NCPRIN
C
          EAU = vpeng(J)
          I = itmp(J)
          IJ = ITJPO(I)-1
          IP = ISPAR(I)
          AM = brevec(I,J)
C
          IF (MOD(IJ,2).EQ.0) THEN
            IJ = IJ/2
            IF (IP.EQ.1) THEN
              WRITE (IWRITE,3120) J,IJ,I,AM,EAU
            ELSE
              WRITE (IWRITE,3110) J,IJ,I,AM,EAU
            ENDIF
          ELSE
            IF (IP.EQ.1) THEN
              WRITE (IWRITE,3100) J,IJ,I,AM,EAU
            ELSE
              WRITE (IWRITE,3090) J,IJ,I,AM,EAU
            ENDIF
          ENDIF
C
        ENDDO
C
        CALL MATOUT(IWRITE,BREVEC,NCPRIN,NCF,MXNC,MXNC,3)
C
      ENDIF
C
C  now rearrange the eigenvectors according to the Coulomb ordering
C
      IF (LSWAP) THEN
C
        DO I = 1,NCF
          MAX = IORDER(I)
          DO L = 1,NCF
            TMPVEC(L,I) = BREVEC(L,MAX)
          ENDDO
        ENDDO
C
        DO I = 1,NCF
          DO J = 1,NCF
            BREVEC(I,J) = TMPVEC(I,J)
          ENDDO
        ENDDO
C
      ENDIF
C
 3000 FORMAT (/                                                         !
     +' >>>> routine BREMT2 called : diagonalise the Breit matrix')
 3010 FORMAT (/' ERROR using the DSYEV routine'/' STOPPING')
 3020 FORMAT (/' Possible breakdown in perturbation theory for level ',I!
     +4/' Maximum vector normalisation is ',1P,E8.1,' with level ',I4/  !
     +' The overlaps are :'/(1X,1P,8E9.1))
 3030 FORMAT (/' diagonalisation using the DSYEV routine'/)
 3040 FORMAT (/' WARNING from BREMT2'/                                  !
     +' Change in level ordering when Breit contribution is included'/  !
     +' Coulomb level ',I4,' is equivalent to Breit level ',I4)
 3050 FORMAT (/' Coulomb level ',I4,' is equivalent to Breit level ',I4)
 3060 FORMAT (/' average energy (a.u.) ',1P,E18.10)
 3070 FORMAT (/' estimated Hamiltonian matrix')
 3080 FORMAT (/' eigenenergies'//'                    dominant'/        !
     +' level  J   parity  CSF   mix         a.u.'/)
 3090 FORMAT (1X,I4,2X,I4,'/2  odd    ',I4,2X,F5.3,3X,1P,E20.12)
 3100 FORMAT (1X,I4,2X,I4,'/2  even   ',I4,2X,F5.3,3X,1P,E20.12)
 3110 FORMAT (1X,I4,2X,I4,'    odd    ',I4,2X,F5.3,3X,1P,E20.12)
 3120 FORMAT (1X,I4,2X,I4,'    even   ',I4,2X,F5.3,3X,1P,E20.12)
      END
C
C                             *******************
C
      FUNCTION BRRA(ITYPE,IA,IC,IB,ID,K)
C
C-----------------------------------------------------------------------
C
C  This routine evaluates the Breit interaction integrals
C
C       ITYPE=1. calculates general R(K; A C / B D )
C
C       ITYPE=2. calculates general S(K; A C / B D )
C
C       ITYPE=3. calculates R(K; A , B D )
C
C       ITYPE=4. calculates F(K; A , B )
C
C       ITYPE=5. calcualtes G(K; A , B ) type integral
C
C       ITYPE=6. calculates H(K; A , B ) type integral
C
C  It calls the routines RKINT and SKINT to perform the particular
C  integrals required.
C
C  Subroutines called:  RKINT,SKINT
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      DOUBLE PRECISION BRRA
      INCLUDE 'grasp0.inc'
C
C  External functions
C
      EXTERNAL RKINT,SKINT
      DOUBLE PRECISION RKINT,SKINT
C
C  Parameter variables
C
      DOUBLE PRECISION HALF
      PARAMETER (HALF=.5D0)
      DOUBLE PRECISION TWO
      PARAMETER (TWO=2.D0)
C
C  Argument variables
C
      INTEGER IA,IB,IC,ID
      INTEGER ITYPE,K
C
C  Local variables
C
      DOUBLE PRECISION RAC(MXNP),RBD(MXNP)
      INTEGER I,IA1,IB1,IC1
      INTEGER ID1,NGRAC,NGRBD,NGRID
C
C  Common variables
C
      INTEGER MPOIN(MXNW),MPOS(MXNW)
      COMMON / PATY   / MPOIN,MPOS
C
C  Common variables
C
      DOUBLE PRECISION PF(MXNG),QF(MXNG)
      COMMON / WAVE   / PF,QF
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
C
C  Set the grid end
C
      NGRAC = MIN(MPOIN(IA),MPOIN(IC))
      NGRBD = MIN(MPOIN(IB),MPOIN(ID))
      NGRID = MIN(NGRAC,NGRBD)
C
      IA1 = MPOS(IA)
      IC1 = MPOS(IC)
      DO I = 1,NGRAC
        RAC(I) = PF(IA1)*QF(IC1)
        IA1 = IA1+1
        IC1 = IC1+1
      ENDDO
      IB1 = MPOS(IB)
      ID1 = MPOS(ID)
      DO I = 1,NGRBD
        RBD(I) = PF(IB1)*QF(ID1)
        IB1 = IB1+1
        ID1 = ID1+1
      ENDDO
C
      GOTO (10,20,30,40,50,60),ITYPE
C
C                                ITYPE=1
C                                -------
   10 CONTINUE
      IF (IA.EQ.IB .AND. IC.EQ.ID) THEN
        BRRA = TWO*RKINT(NGRAC,NGRID,RAC,RBD,K,1)
        RETURN
C
      ENDIF
C
      IF (IA.EQ.ID .AND. IC.EQ.IB) THEN
        BRRA = RKINT(NGRAC,NGRID,RAC,RBD,K,1)+RKINT(NGRAC,NGRID,RBD,RAC,!
     +K,1)
        RETURN
C
      ENDIF
C
      BRRA = (RKINT(NGRAC,NGRID,RAC,RBD,K,1)+RKINT(NGRAC,NGRID,RAC,RBD,K!
     +,2)+RKINT(NGRAC,NGRID,RBD,RAC,K,1)+RKINT(NGRAC,NGRID,RBD,RAC,K,2))!
     +*HALF
      RETURN
C
C                                ITYPE=2
C                                -------
   20 CONTINUE
      IF ((IA.EQ.IB.AND.IC.EQ.ID) .OR. (IA.EQ.ID.AND.IC.EQ.IB)) THEN
        BRRA = SKINT(NGRAC,NGRBD,NGRID,RAC,RBD,K,1)
C
      ELSE
        BRRA = (SKINT(NGRAC,NGRBD,NGRID,RAC,RBD,K,1)+SKINT(NGRAC,NGRBD,N!
     +GRID,RAC,RBD,K,2))*HALF
      ENDIF
C
      RETURN
C
C                                ITYPE=3
C                                -------
   30 CONTINUE
      IF (IA.EQ.IC) THEN
        IB1 = MPOS(IB)
        ID1 = MPOS(ID)
        DO I = 1,NGRBD
          RBD(I) = RBD(I)+PF(ID1)*QF(IB1)
          IB1 = IB1+1
          ID1 = ID1+1
        ENDDO
        BRRA = (RKINT(NGRAC,NGRID,RAC,RBD,K,0)+RKINT(NGRAC,NGRID,RAC,RBD!
     +,K,2)+RKINT(NGRAC,NGRID,RBD,RAC,K,2))*HALF
C
      ELSE
        IC1 = MPOS(IC)
        IA1 = MPOS(IA)
        DO I = 1,NGRAC
          RAC(I) = RAC(I)+PF(IC1)*QF(IA1)
          IC1 = IC1+1
          IA1 = IA1+1
        ENDDO
        BRRA = (RKINT(NGRAC,NGRID,RAC,RBD,K,1)+RKINT(NGRAC,NGRID,RBD,RAC!
     +,K,1)+RKINT(NGRAC,NGRID,RAC,RBD,K,0))*HALF
      ENDIF
C
      RETURN
C
C                                ITYPE=4
C                                -------
   40 CONTINUE
      BRRA = RKINT(NGRAC,NGRID,RAC,RBD,K,0)
      RETURN
C
C                                ITYPE=5
C                                -------
   50 CONTINUE
      IF (IA.EQ.ID .AND. IC.EQ.IB) THEN
        BRRA = RKINT(NGRAC,NGRID,RAC,RBD,K,1)+RKINT(NGRAC,NGRID,RBD,RAC,!
     +K,1)
C
      ELSE
        BRRA = TWO*RKINT(NGRAC,NGRID,RAC,RBD,K,1)
      ENDIF
C
      RETURN
C
C                                ITYPE=6
C                                -------
   60 CONTINUE
      BRRA = SKINT(NGRAC,NGRBD,NGRID,RAC,RBD,K,1)
C
      END
C
C                             *******************
C
      SUBROUTINE CALEN(IWRITE,IPUNCH,RECORD)
C-----------------------------------------------------------------------
C
C   CALEN returns in RECORD the time and date at execution of program.
C
C-----------------------------------------------------------------------
      CHARACTER RECORD*20
C-----------------------------------------------------------------------
      RECORD = ' not available      '
C
      IF (IWRITE.GT.0) WRITE (IWRITE,3000) RECORD
      IF (IPUNCH.GT.0) WRITE (IPUNCH,3000) RECORD
C
 3000 FORMAT (//' Run at : ',A20/)
      END
C
C                             *******************
C
      SUBROUTINE CARDIN(IREAD,IWRITE,IPUNCH,LABEL,JC,NH,NG,NN,RT,IT,ND)
C
C-----------------------------------------------------------------------
C
C   Reads input records using free format.
C
C   NOTE that only the first 72 characters on the input record are read.
C
C   INPUT
C
C   IREAD  - input read from stream number IREAD
C   IWRITE - output written to stream number IWRITE
C   IPUNCH - output written to stream number IPUNCH
C   LABEL  - number of input record being read
C   JC     - determines the format in which the input
C            record is to be read
C         =0  read 72 characters.
C         =1  read integer (I2) , label (A2) , 68 characters
C             The label is used to assign kappa values for orbitals.
C         =2  read label (A4) , 68 characters
C   ND     - maximum number of numbers which can be read
C            sets the dimensions of RT and IT
C
C   OUTPUT
C
C   NH - A2 label read if JC=1
C   NG - A4 label read if JC=2
C   NN - the number of numbers which have been read
C   RT - array containing the NN numbers as reals
C   IT - array containing the NN numbers as integers
C
C   The following characters are recognised
C     0 1 2 3 4 5 6 7 8 9 - . E / * C ! c e D d + : and BLANK
C
C   BLANK is used to separate numbers.
C   BLANKs cannot occur within a number.
C
C   'C' or 'c' can be used to continue an input record - another
C       input record will be read by CARDIN using format JC=0
C       A number cannot be split across two input records.
C       All characters following 'C' or 'c' are ignored.
C
C   '/' can be used to input fractions with numerator or
C       denominator being real or integer
C
C   'E' or 'e' or 'D' or 'd' denotes exponent
C       the exponent must be an integer between -99 and 99
C
C   '*' is used to indicate a repeated value as in FORTRAN
C       data statements
C
C   ':' specifies a range of numbers
C
C   '!' marks the end of the input record, allows comments to be written
C
C   Some checks on consistency are in the code.
C   An error message will be output if the routine fails.
C
C   The following are examples of numbers which can
C   be read by CARDIN :
C
C   .123 , -.123 , -3.23 , 4.5E6 , 12 , 2E-6
C   2/6 , 2.1/6 , -2./6E-2
C
C   Numbers are read as reals (RT)
C   and then the nearest integers are obtained (IT).
C
C   No subroutines called.
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
C
C  Parameter variables
C
      DOUBLE PRECISION EPS6
      PARAMETER (EPS6=1.D-6)
      DOUBLE PRECISION ZERO
      PARAMETER (ZERO=0.D0)
      DOUBLE PRECISION HALF
      PARAMETER (HALF=.5D0)
      DOUBLE PRECISION ONE
      PARAMETER (ONE=1.D0)
      DOUBLE PRECISION TEN
      PARAMETER (TEN=1.D1)
C
C  Argument variables
C
      INTEGER JC,LABEL,ND,NN
      CHARACTER*4 NG
      CHARACTER*2 NH
      DOUBLE PRECISION RT(ND)
      INTEGER IPUNCH,IREAD,IT(ND),IWRITE
C
C  Local variables
C
      CHARACTER BLANK,ICH(24)
      CHARACTER*2 IOR(15)
      CHARACTER JD(73),JDJ
      DOUBLE PRECISION RINC,SUM,SUMA,SUME
      DOUBLE PRECISION SUMX,XSIGN
      INTEGER I,IBL,ICO,IDI
      INTEGER IEX,IFAIL,IPT,IRA
      INTEGER IRP,ISI,J,JPT
      INTEGER JSTART,K,LEN,N1
      INTEGER NK(15),NRA,NRP
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      DATA BLANK/' '/
      DATA IOR/'S ','P-','P ','D-','D ','F-','F ','G-','G ','H-','H ','I!
     +-','I ','J-','J '/
      DATA NK/-1,1,-2,2,-3,3,-4,4,-5,5,-6,6,-7,7,-8/
      DATA ICH/'0','1','2','3','4','5','6','7','8','9','-','.','E','/','!
     +*',' ','C','!','c','e','D','d','+',':'/
C-----------------------------------------------------------------------
      IF (JC.EQ.2) THEN
C
C  JC=2  read label (A4) , 68 characters
C
        READ (IREAD,3200) NG, (JD(I),I=5,72)
C
        DO I = 72,5,-1
          IF (JD(I).NE.BLANK) THEN
            LEN = I
            GOTO 10
          ENDIF
        ENDDO
        LEN = 5
   10   CONTINUE
C
        LABEL = LABEL+1
        IF (IWRITE.GT.0) WRITE (IWRITE,3210) LABEL,NG, (JD(I),I=5,LEN)
        IF (IPUNCH.GT.0) WRITE (IPUNCH,3210) LABEL,NG, (JD(I),I=5,LEN)
        NN = 0
        N1 = 1
        JSTART = 4
C
      ELSE
C
        IF (JC.EQ.1) THEN
C
C  JC=1  read integer (I2) , label (A2) , 68 characters
C  The label is used to assign kappa values for orbitals.
C
          READ (IREAD,3260) IT(1),NH, (JD(I),I=5,72)
C
          DO I = 72,5,-1
            IF (JD(I).NE.BLANK) THEN
              LEN = I
              GOTO 20
            ENDIF
          ENDDO
          LEN = 5
   20     CONTINUE
C
          LABEL = LABEL+1
          IF (IWRITE.GT.0) WRITE (IWRITE,3270) LABEL,IT(1),NH,(JD(I),I=5!
     +,LEN)
          IF (IPUNCH.GT.0) WRITE (IPUNCH,3270) LABEL,IT(1),NH,(JD(I),I=5!
     +,LEN)
          DO I = 1,15
            IF (NH.EQ.IOR(I)) GOTO 30
          ENDDO
          J = 1
          JSTART = 4
          IFAIL = 0
          GOTO 170
C
   30     CONTINUE
          IT(2) = NK(I)
          RT(1) = IT(1)
          RT(2) = IT(2)
          NN = 2
          N1 = 3
          JSTART = 4
C
        ELSE
C
C  JC=0  read 72 characters.
C
          READ (IREAD,3220) (JD(I),I=1,72)
C
          DO I = 72,1,-1
            IF (JD(I).NE.BLANK) THEN
              LEN = I
              GOTO 40
            ENDIF
          ENDDO
          LEN = 1
   40     CONTINUE
C
          LABEL = LABEL+1
          IF (IWRITE.GT.0) WRITE (IWRITE,3230) LABEL, (JD(I),I=1,LEN)
          IF (IPUNCH.GT.0) WRITE (IPUNCH,3230) LABEL, (JD(I),I=1,LEN)
          NN = 0
          N1 = 1
          JSTART = 0
        ENDIF
C
      ENDIF
C
      GOTO 70
C-----------------------------------------------------------------------
C
C  begin here if an input record is continued
C
C-----------------------------------------------------------------------
   50 CONTINUE
      READ (IREAD,3220) (JD(I),I=1,72)
C
      DO I = 72,1,-1
        IF (JD(I).NE.BLANK) THEN
          LEN = I
          GOTO 60
        ENDIF
      ENDDO
      LEN = 1
   60 CONTINUE
C
      LABEL = LABEL+1
      IF (IWRITE.GT.0) WRITE (IWRITE,3230) LABEL, (JD(I),I=1,LEN)
      IF (IPUNCH.GT.0) WRITE (IPUNCH,3230) LABEL, (JD(I),I=1,LEN)
      JSTART = 0
C-----------------------------------------------------------------------
C
C  begin here for each new input record
C
C-----------------------------------------------------------------------
   70 CONTINUE
      ICO = 0
      IRA = 0
      IRP = 0
      LEN = LEN+1
      JD(LEN) = BLANK
      J = JSTART
C-----------------------------------------------------------------------
C
C  begin here when a complete number has been read
C
C-----------------------------------------------------------------------
   80 CONTINUE
      IBL = 0
      IDI = 0
C-----------------------------------------------------------------------
C
C  begin here if '/' has been read - read denominator
C
C-----------------------------------------------------------------------
   90 CONTINUE
      IEX = 0
C-----------------------------------------------------------------------
C
C  begin here if 'E' or 'e' or 'D' or 'd' has been read  - read exponent
C
C-----------------------------------------------------------------------
  100 CONTINUE
      ISI = 0
      IPT = 0
      JPT = 0
      SUM = ZERO
      XSIGN = ONE
C-----------------------------------------------------------------------
C
C  examine each character in turn
C
C-----------------------------------------------------------------------
  110 CONTINUE
      J = J+1
C
C ====== only the first LEN characters are examined ======
C
      IF (J.EQ.LEN+1) GOTO 160
C
      JDJ = JD(J)
      DO I = 1,24
        IF (JDJ.EQ.ICH(I)) GOTO 120
      ENDDO
C-----------------------------------------------------------------------
C
C  ERROR - character not allowed
C
C-----------------------------------------------------------------------
      IFAIL = 1
      GOTO 170
C-----------------------------------------------------------------------
  120 CONTINUE
C-----------------------------------------------------------------------
      IF (I.EQ.16) GOTO 140
C-----------------------------------------------------------------------
C
C  character is '!' for comment
C  this is equivalent to BLANK and end of line
C
C-----------------------------------------------------------------------
      IF (I.EQ.18) THEN
        I = 16
        J = LEN
        GOTO 140
      ENDIF
C-----------------------------------------------------------------------
C
C  character is 'C' or 'c' for continue
C  another input record will be read
C  this is equivalent to BLANK and end of line
C  with flag set for continue
C
C-----------------------------------------------------------------------
      IF (I.EQ.17 .OR. I.EQ.19) THEN
        I = 16
        J = LEN
        ICO = 1
        GOTO 140
      ENDIF
C-----------------------------------------------------------------------
C
C  character is ':' for range
C  this is equivalent to BLANK
C  with flag set for range
C
C-----------------------------------------------------------------------
      IF (I.EQ.24) THEN
C
        IF (IRA.GT.0) THEN
          IFAIL = 13
          GOTO 170
        ENDIF
C
        IF (IRP.GT.0) THEN
          IFAIL = 14
          GOTO 170
        ENDIF
C
        I = 16
        IRA = 1
        GOTO 140
C
      ENDIF
C-----------------------------------------------------------------------
C
C  character is '*' for repeat
C  this is equivalent to BLANK
C  with flag set for repeat
C
C-----------------------------------------------------------------------
      IF (I.EQ.15) THEN
C
        IF (IRA.GT.0) THEN
          IFAIL = 23
          GOTO 170
        ENDIF
C
        IF (IRP.GT.0) THEN
          IFAIL = 24
          GOTO 170
        ENDIF
C
        I = 16
        IRP = 1
        GOTO 140
C
      ENDIF
C-----------------------------------------------------------------------
C
C  Character is a digit.
C  Construct the number.
C  IBL is set to 1 and ISI is set to 1 to indicate a number
C   is being read
C
C-----------------------------------------------------------------------
      IF (I.GE.1 .AND. I.LE.10) THEN
        IBL = 1
        ISI = 1
        JPT = JPT+1
        SUM = SUM*TEN+(I-1)
        GOTO 110
      ENDIF
C-----------------------------------------------------------------------
C
C  character is '-'
C  ERROR - if a sign has already been read for this number
C
C-----------------------------------------------------------------------
      IF (I.EQ.11) THEN
C
        IF (ISI.EQ.1) THEN
          IFAIL = 4
          GOTO 170
        ENDIF
C
        XSIGN = -ONE
        ISI = 1
        GOTO 110
C
      ENDIF
C-----------------------------------------------------------------------
C
C  character is '+'
C  ERROR - if a sign has already been read for this number
C
C-----------------------------------------------------------------------
      IF (I.EQ.23) THEN
C
        IF (ISI.EQ.1) THEN
          IFAIL = 4
          GOTO 170
        ENDIF
C
        XSIGN = ONE
        ISI = 1
        GOTO 110
C
      ENDIF
C-----------------------------------------------------------------------
C
C  character is '.'
C  ERROR - if '.' has already been read for this number
C
C-----------------------------------------------------------------------
      IF (I.EQ.12) THEN
C
        IF (IPT.EQ.1) THEN
          IFAIL = 5
          GOTO 170
        ENDIF
C
        ISI = 1
        IPT = 1
        JPT = 0
        GOTO 110
C
      ENDIF
C-----------------------------------------------------------------------
C
C  To get here you must have read
C
C    'E' or 'e' or 'D' or 'd'
C    '/'
C    ' ' just after a number
C
C-----------------------------------------------------------------------
  130 CONTINUE
C-----------------------------------------------------------------------
C
C  form current number
C
C  ERROR - '.' in isolation
C
C-----------------------------------------------------------------------
      SUM = XSIGN*SUM
C
      IF (IPT.GT.0) THEN
        IF (IBL.EQ.0) THEN
          IFAIL = 6
          GOTO 170
        ENDIF
        SUM = SUM*TEN**(-JPT)
      ENDIF
C-----------------------------------------------------------------------
C
C  character is 'E' or 'e' or 'D' or 'd'
C
C  ERROR - if 'E' has already been read for this number
C          or a number is not being read
C
C  store mantissa in SUME and look for exponent
C
C-----------------------------------------------------------------------
      IF (I.EQ.13 .OR. I.EQ.20 .OR. I.EQ.21 .OR. I.EQ.22) THEN
C
        IF (IEX.EQ.1) THEN
          IFAIL = 7
          GOTO 170
        ENDIF
C
        IF (IBL.EQ.0) THEN
          IFAIL = 8
          GOTO 170
        ENDIF
C
        IEX = 1
        SUME = SUM
        GOTO 100
C
      ENDIF
C-----------------------------------------------------------------------
C
C  character is '/' or ' '
C
C-----------------------------------------------------------------------
C
C  'E' has been read for this number
C  the exponent has now been obtained
C
C  ERROR - if exponent contained '.' or more than 2 digits
C    (exponent is an integer lying between -99 and 99)
C
C  Form the number.
C
C-----------------------------------------------------------------------
      IF (IEX.EQ.1) THEN
C
        IF (IPT.EQ.1) THEN
          IFAIL = 9
          GOTO 170
        ENDIF
C
        IF (JPT.GT.2) THEN
          IFAIL = 10
          GOTO 170
        ENDIF
C
        IF (SUM.LT.ZERO) SUM = SUM - HALF - EPS6
        IF (SUM.GE.ZERO) SUM = SUM + HALF + EPS6
        JPT = INT(SUM)
        SUM = SUME*TEN**JPT
C
      ENDIF
C-----------------------------------------------------------------------
C
C  Character is '/'  - denoting division
C
C  ERROR - if '/' has already been read for this number
C          or a number is not being read
C
C  Store the first number.
C  Read the denominator.
C
C-----------------------------------------------------------------------
      IF (I.EQ.14) THEN
C
        IF (IDI.EQ.1) THEN
          IFAIL = 11
          GOTO 170
        ENDIF
C
        IF (IBL.EQ.0) THEN
          IFAIL = 12
          GOTO 170
        ENDIF
C
        IDI = 1
        SUMA = SUM
        GOTO 90
C
      ENDIF
C-----------------------------------------------------------------------
      GOTO 150
C-----------------------------------------------------------------------
C
C  character is ' '
C  This character is used to separate numbers.
C  It indicates that a number has been read.
C
C-----------------------------------------------------------------------
  140 CONTINUE
      IF (IBL.EQ.1) GOTO 130
      GOTO 80
C-----------------------------------------------------------------------
C
C  '/' was read - evaluate number.
C
C  ERROR - denominator is zero.
C
C-----------------------------------------------------------------------
  150 CONTINUE
      IF (IDI.EQ.1) THEN
        IF (SUM.EQ.ZERO) THEN
          IFAIL = 15
          GOTO 170
        ENDIF
        SUM = SUMA/SUM
      ENDIF
C-----------------------------------------------------------------------
C
C  Range was defined.
C
C-----------------------------------------------------------------------
      IF (IRA.EQ.1) THEN
        SUMX = SUM
        IRA = 2
        GOTO 80
      ENDIF
C
      IF (IRA.EQ.2) THEN
C
        NRA = INT(SUM-SUMX)
        RINC = ONE
C
        IF (NRA.LT.0) THEN
          RINC = -ONE
          NRA = -NRA
        ELSE
          RINC = ONE
        ENDIF
C
        NN = NN+1
        IF (NN.GT.ND) GOTO 180
        RT(NN) = SUMX
C
        IF (NRA.GT.0) THEN
          DO K = 1,NRA
            SUMX = SUMX+RINC
            NN = NN+1
            IF (NN.GT.ND) GOTO 180
            RT(NN) = SUMX
          ENDDO
        ENDIF
C
        IRA = 0
        GOTO 80
C
      ENDIF
C-----------------------------------------------------------------------
C
C  Repeat count given.
C
C  ERROR - if repeat count is less then 1
C
C-----------------------------------------------------------------------
      IF (IRP.EQ.1) THEN
C
        NRP = INT(SUM)
C
        IF (NRP.LE.0) THEN
          IFAIL = 20
          GOTO 170
        ENDIF
C
        IRP = 2
        GOTO 80
C
      ENDIF
C
      IF (IRP.EQ.2) THEN
        DO K = 1,NRP
          NN = NN+1
          IF (NN.GT.ND) GOTO 180
          RT(NN) = SUM
        ENDDO
        IRP = 0
        GOTO 80
      ENDIF
C-----------------------------------------------------------------------
      NN = NN+1
      IF (NN.GT.ND) GOTO 180
      RT(NN) = SUM
      GOTO 80
C-----------------------------------------------------------------------
C
C  Input record has been read.
C  Read another input record if 'C' has been read.
C
C  EROOR - You cannot continue with incomplete range or repeat.
C
C-----------------------------------------------------------------------
  160 CONTINUE
C
      IF (IRA.GT.1) THEN
        IFAIL = 33
        GOTO 170
      ENDIF
C
      IF (IRP.GT.1) THEN
        IFAIL = 34
        GOTO 170
      ENDIF
C
      IF (ICO.EQ.1) GOTO 50
C-----------------------------------------------------------------------
C
C  The numbers are read as real.
C  Take the nearest integers.
C
C-----------------------------------------------------------------------
      IF (NN.GE.N1) THEN
        DO I = N1,NN
          SUM = RT(I)
          IF (SUM.LT.ZERO) THEN
            SUM = SUM-HALF-EPS6
          ELSE
            SUM = SUM+HALF+EPS6
          ENDIF
          IT(I) = INT(SUM)
        ENDDO
      ENDIF
C-----------------------------------------------------------------------
      RETURN
C-----------------------------------------------------------------------
C
C  ERROR messages.
C
C-----------------------------------------------------------------------
  170 CONTINUE
      DO I = JSTART+1,LEN
        JD(I) = ICH(16)
      ENDDO
      IF (IFAIL.GT.0) JD(J) = ICH(15)
      IF (IWRITE.GT.0) THEN
        IF (JC.EQ.2) WRITE (IWRITE,3210) LABEL,NG, (JD(I),I=5,LEN)
        IF (JC.EQ.1) WRITE (IWRITE,3270) LABEL,IT(1),NH,(JD(I),I=5,LEN)
        IF (JC.EQ.0) WRITE (IWRITE,3230) LABEL, (JD(I),I=1,LEN)
        WRITE (IWRITE,3240)
        IF (IFAIL.EQ.0) WRITE (IWRITE,3000)
        IF (IFAIL.EQ.1) WRITE (IWRITE,3010)
        IF (IFAIL.EQ.4) WRITE (IWRITE,3020)
        IF (IFAIL.EQ.5) WRITE (IWRITE,3030)
        IF (IFAIL.EQ.6) WRITE (IWRITE,3040)
        IF (IFAIL.EQ.7) WRITE (IWRITE,3050)
        IF (IFAIL.EQ.8) WRITE (IWRITE,3060)
        IF (IFAIL.EQ.9) WRITE (IWRITE,3070)
        IF (IFAIL.EQ.10) WRITE (IWRITE,3080)
        IF (IFAIL.EQ.11) WRITE (IWRITE,3090)
        IF (IFAIL.EQ.12) WRITE (IWRITE,3100)
        IF (IFAIL.EQ.13) WRITE (IWRITE,3110)
        IF (IFAIL.EQ.14) WRITE (IWRITE,3120)
        IF (IFAIL.EQ.15) WRITE (IWRITE,3130)
        IF (IFAIL.EQ.17) WRITE (IWRITE,3140)
        IF (IFAIL.EQ.20) WRITE (IWRITE,3150)
        IF (IFAIL.EQ.23) WRITE (IWRITE,3160)
        IF (IFAIL.EQ.24) WRITE (IWRITE,3170)
        IF (IFAIL.EQ.33) WRITE (IWRITE,3180)
        IF (IFAIL.EQ.34) WRITE (IWRITE,3190)
      ENDIF
C
      IF (IPUNCH.GT.0) THEN
        IF (JC.EQ.2) WRITE (IPUNCH,3210) LABEL,NG, (JD(I),I=5,LEN)
        IF (JC.EQ.1) WRITE (IPUNCH,3270) LABEL,IT(1),NH,(JD(I),I=5,LEN)
        IF (JC.EQ.0) WRITE (IPUNCH,3230) LABEL, (JD(I),I=1,LEN)
        WRITE (IPUNCH,3240)
        IF (IFAIL.EQ.0) WRITE (IPUNCH,3000)
        IF (IFAIL.EQ.1) WRITE (IPUNCH,3010)
        IF (IFAIL.EQ.4) WRITE (IPUNCH,3020)
        IF (IFAIL.EQ.5) WRITE (IPUNCH,3030)
        IF (IFAIL.EQ.6) WRITE (IPUNCH,3040)
        IF (IFAIL.EQ.7) WRITE (IPUNCH,3050)
        IF (IFAIL.EQ.8) WRITE (IPUNCH,3060)
        IF (IFAIL.EQ.9) WRITE (IPUNCH,3070)
        IF (IFAIL.EQ.10) WRITE (IPUNCH,3080)
        IF (IFAIL.EQ.11) WRITE (IPUNCH,3090)
        IF (IFAIL.EQ.12) WRITE (IPUNCH,3100)
        IF (IFAIL.EQ.13) WRITE (IPUNCH,3110)
        IF (IFAIL.EQ.14) WRITE (IPUNCH,3120)
        IF (IFAIL.EQ.15) WRITE (IPUNCH,3130)
        IF (IFAIL.EQ.17) WRITE (IPUNCH,3140)
        IF (IFAIL.EQ.20) WRITE (IPUNCH,3150)
        IF (IFAIL.EQ.23) WRITE (IPUNCH,3160)
        IF (IFAIL.EQ.24) WRITE (IPUNCH,3170)
        IF (IFAIL.EQ.33) WRITE (IPUNCH,3180)
        IF (IFAIL.EQ.34) WRITE (IPUNCH,3190)
      ENDIF
C
      STOP
C-----------------------------------------------------------------------
  180 CONTINUE
      IF (IWRITE.GT.0) WRITE (IWRITE,3250)
      IF (IPUNCH.GT.0) WRITE (IPUNCH,3250)
      STOP
C-----------------------------------------------------------------------
 3000 FORMAT (' orbital label not recognised')
 3010 FORMAT (' character not recognised')
 3020 FORMAT (' sign already read for this number')
 3030 FORMAT (' . already read for this number')
 3040 FORMAT (' . occurs in isolation')
 3050 FORMAT (' exponent already read for this number')
 3060 FORMAT (' exponent read but number is not being read')
 3070 FORMAT (' exponent contains .')
 3080 FORMAT (' exponent has more than 2 digits')
 3090 FORMAT (' / already read for this number')
 3100 FORMAT (' / read but number is not being read')
 3110 FORMAT (' : read but range already specified')
 3120 FORMAT (' : read but repeat count already specified')
 3130 FORMAT (' denominator is zero')
 3140 FORMAT (' range of numbers but repeat count already specified')
 3150 FORMAT (' repeat count is less than 1')
 3160 FORMAT (' * read but range already specified')
 3170 FORMAT (' * read but repeat count already specified')
 3180 FORMAT (' : cannot be continued to another line')
 3190 FORMAT (' * cannot be continued to another line')
 3200 FORMAT (A4,69A1)
 3210 FORMAT (1X,I4,' = ',A4,69A1)
 3220 FORMAT (73A1)
 3230 FORMAT (1X,I4,' = ',73A1)
 3240 FORMAT (/' ERROR on above input record read by subroutine CARDIN')
 3250 FORMAT (/' Dimension ERROR in subroutine CARDIN.'/                !
     +' Increase the input parameter ND.')
 3260 FORMAT (I2,A2,69A1)
 3270 FORMAT (1X,I4,' = ',I2,A2,69A1)
      END
C
C                             *******************
C
      SUBROUTINE CFOUT
C
C-----------------------------------------------------------------------
C
C  Print configuration data in a neat format.
C
C  No subroutines called.
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  Local variables
C
      CHARACTER*4 ILIT(MXNW),ITOT(MXNW),JLAB(20)
      CHARACTER*2 NNH(MXNW),NOCCP(MXNW),NSEN(MXNW),NUM(20)
      INTEGER I,IBIGJ,IFIRST
      INTEGER ILITJ(MXNW),ITOTJ(MXNW),J,K
      INTEGER K1,K2,MM,MX
      INTEGER NCOR,NCORE,NFULL
      INTEGER NN(MXNW),NOC,NOCC,NWP
      INTEGER NX
C
C  Common variables
C
      INTEGER IPUNCH,IREAD,IWRITE
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
C
C  Common variables
C
      CHARACTER*2 NH(MXNW)
      COMMON / ORB00  / NH
C
C  Common variables
C
      INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF
      INTEGER NP(MXNW),NW
      COMMON / ORB04  / NW,NCF,NP,NAK,IQ
C
C  Common variables
C
      INTEGER ICHOP(MXNW,MXNC),IEXC
      INTEGER JCUP(10,MXNC),JQS(3,MXNW,MXNC)
      COMMON / ORB06  / JQS,JCUP,ICHOP,IEXC
C
C  Common variables
C
      INTEGER ISPAR(MXNC),ITJPO(MXNC)
      COMMON / ORB07  / ITJPO,ISPAR
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      DATA NUM/'0 ','1 ','2 ','3 ','4 ','5 ','6 ','7 ','8 ','9 ','10','1!
     +1','12','13','14','15','16','17','18','19'/
      DATA JLAB/'0   ','1/2 ','1   ','3/2 ','2   ','5/2 ','3   ','7/2 ',!
     +'4   ','9/2 ','5   ','11/2','6   ','13/2','7   ','15/2','8   ','17!
     +/2','9   ','19/2'/
C-----------------------------------------------------------------------
      NCORE = 0
      IF (NW.GT.0) THEN
        DO J = 1,NW
          NFULL = 2*ABS(NAK(J))
          DO I = 1,NCF
            IF (IQ(J,I).NE.NFULL) GOTO 10
          ENDDO
          NCORE = NCORE+1
        ENDDO
      ENDIF
C
   10 CONTINUE
      NWP = NW-NCORE
      NCOR = NCORE+1
C
      WRITE (IWRITE,3000)
C
      IF (NCORE.EQ.0) THEN
        WRITE (IWRITE,3050)
      ELSE
C
        DO I = 1,NCORE
          NX = IQ(I,1)
          NOCCP(I) = NUM(NX+1)
        ENDDO
C
        WRITE (IWRITE,3020)
C
        K1 = 1
        K2 = NCORE
        IF (K2.GT.10) K2 = 10
   20   CONTINUE
        WRITE (IWRITE,3030) (NOCCP(I),I=K1,K2)
        WRITE (IWRITE,3040) (NP(I),NH(I),I=K1,K2)
        IF (K2.EQ.NCORE) GOTO 30
        K1 = K1+10
        K2 = NCORE
        IF (K2.GT.K1+9) K2 = K1 + 9
        GOTO 20
C
   30   CONTINUE
      ENDIF
C-----------------------------------------------------------------------
      IF (NWP.EQ.0) THEN
        WRITE (IWRITE,3060)
      ELSE
        WRITE (IWRITE,3070)
        DO I = 1,NCF
          MM = 1
          IBIGJ = 1
          IFIRST = 0
          NOC = 0
C
          DO J = NCOR,NW
            IF (IQ(J,I).GT.0) THEN
              NOC = NOC+1
              MX = IQ(J,I)
              NOCCP(NOC) = NUM(MX+1)
              NN(NOC) = NP(J)
              NNH(NOC) = NH(J)
              MX = JQS(1,J,I)
              NSEN(NOC) = NUM(MX+1)
              ILITJ(NOC) = JQS(3,J,I)
              NOCC = MIN(IQ(J,I),2*ABS(NAK(J))-IQ(J,I))
              IF (NOCC.GT.0) THEN
                IF (IFIRST.EQ.0) THEN
                  IFIRST = 1
                  IBIGJ = ILITJ(NOC)
                ELSE
                  IBIGJ = JCUP(MM,I)
                  MM = MM+1
                ENDIF
              ENDIF
              ITOTJ(NOC) = IBIGJ
            ENDIF
          ENDDO
C
          DO J = 1,NOC
            MX = ILITJ(J)
            ILIT(J) = JLAB(MX)
            MX = ITOTJ(J)
            ITOT(J) = JLAB(MX)
          ENDDO
C
          MX = ITJPO(I)
          IF (ISPAR(I).GT.0) THEN
            WRITE (IWRITE,3120) I,JLAB(MX)
          ELSE
            WRITE (IWRITE,3110) I,JLAB(MX)
          ENDIF
C
          K1 = 1
          K2 = NOC
          IF (K2.GT.4) K2 = 4
   40     CONTINUE
          WRITE (IWRITE,3080) (NOCCP(K),K=K1,K2)
          WRITE (IWRITE,3090) (NN(K),NNH(K),K=K1,K2)
          WRITE (IWRITE,3100) (NSEN(K),ILIT(K),ITOT(K),K=K1,K2)
          IF (K2.EQ.NOC) GOTO 50
          K1 = K1+4
          K2 = NOC
          IF (K2.GT.K1+3) K2 = K1 + 3
          GOTO 40
C
   50     CONTINUE
        ENDDO
C
      ENDIF
C
      WRITE (IWRITE,3010)
C-----------------------------------------------------------------------
 3000 FORMAT (/1X,71('*')/' routine CFOUT: write out jj-coupled CSFs'/1X!
     +,71('*'))
 3010 FORMAT (/1X,71('*'))
 3020 FORMAT (/' The core common to all CSFs is : ')
 3030 FORMAT (/2X,10(3X,A2,1X))
 3040 FORMAT (2X,10(I2,A2,2X))
 3050 FORMAT (/' No core has been defined')
 3060 FORMAT (/' No valence orbitals have been defined')
 3070 FORMAT (/' CSFs are defined using format :         Q'/            !
     +'                                    NL(-)'/                      !
     +'                                         V;J ) X')
 3080 FORMAT (/1X,4(6X,A2,10X))
 3090 FORMAT (1X,4(2X,I2,A2,12X))
 3100 FORMAT (1X,4(6X,A2,';',A4,')',A4))
 3110 FORMAT (/' CSF ',I5,'  J = ',A4,' odd')
 3120 FORMAT (/' CSF ',I5,'  J = ',A4,' even')
      END
C
C                             *******************
C
      SUBROUTINE CFP(LOCK,NEL,IJD,IVD,IWD,IJP,IVP,IWP,COEFP)
C
C=======================================================================
C
C   Section 3             CFP       5 routines
C
C      1.  CFP
C      2.  CFP3
C      3.  CFP5
C      4.  CFP7
C      5.  CFPD
C
C=======================================================================
C
C                CFP
C                 |
C        -------------------
C        |     |     |     |
C       CFP3  CFP5  CFP7  CFPD
C
C=======================================================================
C
C   These routines have been taken from:
C   CFPJJ - CPC 4(1972)377 , I.P.Grant - ACRI
C
C   The following changes have been made :
C
C   (1) correction deck has been incorporated
C   (2) double precision is used
C   (3) routine CFP has been modified
C   (4) programs now stops when an error is detected
C
C=======================================================================
C
C  Selects the appropriate table of fractional parentage coefficients
C  in JJ-coupling.
C
C  Input variables -
C
C   LOCK     - + OR - (2*J + 1)
C   NEL      - number of equivalent electrons in shell.
C   IJD/IJP  - total J of daughter/parent state.
C   IVD/IVP  - seniority of daughter/parent state
C   IWD/IWP  - other quantum number (if needed).
C
C  Output variable -
C
C   COEFP    - numerical result
C
C  This control routine does not check the input variables for
C  consistency, except the trivial case of J = 1/2.  All other
C  checks are performed at a lower level. The package will return
C  correct results for J = 3/2, 5/2, 7/2. Higher values of J return
C  a value 1.0 if NEL = 1 OR 2; otherwise 0 with an error signal.
C
C  Subroutines called: CFP3,CFP5,CFP7,CFPD
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
C
C  Argument variables
C
      DOUBLE PRECISION COEFP
      INTEGER IJD,IJP,IVD,IVP
      INTEGER IWD,IWP,LOCK,NEL
C
C  Local variables
C
      INTEGER K
C
C  Common variables
C
      INTEGER IPUNCH,IREAD,IWRITE
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
      K = ABS(LOCK)/2
C
      IF (K.GE.5) GOTO 50
C
      GOTO (10,20,30,40),K
C
   10 CONTINUE
      WRITE (IWRITE,3000)
      STOP
C
   20 CONTINUE
      CALL CFP3(NEL,IJD,IJP,COEFP)
      RETURN
C
   30 CONTINUE
      CALL CFP5(NEL,IJD,IVD,IJP,IVP,COEFP)
      RETURN
C
   40 CONTINUE
      CALL CFP7(NEL,IJD,IVD,IJP,IVP,COEFP)
      RETURN
C
   50 CONTINUE
      CALL CFPD(LOCK,NEL,COEFP)
C
 3000 FORMAT (                                                          !
     +' Unnecessary attempt to form CFP for an electron with J = 1/2. ',!
     +'There is an ERROR!')
      END
C
C                             *******************
C
      SUBROUTINE CFP3(NEL,IJD,IJP,COEFP)
C
C-----------------------------------------------------------------------
C
C  Table look-up for fractional parentage coefficients of equivalent
C  electrons with J = 3/2. See listing of CFP for argument list.
C
C  No subroutines called.
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
C
C  Parameter variables
C
      DOUBLE PRECISION SIX
      PARAMETER (SIX=6.D0)
      DOUBLE PRECISION FIVE
      PARAMETER (FIVE=5.D0)
      DOUBLE PRECISION ONE
      PARAMETER (ONE=1.D0)
      DOUBLE PRECISION ZERO
      PARAMETER (ZERO=0.D0)
C
C  Argument variables
C
      DOUBLE PRECISION COEFP
      INTEGER IJD,IJP,NEL
C
C  Common variables
C
      INTEGER IPUNCH,IREAD,IWRITE
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
      IF ((NEL.LE.0) .OR. (NEL.GT.4)) GOTO 70
C
      GOTO (10,20,30,50),NEL
C
   10 CONTINUE
      IF (IJD.NE.3 .OR. IJP.NE.0) GOTO 70
      GOTO 60
C
   20 CONTINUE
      IF (IJP.NE.3) GOTO 70
      IF (IJD.EQ.0 .OR. IJD.EQ.4) GOTO 60
      GOTO 70
C
   30 CONTINUE
      IF (IJD.NE.3) GOTO 70
      IF (IJP.NE.0) GOTO 40
      COEFP = SQRT(ONE/SIX)
      RETURN
C
   40 CONTINUE
      IF (IJP.NE.4) GOTO 70
      COEFP = -SQRT(FIVE/SIX)
      RETURN
C
   50 CONTINUE
      IF (IJD.NE.0 .OR. IJP.NE.3) GOTO 70
   60 CONTINUE
      COEFP = ONE
      RETURN
C
C  Fault mode section.
C
   70 CONTINUE
      COEFP = ZERO
      WRITE (IWRITE,3000) NEL,IJD,IJP
      STOP
C
 3000 FORMAT (' ERROR in trying to compute CFP for a state with ',I4,   !
     +' electrons with J = 3/2'/' Parameters ',4I6)
      END
C
C                             *******************
C
      SUBROUTINE CFP5(NEL,IJD,IVD,IJP,IVP,COEFP)
C
C-----------------------------------------------------------------------
C
C  Table look-up for fractional parentage coefficients of equivalent
C  electrons with J = 5/2. See listing of CFP for argument list.
C
C  No subroutines called.
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
C
C  Parameter variables
C
      DOUBLE PRECISION ONE
      PARAMETER (ONE=1.D0)
      DOUBLE PRECISION SEVEN
      PARAMETER (SEVEN=7.D0)
      DOUBLE PRECISION ZERO
      PARAMETER (ZERO=0.D0)
C
C  Argument variables
C
      DOUBLE PRECISION COEFP
      INTEGER IJD,IJP,IVD,IVP
      INTEGER NEL
C
C  Local variables
C
      DOUBLE PRECISION DENOM,DNEL,FACT
      INTEGER IJ(3,3),IJ1,IJ2,IS
      INTEGER IV(3,3),IV1,IV2,K
      INTEGER KD,KP,N,NORM(3)
      INTEGER NUM3(3,3)
C
C  Common variables
C
      INTEGER IPUNCH,IREAD,IWRITE
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C
C  1.0 tables of data
C
      DATA IJ/5,0,5,0,4,3,0,8,9/,IV/1,0,1,8,2,3,8,2,3/,NUM3/-4,0,0,5,-5,!
     +3,9,2,-11/,NORM/18,7,14/
C-----------------------------------------------------------------------
C
C  2.0 locate entry in CFP table
C
      IF (NEL.LE.0) GOTO 120
      IF (NEL.GE.4) GOTO 10
C
      N = NEL
      IJ1 = IJD
      IV1 = IVD
      IJ2 = IJP
      IV2 = IVP
      GOTO 20
C
   10 CONTINUE
      IF (NEL.GT.6) GOTO 120
      N = 7-NEL
      IJ1 = IJP
      IV1 = IVP
      IJ2 = IJD
      IV2 = IVD
C
C  2.1 find 'daughter' index
C
   20 CONTINUE
      K = 0
   30 CONTINUE
      K = K+1
      IF (K.GT.3) GOTO 120
      IF (IJ(N,K).NE.IJ1) GOTO 30
      IF (IV(N,K).NE.IV1) GOTO 30
      KD = K
C
C  2.2 find 'parent' index
C
      IF (N.NE.1) GOTO 40
      IF (IV2.NE.0) GOTO 120
      IF (IJ2.EQ.0) GOTO 60
      GOTO 120
C
   40 CONTINUE
      K = 0
   50 CONTINUE
      K = K+1
      IF (K.GT.3) GOTO 120
      IF (IJ(N-1,K).NE.IJ2) GOTO 50
      IF (IV(N-1,K).NE.IV2) GOTO 50
      KP = K
C-----------------------------------------------------------------------
C
C  3.0 compute coefficients
C
C  3.1 table look-up
C
      GOTO (60,60,70),N
C
   60 CONTINUE
      COEFP = ONE
      GOTO 100
C
   70 CONTINUE
      COEFP = DBLE(NUM3(KD,KP))
      DENOM = DBLE(NORM(KD))
      IF (COEFP) 90,110,80
   80 CONTINUE
      COEFP = SQRT(COEFP/DENOM)
      GOTO 100
C
   90 CONTINUE
      COEFP = -SQRT(-COEFP/DENOM)
C
C  3.2 insert additional factors for hole states
C
  100 CONTINUE
      IF (NEL.LE.3) GOTO 110
      DNEL = DBLE(NEL)
      FACT = ((SEVEN-DNEL)/DNEL)*(ONE+IJP)/(ONE+IJD)
      COEFP = COEFP*SQRT(FACT)
      IS = ABS((IJD-IJP-IVD+IVP)/2)
      IF (MOD(IS,2).EQ.0) GOTO 110
      COEFP = -COEFP
  110 CONTINUE
      RETURN
C-----------------------------------------------------------------------
C
C  4.0 fault mode section
C
  120 CONTINUE
      COEFP = ZERO
      WRITE (IWRITE,3000) NEL,IJD,IVD,IJP,IVP
      STOP
C
 3000 FORMAT (' ERROR in trying to compute CFP for a state with ',I4,   !
     +' electrons with J = 5/2'/' Parameters ',4I6)
      END
C
C                             *******************
C
      SUBROUTINE CFP7(NEL,IJD,IVD,IJP,IVP,COEFP)
C
C-----------------------------------------------------------------------
C  Table look-up for fractional parentage coefficients of equivalent
C  electrons with J = 7/2. See listing of CFP for argument list.
C
C  No subroutines called.
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
C
C  Parameter variables
C
      DOUBLE PRECISION ONE
      PARAMETER (ONE=1.D0)
      DOUBLE PRECISION NINE
      PARAMETER (NINE=9.D0)
      DOUBLE PRECISION ZERO
      PARAMETER (ZERO=0.D0)
C
C  Argument variables
C
      DOUBLE PRECISION COEFP
      INTEGER IJD,IJP,IVD,IVP
      INTEGER NEL
C
C  Local variables
C
      DOUBLE PRECISION DENOM,DNEL,FACT
      INTEGER IJ(4,8),IJ1,IJ2,IS
      INTEGER IV(4,8),IV1,IV2,K
      INTEGER KD,KP,N
      INTEGER NORM3(6),NORM4(8),NUM3(6,4)
      INTEGER NUM4(8,6)
C
C  Common variables
C
      INTEGER IPUNCH,IREAD,IWRITE
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C
C  1.0 tables of data
C
      DATA IJ/7,0,7,0,0,4,3,4,0,8,5,8,0,12,9,12,0,0,11,4,0,0,15,8,3*0,10!
     +,3*0,16/
      DATA IV/1,0,1,0,10,2,3,2,10,2,3,2,10,2,3,2,10,10,3,4,10,10,3,4,3*1!
     +0,4,3*10,4/
      DATA NUM3/9,5*0,-5,3,121,143,-55,0,-9,-11,12,-900,39,5,-13,0,-65,3!
     +43,104,-17/
      DATA NORM3/36,14,198,1386,198,22/
      DATA NUM4/1,280,308,1144,4*0,0,54,-121,0,-968,169,462,0,0,-231,-14!
     +,195,-77,2366,-343,0,0,-65,250,-245,-1755,90,-945,140,0,-210,91,62!
     +4,280,2275,650,234,0,0,140,-1224,0,-560,680,627/
      DATA NORM4/1,840,924,3432,3080,5460,3080,1001/
C-----------------------------------------------------------------------
C
C  2.0 locate entry in CFP table
C
      IF (NEL.LE.0) GOTO 140
      IF (NEL.GE.5) GOTO 10
C
      N = NEL
      IJ1 = IJD
      IV1 = IVD
      IJ2 = IJP
      IV2 = IVP
      GOTO 20
C
   10 CONTINUE
      IF (NEL.GT.8) GOTO 140
      N = 9-NEL
      IJ1 = IJP
      IV1 = IVP
      IJ2 = IJD
      IV2 = IVD
C
C  2.1 find 'daughter' index
C
   20 CONTINUE
      K = 0
   30 CONTINUE
      K = K+1
      IF (K.GT.8) GOTO 140
      IF (IJ(N,K).NE.IJ1) GOTO 30
      IF (IV(N,K).NE.IV1) GOTO 30
      KD = K
C
C  2.2 find 'parent' index
C
      IF (N.NE.1) GOTO 40
      IF (IV2.NE.0) GOTO 140
      IF (IJ2.EQ.0) GOTO 60
      GOTO 140
C
   40 CONTINUE
      K = 0
   50 CONTINUE
      K = K+1
      IF (K.GT.8) GOTO 140
      IF (IJ(N-1,K).NE.IJ2) GOTO 50
      IF (IV(N-1,K).NE.IV2) GOTO 50
      KP = K
C-----------------------------------------------------------------------
C
C  3.0 compute coefficients
C
C  3.1 table look-up
C
      GOTO (60,60,70,110),N
C
   60 CONTINUE
      COEFP = ONE
      GOTO 120
C
   70 CONTINUE
      COEFP = NUM3(KD,KP)
      DENOM = NORM3(KD)
   80 CONTINUE
      IF (COEFP) 100,130,90
   90 CONTINUE
      COEFP = SQRT(COEFP/DENOM)
      GOTO 120
C
  100 CONTINUE
      COEFP = -SQRT(-COEFP/DENOM)
      GOTO 120
C
  110 CONTINUE
      COEFP = NUM4(KD,KP)
      DENOM = NORM4(KD)
      GOTO 80
C
C  3.2 insert additional factors for hole states
C
  120 CONTINUE
      IF (NEL.LE.4) GOTO 130
      DNEL = DBLE(NEL)
      FACT = ((NINE-DNEL)/DNEL)*(ONE+IJP)/(ONE+IJD)
      COEFP = COEFP*SQRT(FACT)
      IS = ABS((IJD-IJP-IVD+IVP)/2-3)
      IF (MOD(IS,2).EQ.0) GOTO 130
      COEFP = -COEFP
  130 CONTINUE
      RETURN
C-----------------------------------------------------------------------
C
C  4.0 fault mode section
C
  140 CONTINUE
      COEFP = ZERO
      WRITE (IWRITE,3000) NEL,IJD,IVD,IJP,IVP
      STOP
C
 3000 FORMAT (' ERROR in trying to compute CFP for a state with ',I4,   !
     +' electrons with J = 7/2'/' Parameters ',4I6)
      END
C
C                             *******************
C
      SUBROUTINE CFPD(LOCK,NEL,COEFP)
C
C-----------------------------------------------------------------------
C
C  This is a dummy subroutine. It returns correct values for 1 or 2
C  particle or single hole states, and signals an error otherwise.
C
C  No subroutines called.
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
C
C  Parameter variables
C
      DOUBLE PRECISION ONE
      PARAMETER (ONE=1.D0)
      DOUBLE PRECISION ZERO
      PARAMETER (ZERO=0.D0)
C
C  Argument variables
C
      DOUBLE PRECISION COEFP
      INTEGER LOCK,NEL
C
C  Local variables
C
      INTEGER LOCJ
C
C  Common variables
C
      INTEGER IPUNCH,IREAD,IWRITE
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
      IF (NEL.EQ.1) GOTO 10
      IF (NEL.EQ.2) GOTO 10
      IF (NEL.EQ.ABS(LOCK)) GOTO 10
C
      COEFP = ZERO
      LOCJ = ABS(LOCK)-1
      WRITE (IWRITE,3000) LOCJ
      STOP
C
   10 CONTINUE
      COEFP = ONE
C-----------------------------------------------------------------------
 3000 FORMAT (                                                          !
     +' Inadmissable attempt to obtain CFP for a state of the shell wi',!
     +'th J = ',I4,'/2'/' New subprogram required')
      END
C
C                             *******************
C
      SUBROUTINE CLEBGOR(XJ1,XJ2,XM1,XM2,XJ3,XM3,CG,IER)      
C-----------------------------------------------------------------------
C
C
C-----------------------------------------------------------------------
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      IMPLICIT NONE
C
C  PARAMETER VARIABLES
C
      DOUBLE PRECISION ZERO
      PARAMETER (ZERO=0.D0)
      DOUBLE PRECISION ONE
      PARAMETER (ONE=1.D0)
      DOUBLE PRECISION TWO
      PARAMETER (TWO=2.D0)
      INTEGER IFAK
      PARAMETER (IFAK=500)
C
C  ARGUMENT VARIABLES
C
      DOUBLE PRECISION CG,XJ1,XJ2,XJ3
      DOUBLE PRECISION XM1,XM2,XM3
      INTEGER IER
C
C  LOCAL VARIABLES
C
      DOUBLE PRECISION AI,BIP1,CONST,SUM
      DOUBLE PRECISION FAK(IFAK)
      DOUBLE PRECISION X
      INTEGER I,IA,IB,IC
      INTEGER ID,IE,IG,J
      INTEGER J1,J2,J3,JX
      INTEGER JY,JZ,KMAX,KMIN
      INTEGER L,L1,L2,L3
      INTEGER M,M1,M2,M3
      INTEGER N,N1,N10,N11
      INTEGER N2,N3,N4,N5
      INTEGER N6,N7,N8
      INTEGER K
      LOGICAL FIRST
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      SAVE FAK
      SAVE FIRST
      DATA FIRST/.TRUE./
C-----------------------------------------------------------------------
C
C   CALCULATE LOG OF FACTORIALS (0..........500) TO THE BASE E
C
C-----------------------------------------------------------------------
      IF (FIRST) THEN
        FAK(1) = ZERO
        FAK(2) = ZERO
        DO K = 3,500
          N = K-1
          X = N
          FAK(K) = FAK(N)+LOG(X)
        ENDDO
        FIRST = .FALSE.
      ENDIF
C-----------------------------------------------------------------------
      CG = ZERO
      IER = 0
C
      J1 = NINT(TWO*XJ1)
      J2 = NINT(TWO*XJ2)
      J3 = NINT(TWO*XJ3)
      M1 = NINT(TWO*XM1)
      M2 = NINT(TWO*XM2)
      M3 = NINT(TWO*XM3)
      J = (J1+J2+J3)/2
      M = (M1+M2-M3)/2
      JX = (-J1+J2+J3)/2
      JY = (J1-J2+J3)/2
      JZ = (J1+J2-J3)/2
C
C   **********    CHECK OF THE COUPLING RULES    **********
C
      IF ((J1.LT.0) .OR. (J2.LT.0) .OR. (J3.LT.0) .OR. (JX.LT.0) .OR.(JY!
     +.LT.0) .OR. (JZ.LT.0) .OR. ((J1-ABS(M1)).LT.0) .OR.((J2-ABS(M2)).L!
     +T.0) .OR. ((J3-ABS(M3)).LT.0) .OR.(MOD(J1,2).NE.MOD(ABS(M1),2)) .O!
     +R.(MOD(J2,2).NE.MOD(ABS(M2),2)) .OR.(MOD(J3,2).NE.MOD(ABS(M3),2)) !
     +.OR.(MOD(J1+J2,2).NE.MOD(J3,2)) .OR. (M.NE.0)) THEN
        IER = 1
        RETURN
      ENDIF
C
C   **********   CALCULATION OF SPECIAL VALUES   **********
C
      IF ((J1.EQ.0) .OR. (J2.EQ.0)) THEN
        CG = ONE
        RETURN
      ENDIF
C
      IF (J3.EQ.0) THEN
        CG = ONE/SQRT(TWO*XJ1+ONE)
        N = (J1-M1)/2
        IF (MOD(N,2).EQ.1) CG = -CG
        RETURN
      ENDIF
C
      IF ((M1.EQ.0) .AND. (M2.EQ.0)) THEN
        IF (MOD(J,2).EQ.1) RETURN
        N10 = J/2
        L1 = J1/2
        L2 = J2/2
        L3 = J3/2
        N11 = (L1+L2-L3)/2
        CG = (TWO*XJ3+ONE)*EXP(FAK(JX+1)+FAK(JY+1)+FAK(JZ+1)-FAK(J+2)+TW!
     +O*(FAK(N10+1)-FAK(N10-L1+1)-FAK(N10-L2+1)-FAK(N10-L3+1)))
        CG = SQRT(CG)
        IF (MOD(N11,2).EQ.1) CG = -CG
        RETURN
      ENDIF
C
C   **********   CALCULATION OF THE GENERAL CASE   **********
C
      N1 = (J1+M1)/2
      N2 = (J1-M1)/2
      N3 = (J2+M2)/2
      N4 = (J2-M2)/2
      N5 = (J3+M3)/2
      N6 = (J3-M3)/2
      N7 = (J2-J3-M1)/2
      N8 = (J1-J3+M2)/2
      KMIN = MAX(0,N7,N8)
      KMAX = MIN(JZ,N2,N3)
      L = KMIN
      CONST = FAK(N1+1)+FAK(N2+1)+FAK(N3+1)+FAK(N4+1)+FAK(N5+1)+FAK(N6+1!
     +)+FAK(JX+1)+FAK(JY+1)+FAK(JZ+1)-FAK(J+2)-TWO*(FAK(JZ-L+1)+FAK(N2-L!
     ++1)+FAK(N3-L+1)+FAK(L-N7+1)+FAK(L-N8+1)+FAK(L+1))
      N = KMAX-KMIN+1
      I = N-1
      SUM = ONE
      IA = JZ-L
      IB = N2-L
      IC = N3-L
      ID = L+1-N7
      IE = L+1-N8
      IG = L+1
C
   10 CONTINUE
      AI = (IA-I)*(IB-I)*(IC-I)
      BIP1 = (ID+I)*(IE+I)*(IG+I)
      SUM = ONE-AI*SUM/BIP1
      I = I-1
      IF (I.GE.0) GOTO 10
C
      CG = SQRT((TWO*XJ3+ONE)*EXP(CONST))*SUM
      IF (MOD(L,2).EQ.1) CG = -CG
C
      END
C
C                             *******************
C
      FUNCTION CLRX(KAP1,K,KAP2)
C
C-----------------------------------------------------------------------
C
C   The value of CLRX is the 3-J symbol
C
C            J1      K        J2
C           0.5      0      -0.5
C
C   KAP1 = kappa value for J1
C   KAP2 = kappa value for J2
C
C   Triangular conditions are tested in code.
C
C   SEE : Angular Momentum (second edition)
C         by Brink and Satchler
C              Page 138
C
C  No subroutines called.
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      DOUBLE PRECISION CLRX
C
C  Parameter variables
C
      DOUBLE PRECISION ZERO
      PARAMETER (ZERO=0.D0)
      DOUBLE PRECISION ONE
      PARAMETER (ONE=1.D0)
C
C  Argument variables
C
      INTEGER K,KAP1,KAP2
C
C  Local variables
C
      DOUBLE PRECISION X,Y
      INTEGER I,IP,IPHASE,IX
      INTEGER J,JM,JP,JQ
      INTEGER KMA,KMB
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
      KMA = ABS(KAP1)
      KMB = ABS(KAP2)
      JP = KMA+KMB-1
      JM = KMA-KMB
      X = ONE/(KMA*KMB)
C
      IX = JP-K
      J = 1
      GOTO 90
C
   10 CONTINUE
      IX = JP+K+1
      J = 1
      GOTO 100
C
   20 CONTINUE
      IX = JM+K
      J = 2
      GOTO 90
C
   30 CONTINUE
      IX = K-JM
      J = 3
      GOTO 90
C
   40 CONTINUE
      Y = SQRT(X)
      IP = K
      JQ = JP+K
      IF (MOD(JQ,2).NE.0) THEN
        Y = -Y
        IP = K+1
      ENDIF
C
      X = ONE
      IX = (IP+JP)/2
      J = 4
      GOTO 90
C
   50 CONTINUE
      IX = (JP-IP)/2
      J = 2
      GOTO 100
C
   60 CONTINUE
      IX = (JM+IP-1)/2
      J = 3
      GOTO 100
C
   70 CONTINUE
      IX = (IP-1-JM)/2
      J = 4
      GOTO 100
C
   80 CONTINUE
      CLRX = Y*X
      IPHASE = (JP+IP-2)/2
      IF (MOD(IPHASE,2).EQ.1) CLRX = -CLRX
      RETURN
C-----------------------------------------------------------------------
   90 CONTINUE
      IF (IX.LT.0) GOTO 110
      IF (IX.GT.0) THEN
        DO I = 1,IX
          X = X*DBLE(I)
        ENDDO
      ENDIF
C
      IF (J.EQ.1) GOTO 10
      IF (J.EQ.2) GOTO 30
      IF (J.EQ.3) GOTO 40
      GOTO 50
C-----------------------------------------------------------------------
  100 CONTINUE
      IF (IX.LT.0) GOTO 110
      IF (IX.GT.0) THEN
        DO I = 1,IX
          X = X/DBLE(I)
        ENDDO
      ENDIF
C
      IF (J.EQ.1) GOTO 20
      IF (J.EQ.2) GOTO 60
      IF (J.EQ.3) GOTO 70
      GOTO 80
C-----------------------------------------------------------------------
  110 CONTINUE
      CLRX = ZERO
C
      END
C
C                             *******************
C
      SUBROUTINE CORD(JA1,IPCA,JB1)
C
C-----------------------------------------------------------------------
C
C   Computes the MCP coefficients for contributions
C   involving closed shells. The standard formulae are given in
C   I.P.Grant. Advances in Physics (1970), vol.19, p.747, eq.(8.33).
C
C   JA1,JB1 point to the JLIST array,
C   IA1,IB1 point to the full list of orbitals.
C
C  Subroutines called: CLRX, SPEAK, BREID
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  External functions
C
      EXTERNAL CLRX
      DOUBLE PRECISION CLRX
C
C  Parameter variables
C
      DOUBLE PRECISION EPS10
      PARAMETER (EPS10=1.D-10)
      INTEGER NPLX
      PARAMETER (NPLX=14)
C
C  Argument variables
C
      INTEGER IPCA,JA1,JB1
C
C  Local variables
C
      DOUBLE PRECISION CONST,GAM,X
      INTEGER IA1,IB1,ISG,ITYPE
      INTEGER J1,J2,KAP1,KAP2
      INTEGER NQS1,NQS2,NS,NU
      INTEGER NUMAX,NUMIN
C
C  Common variables
C
      INTEGER IBREIT,ICOUL,IEXCH
      COMMON / ANG01  / ICOUL,IBREIT,IEXCH
C
C  Common variables
C
      INTEGER IME,JA,JB,NWA
      COMMON / ANG04  / IME,JA,JB,NWA
C
C  Common variables
C
      INTEGER ICORE(MXNW)
      COMMON / ANG05  / ICORE
C
C  Common variables
C
      INTEGER NQ1(MXNW),NQ2(MXNW)
      COMMON / ANG11  / NQ1,NQ2
C
C  Common variables
C
      INTEGER JLIST(NPLX),KLIST(MXNW),NCORE,NPEEL
      COMMON / ANG13  / JLIST,KLIST,NPEEL,NCORE
C
C  Common variables
C
      INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF
      INTEGER NP(MXNW),NW
      COMMON / ORB04  / NW,NCF,NP,NAK,IQ
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
      IF (IBREIT.EQ.1) CALL BREID(JA1,IPCA,JB1)
      IF (ICOUL.EQ.0) RETURN
C-----------------------------------------------------------------------
C
C   Set quantum numbers required.
C
C-----------------------------------------------------------------------
      IF (IPCA.EQ.2) THEN
        IA1 = KLIST(JA1)
      ELSE
        IA1 = JLIST(JA1)
      ENDIF
      IB1 = KLIST(JB1)
      IF (IA1.LE.IB1) GOTO 10
      NS = IA1
      IA1 = IB1
      IB1 = NS
C
   10 CONTINUE
      ISG = 1
      IF (JA.NE.JB) GOTO 20
      IF (ICORE(IA1).EQ.0 .OR. ICORE(IB1).EQ.0) GOTO 20
      IF (JA.GT.1) RETURN
      ISG = -1
C
   20 CONTINUE
      KAP1 = NAK(IA1)
      J1 = ABS(KAP1)
      NQS1 = NQ1(IA1)
C
      IF (IA1.EQ.IB1) THEN
C-----------------------------------------------------------------------
C
C  Case when IA1=IB1
C
C-----------------------------------------------------------------------
        X = DBLE(NQS1*(NQS1-1)/2)
        ITYPE = ISG*8
        CALL SPEAKG(1,ITYPE,IA1,IB1,IA1,IB1,0,X)
        NUMAX = J1+J1-2
        IF (NUMAX.LE.0) RETURN
        CONST = DBLE(NQS1*NQS1/2)
        DO NU = 2,NUMAX,2
          GAM = CLRX(KAP1,NU,KAP1)
          X = -CONST*GAM*GAM
          IF (ABS(X).LT.EPS10) GOTO 30
          CALL SPEAKG(1,ITYPE,IA1,IB1,IA1,IB1,NU,X)
   30     CONTINUE
        ENDDO
C
      ELSE
C-----------------------------------------------------------------------
C
C  Case when IA1<>IB1
C
C-----------------------------------------------------------------------
        KAP2 = NAK(IB1)
        J2 = ABS(KAP2)
        NQS2 = NQ1(IB1)
        CONST = DBLE(NQS1*NQS2)
        ITYPE = ISG*8
        CALL SPEAKG(1,ITYPE,IA1,IB1,IA1,IB1,0,CONST)
        NUMIN = ABS(J1-J2)
        NUMAX = J1+J2-1
        IF (KAP1*KAP2.LT.0) NUMIN = NUMIN + 1
        ITYPE = ISG*9
        DO NU = NUMIN,NUMAX,2
          GAM = CLRX(KAP1,NU,KAP2)
          X = -CONST*GAM*GAM
          IF (ABS(X).LT.EPS10) GOTO 40
          CALL SPEAKG(1,ITYPE,IA1,IB1,IB1,IA1,NU,X)
   40     CONTINUE
        ENDDO
      ENDIF
C-----------------------------------------------------------------------
      END
C
C                             *******************
C
      SUBROUTINE CORG(JA1,JB1,JA2,JB2)
C
C-----------------------------------------------------------------------
C
C  Computes the MCP/MCBP coefficients.
C
C  Subroutines called: CRE,GENSUM,ITRIG,LTAB,MODJ23,
C                      MUMDAD,NJSYM,OCON,SETJ,SKRC,SPEAK,
C                      CXK,SNRC
C
C  Equations refer to  CPC 5,263(1973)
C
C-----------------------------------------------------------------------
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      LOGICAL FREE
      LOGICAL FAILD,FAILE
C
      PARAMETER (MANGM = 60)
      PARAMETER (MTRIAD=20)
      PARAMETER (M3MNGM = 3*MANGM)
      PARAMETER (M6J = 20)
      COMMON / NJS00  / J6C,J7C,J8C,JWC
      COMMON / NJS01  / J6(M3MNGM),J7(M3MNGM),J8(M3MNGM),
     +JW(6,M6J)
      COMMON / NJS02  / ICOUNT,J2TEST(MTRIAD),J3TEST(MTRIAD)
      DIMENSION JD6(M3MNGM),JD7(M3MNGM),JD8(M3MNGM),
     +JDW(6,M6J),J2TSTD(MTRIAD),J3TSTD(MTRIAD)
      DIMENSION JE6(M3MNGM),JE7(M3MNGM),JE8(M3MNGM),
     +JEW(6,M6J),J2TSTE(MTRIAD),J3TSTE(MTRIAD)
C
      INCLUDE 'grasp0.inc'
      PARAMETER (NPLX=14)
      PARAMETER (IDIM=20)
C
      COMMON / ANG00  / MMOM,NMOM,J1(MANGM),J2(MTRIAD,3),J3(MTRIAD,3),  !
     +                  FREE(MANGM)
      COMMON / ANG01  / ICOUL,IBREIT,IEXCH
      COMMON / ANG08  / JBQ1(3,MXNW),JBQ2(3,MXNW),JTQ1(3),JTQ2(3)
      COMMON / ANG11  / NQ1(MXNW),NQ2(MXNW)
      COMMON / ANG12  / JJQ1(3,MXNW),JJQ2(3,MXNW)
      COMMON / ANG13  / JLIST(NPLX),KLIST(MXNW),NPEEL,NCORE
      COMMON / DEBUG  / IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
      COMMON / ORB04  / NW,NCF,NP(MXNW),NAK(MXNW),IQ(MXNW,MXNC)
      COMMON / TERMS  / NROWS,ITAB(16),JTAB(16),NTAB(255)
C
      DIMENSION COND(IDIM),CONE(IDIM)
      DIMENSION BOND(12,IDIM),BONE(12,IDIM),S(12)
      DIMENSION KAPS(4),KS(4),NQS(4),ILS(4),LLS(4),IROWS(4),IS(4),JS(4)
C
      PARAMETER (EPS10=1.D-10)
      PARAMETER (ZERO=0.D0)
      PARAMETER (HALF=.5D0)
C-----------------------------------------------------------------------
C
C  Initialize pointers and flags and set any tables required.
C
C  The array IS points to the full list of orbitals,
C  the array JS to the array, JLIST, of peel orbital pointers.
C
C  Initialization.
C
C-----------------------------------------------------------------------
      JS(1) = JA1
      JS(2) = JB1
      JS(3) = JA2
      JS(4) = JB2
C
      DO I = 1,4
        IS(I) = JLIST(JS(I))
        KAPS(I) = 2*NAK(IS(I))
        KS(I) = ABS(KAPS(I))
      ENDDO
C
      IA1 = IS(1)
      IB1 = IS(2)
      IA2 = IS(3)
      IB2 = IS(4)
C
      KJ23 = 0
      ISNJ = 0
C
      FAILD = .FALSE.
      FAILE = .FALSE.
C-----------------------------------------------------------------------
C
C  Initialize arrays.
C
      DO J = 1,NW
        DO K = 1,3
          JBQ1(K,J) = 0
          JBQ2(K,J) = 0
        ENDDO
      ENDDO
C
      NBRJ = 3*NPEEL+7
C-----------------------------------------------------------------------
C
C  Set tables of quantum numbers of spectator shells.
C
      DO JJ = 1,NPEEL
C
        J = JLIST(JJ)
        IF ((J.EQ.IA1) .OR. (J.EQ.IB1)) GOTO 10
        DO K = 1,3
          JBQ1(K,J) = JJQ1(K,J)
        ENDDO
   10   CONTINUE
        IF ((J.EQ.IA2) .OR. (J.EQ.IB2)) GOTO 20
        DO K = 1,3
          JBQ2(K,J) = JJQ2(K,J)
        ENDDO
C
C  Examine quantum numbers of spectator shells for orthogonality
C  and exit if found.
C
        IF (J.EQ.IA1 .OR. J.EQ.IB1 .OR. J.EQ.IA2 .OR.J.EQ.IB2) GOTO 20
C
        DO K = 1,3
          IF (JBQ1(K,J).NE.JBQ2(K,J)) THEN
            IF (IBUG2.EQ.1) WRITE (IWRITE,3000)
            RETURN
          ENDIF
        ENDDO
C
   20   CONTINUE
      ENDDO
C
      IF (IBUG2.EQ.1) WRITE (IWRITE,3010) IA1,IB1,IA2,IB2
C-----------------------------------------------------------------------
C
C  Set range of the parameter K for coulomb integrals.
C  Terminate run if buffer store dimension IDIM is too small.
C
      IF (ICOUL.EQ.1) THEN
        CALL SKRCG(IS,KAPS,KS,KCD1,KCD2,KCE1,KCE2)
        IF (IEXCH.EQ.-1) THEN
          KCD2 = 0
        ELSE
          IF (IEXCH.EQ.1) THEN
            KCE2 = 0
          ENDIF
        ENDIF
      ELSE
        KCD1 = 0
        KCD2 = 0
        KCE1 = 0
        KCE2 = 0
      ENDIF
C
      IF (IBUG2.EQ.1) WRITE (IWRITE,3020) KCD1,KCD2,KCE1,KCE2
C
      IF (KCD2.GT.IDIM .OR. KCE2.GT.IDIM) THEN
        KK = MAX(KCD2,KCE2)
        WRITE (IWRITE,3030) KK
        WRITE (IPUNCH,3030) KK
        STOP
      ENDIF
C
      IF (KCD2.GT.0) THEN
        DO K = 1,KCD2
          COND(K) = ZERO
        ENDDO
      ENDIF
C
      IF (KCE2.GT.0) THEN
        DO K = 1,KCE2
          CONE(K) = ZERO
        ENDDO
      ENDIF
C-----------------------------------------------------------------------
C
C  Set range of the parameter K for Breit integrals.
C  Terminate run if buffer store dimension IDIM is too small.
C
      IF (IBREIT.EQ.1) THEN
        CALL SNRC(IS,KAPS,KS,KBD1,KBD2,KBE1,KBE2,IBRD,IBRE)
      ELSE
        KBD1 = 0
        KBD2 = 0
        KBE1 = 0
        KBE2 = 0
        IBRD = -1
        IBRE = -1
      ENDIF
C
      IF (IBUG2.EQ.1) WRITE (IWRITE,3040) KBD1,KBD2,KBE1,KBE2,IBRD,IBRE
C
      IF (KCD2.EQ.0 .AND. KCE2.EQ.0 .AND. IBRD.LT.0 .AND.IBRE.LT.0) RETU!
     +RN
C
      IF (KBD2.GT.IDIM .OR. KBE2.GT.IDIM) THEN
        KK = MAX(KBD2,KBE2)
        WRITE (IWRITE,3050) KK
        WRITE (IPUNCH,3050) KK
        STOP
      ENDIF
C
      IF (IBRD.GE.0) THEN
        DO K = 1,KBD2
          DO MU = 1,12
            BOND(MU,K) = ZERO
          ENDDO
        ENDDO
      ENDIF
C
      IF (IBRE.GE.0) THEN
        DO K = 1,KBE2
          DO MU = 1,12
            BONE(MU,K) = ZERO
          ENDDO
        ENDDO
      ENDIF
C-----------------------------------------------------------------------
      NQS(1) = NQ1(IA1)
      NQS(2) = NQ1(IB1)
      NQS(3) = NQ2(IA2)
      NQS(4) = NQ2(IB2)
C-----------------------------------------------------------------------
C
C  Set parameters of summation over parent (barred) terms in eq.(5).
C  The array IROWS is formed to point at the list of allowed
C  parents of active shells in the array NTAB.
C
      CALL LTAB(IS,NQS,KS,IROWS)
C
      DO I = 1,4
        II = IROWS(I)
        LLS(I) = ITAB(II)
        ILS(I) = JTAB(II)
      ENDDO
C
      IF (IBUG2.EQ.1) THEN
        WRITE (IWRITE,3060) (NQS(I),I=1,4)
        WRITE (IWRITE,3070) (LLS(I),I=1,4)
        WRITE (IWRITE,3080) (ILS(I),I=1,4)
      ENDIF
C-----------------------------------------------------------------------
C
C  Sum contributions over all parent terms permitted by angular
C  momentum and seniority selection rules.
C
      LLS1 = LLS(1)
      LLS2 = LLS(2)
      LLS3 = LLS(3)
      LLS4 = LLS(4)
C
      LS2 = ILS(2)
      DO LB1 = 1,LLS2
        LS2 = LS2+3
        IT12 = NTAB(LS2)
        IT2 = KS(2)
        IT3 = JJQ1(3,IB1)
        IF (ITRIG(IT12,IT2,IT3).EQ.0) GOTO 140
        IF (ABS(NTAB(LS2-2)-JJQ1(1,IB1)).NE.1) GOTO 140
C
        LS1 = ILS(1)
        DO LA1 = 1,LLS1
          LS1 = LS1+3
          IT11 = NTAB(LS1)
          IT2 = KS(1)
C
          IF (IA1.EQ.IB1) THEN
            IT3 = IT12
            IF (ITRIG(IT11,IT2,IT3).EQ.0) GOTO 130
            IF (ABS(NTAB(LS1-2)-NTAB(LS2-2)).NE.1) GOTO 130
          ELSE
            IT3 = JJQ1(3,IA1)
            IF (ITRIG(IT11,IT2,IT3).EQ.0) GOTO 130
            IF (ABS(NTAB(LS1-2)-JJQ1(1,IA1)).NE.1) GOTO 130
          ENDIF
C
          LS4 = ILS(4)
          DO LB2 = 1,LLS4
            LS4 = LS4+3
            IT14 = NTAB(LS4)
            IT2 = KS(4)
            IT3 = JJQ2(3,IB2)
            IF (ITRIG(IT14,IT2,IT3).EQ.0) GOTO 120
            IF (ABS(NTAB(LS4-2)-JJQ2(1,IB2)).NE.1) GOTO 120
C
            LS3 = ILS(3)
            DO LA2 = 1,LLS3
              LS3 = LS3+3
              IT13 = NTAB(LS3)
              IT2 = KS(3)
C
              IF (IA2.EQ.IB2) THEN
                IT3 = IT14
                IF (ITRIG(IT13,IT2,IT3).EQ.0) GOTO 110
                IF (ABS(NTAB(LS3-2)-NTAB(LS4-2)).NE.1) GOTO 110
              ELSE
                IT3 = JJQ2(3,IA2)
                IF (ITRIG(IT13,IT2,IT3).EQ.0) GOTO 110
                IF (ABS(NTAB(LS3-2)-JJQ2(1,IA2)).NE.1) GOTO 110
              ENDIF
C
              IF (IBUG2.EQ.1) WRITE (IWRITE,3090) LS1,LS2,LS3,LS4
C-----------------------------------------------------------------------
C
C  The current parent has been completely defined, and its quantum
C  numbers can now be set. The JTQ arrays must be set if IA1=IB1 or
C  IA2=IB2. The matrix element should be diagonal in barred quantum
C  numbers.
C
C-----------------------------------------------------------------------
              DO K = 1,3
C
                JBQ1(K,IA1) = NTAB(LS1+K-3)
                JBQ2(K,IA2) = NTAB(LS3+K-3)
C
                JTQ1(K) = 0
C
                IF (IB1.EQ.IA1) THEN
                  JTQ1(K) = NTAB(LS2+K-3)
                ELSE
                  JBQ1(K,IB1) = NTAB(LS2+K-3)
                ENDIF
C
                JTQ2(K) = 0
C
                IF (IB2.EQ.IA2) THEN
                  JTQ2(K) = NTAB(LS4+K-3)
                ELSE
                  JBQ2(K,IB2) = NTAB(LS4+K-3)
                ENDIF
C
              ENDDO
C
              IF (IBUG2.EQ.1) WRITE (IWRITE,3100) (IS(KK),(JBQ1(K,IS(KK)!
     +),K=1,3), (JBQ2(K,IS(KK)),K=1,3),KK=1,4)
C
              DO K = 1,3
                DO KK = 1,4
                  IF (JBQ1(K,IS(KK)).NE.JBQ2(K,IS(KK))) GOTO 110
                ENDDO
              ENDDO
C-----------------------------------------------------------------------
C
C  Evaluate product of 4 CFP'S, eq.(5).
C
              CALL MUMDAD(IS,KAPS,PROD)
              IF (ABS(PROD).LT.EPS10) GOTO 110
C-----------------------------------------------------------------------
C
C  Set arrays for defining the recoupling coefficient.
C
              CALL SETJ(IS,JS,KS,NPEEL,KJ23)
C
              IF (ISNJ.NE.0) GOTO 40
C-----------------------------------------------------------------------
C
C  Set up arrays and variables for direct case.
C
C  J1(NBRJ) ( = J1(M) ) is set to (2*KCD1+1) so that NJSYM is
C  called correctly.
C
              IF (KCD2.EQ.0 .AND. IBRD.LT.0) GOTO 30
C
              IF (KCD2.GT.0) THEN
                J1(NBRJ) = KCD1+KCD1+1
              ELSE
                J1(NBRJ) = KBD1+KBD1+1
              ENDIF
C
      CALL NJSYM (RECUP,-1,FAILD)
C
              ISNJ = 1
              IF (FAILD) GOTO 30
C-----------------------------------------------------------------------
C
C  Store data for future calls in direct case.
C
      JD6C=J6C
      JD7C=J7C
      JD8C=J8C
      JDWC=JWC
      ICNTD=ICOUNT
      IF (J6C.NE.0) THEN
        DO I=1,J6C
          JD6(I)=J6(I)
        ENDDO
      ENDIF
      IF (J7C.NE.0) THEN
        DO I=1,J7C
          JD7(I)=J7(I)
        ENDDO
      ENDIF
      IF (J8C.NE.0) THEN
        DO I=1,J8C
          JD8(I)=J8(I)
        ENDDO
      ENDIF
      IF (JWC.NE.0) THEN
        DO I=1,6
          DO J=1,JWC
            JDW(I,J)=JW(I,J)
          ENDDO
        ENDDO
      ENDIF
      IF (ICOUNT.NE.0) THEN
        DO I=1,ICOUNT
          J2TSTD(I)=J2TEST(I)
          J3TSTD(I)=J3TEST(I)
        ENDDO
      ENDIF
C-----------------------------------------------------------------------
C
C  Set up arrays and variables for exchange case.
C
C  J1(NBRJ) ( = J1(M) ) is set to (2*KCE1+1) so that NJSYM is
C  called correctly.
C
   30         CONTINUE
              IF (KCE2.EQ.0 .AND. IBRE.LT.0) GOTO 40
C
              CALL MODJ23
C
              IF (KCE2.GT.0) THEN
                J1(NBRJ) = KCE1+KCE1+1
              ELSE
                J1(NBRJ) = KBE1+KBE1+1
              ENDIF
C
      CALL NJSYM (RECUP,-1,FAILE)
C
              ISNJ = 2
C
              IF (FAILE) GOTO 40
C-----------------------------------------------------------------------
C
C  Store data for future calls in exchange case.
C
      JE6C=J6C
      JE7C=J7C
      JE8C=J8C
      JEWC=JWC
      ICNTE=ICOUNT
      IF (J6C.NE.0) THEN
        DO I=1,J6C
          JE6(I)=J6(I)
        ENDDO
      ENDIF
      IF (J7C.NE.0) THEN
        DO I=1,J7C
          JE7(I)=J7(I)
        ENDDO
      ENDIF
      IF (J8C.NE.0) THEN
        DO I=1,J8C
          JE8(I)=J8(I)
        ENDDO
      ENDIF
      IF (JWC.NE.0) THEN
        DO I=1,6
          DO J=1,JWC
            JEW(I,J)=JW(I,J)
          ENDDO
        ENDDO
      ENDIF
      IF (ICOUNT.NE.0) THEN
        DO I=1,ICOUNT
          J2TSTE(I)=J2TEST(I)
          J3TSTE(I)=J3TEST(I)
        ENDDO
      ENDIF
C-----------------------------------------------------------------------
C
C  COULOMB
C  Calculate recoupling coefficients for direct cases.
C  Calculate AD, eq.(6), without the phase factor
C
C-----------------------------------------------------------------------
   40         CONTINUE
              IF ((KCD2.NE.0) .AND. (.NOT.FAILD)) THEN
                KK = KCD1-2
                DO K = 1,KCD2
                  KK = KK+2
                  J1(MMOM) = KK+KK+1
                  CALL GENSUM (JD6C,JD7C,JD8C,JDWC,JD6,JD7,JD8,JDW,
     +                         ICNTD,J2TSTD,J3TSTD,X)
                  IF (IBUG2.EQ.1) WRITE (IWRITE,3110) KK,X
                  COND(K) = COND(K)+X*PROD
                ENDDO
              ENDIF
C-----------------------------------------------------------------------
C
C  COULOMB
C  Calculate recoupling coefficients for exchange cases.
C  Calculate AE, eq.(6), without the phase factor
C
C-----------------------------------------------------------------------
              IF ((KCE2.NE.0) .AND. (.NOT.FAILE)) THEN
                KK = KCE1-2
                DO K = 1,KCE2
                  KK = KK+2
                  J1(MMOM) = KK+KK+1
                  CALL GENSUM (JE6C,JE7C,JE8C,JEWC,JE6,JE7,JE8,JEW,
     +                         ICNTE,J2TSTE,J3TSTE,X)
                  IF (IBUG2.EQ.1) WRITE (IWRITE,3120) KK,X
                  CONE(K) = CONE(K)+X*PROD
                ENDDO
              ENDIF
C-----------------------------------------------------------------------
C
C  BREIT
C  Calculate recoupling coefficients for direct cases.
C
C-----------------------------------------------------------------------
              IF ((IBRD.GE.0) .AND. (.NOT.FAILD)) THEN
C
                IF (IBRD.GT.1) THEN
                  IMUD = 1
                ELSE
                  IMUD = 4
                ENDIF
C
                NCODE = 0
C======================================================
                DO NN = 1,KBD2
C
                  NU = KBD1+2*(NN-1)
                  NUD = NU+NU+1
C
                  IF (NU.EQ.0) GOTO 60
C
                  IF (ITRIG(KS(1),KS(3),NUD).EQ.0) GOTO 50
                  IF (ITRIG(KS(2),KS(4),NUD).EQ.0) GOTO 50
                  K = NU
                  J1(MMOM) = NUD
C
                  CALL GENSUM (JD6C,JD7C,JD8C,JDWC,JD6,JD7,JD8,JDW,
     +                         ICNTD,J2TSTD,J3TSTD,X)
C
                  IF (IBUG2.EQ.1) WRITE (IWRITE,3130) NU,K,X
C
                  IF (ABS(X).GE.EPS10) THEN
                    X = X*PROD
                    CALL CXK(S,IS,KAPS,NU,K,IBRD,1)
                    IF (IBUG2.EQ.1) WRITE (IWRITE,3140) (S(III),III=1,IM!
     +UD)
                    DO MU = 1,IMUD
                      BOND(MU,NN) = BOND(MU,NN)+X*S(MU)
                    ENDDO
                  ENDIF
C++++++++++++++++++++++++++++++++++++++++++++++++++
   50             CONTINUE
                  IF (IBRD.GT.1) GOTO 70
                  K = NU-1
C
                  IF (NCODE.EQ.NN) THEN
                    X = XCODE
                  ELSE
                    ITKMO = NUD-2
                    IF (ITRIG(KS(1),KS(3),ITKMO).EQ.0) GOTO 60
                    IF (ITRIG(KS(2),KS(4),ITKMO).EQ.0) GOTO 60
                    J1(MMOM) = ITKMO
                    CALL GENSUM (JD6C,JD7C,JD8C,JDWC,JD6,JD7,JD8,JDW,
     +                           ICNTD,J2TSTD,J3TSTD,X)
                  ENDIF
C
                  IF (IBUG2.EQ.1) WRITE (IWRITE,3130) NU,K,X
C
                  IF (ABS(X).GE.EPS10) THEN
                    X = X*PROD
                    CALL CXK(S,IS,KAPS,NU,K,IBRD,1)
                    IF (IBUG2.EQ.1) WRITE (IWRITE,3140) (S(III),III=1,4)
                    DO MU = 1,4
                      BOND(MU,NN) = BOND(MU,NN)+X*S(MU)
                    ENDDO
                  ENDIF
C++++++++++++++++++++++++++++++++++++++++++++++++++
   60             CONTINUE
                  IF (IBRD.GT.1 .OR. NN.EQ.KBD2) GOTO 70
                  NCODE = NN+1
                  XCODE = ZERO
C
                  ITKMO = NUD+2
                  IF (ITRIG(KS(1),KS(3),ITKMO).EQ.0) GOTO 70
                  IF (ITRIG(KS(2),KS(4),ITKMO).EQ.0) GOTO 70
                  K = NU+1
                  J1(MMOM) = ITKMO
C
                  CALL GENSUM (JD6C,JD7C,JD8C,JDWC,JD6,JD7,JD8,JDW,
     +                         ICNTD,J2TSTD,J3TSTD,X)
                  XCODE = X
C
                  IF (IBUG2.EQ.1) WRITE (IWRITE,3130) NU,K,X
C
                  IF (ABS(X).GE.EPS10) THEN
                    X = X*PROD
                    CALL CXK(S,IS,KAPS,NU,K,IBRD,1)
                    IF (IBUG2.EQ.1) WRITE (IWRITE,3140) (S(III),III=1,12!
     +)
                    DO MU = 1,12
                      BOND(MU,NN) = BOND(MU,NN)+X*S(MU)
                    ENDDO
                  ENDIF
C++++++++++++++++++++++++++++++++++++++++++++++++++
   70             CONTINUE
                ENDDO
C
              ENDIF
C-----------------------------------------------------------------------
C
C  BREIT
C  Calculate recoupling coefficients for exchange cases.
C
C-----------------------------------------------------------------------
              IF ((IBRE.GE.0) .AND. (.NOT.FAILE)) THEN
                NCODE = 0
C
                DO NN = 1,KBE2
                  IMUE = 4
                  IF (IBRE.EQ.2) IMUE = 1
                  IF (IBRE.EQ.4) IMUE = 3
C
                  NU = KBE1+2*(NN-1)
                  NUD = NU+NU+1
C
                  IF (NU.EQ.0) GOTO 90
C
                  IF (ITRIG(KS(1),KS(4),NUD).EQ.0) GOTO 80
                  IF (ITRIG(KS(2),KS(3),NUD).EQ.0) GOTO 80
                  K = NU
                  J1(MMOM) = NUD
C
                  CALL GENSUM (JE6C,JE7C,JE8C,JEWC,JE6,JE7,JE8,JEW,
     +                         ICNTE,J2TSTE,J3TSTE,X)
C
                  IF (IBUG2.EQ.1) WRITE (IWRITE,3150) NU,K,X
C
                  IF (ABS(X).GE.EPS10) THEN
                    X = X*PROD
                    CALL CXK(S,IS,KAPS,NU,K,IBRE,2)
                    IF (IBUG2.EQ.1) WRITE (IWRITE,3140) (S(III),III=1,IM!
     +UE)
                    DO MU = 1,IMUE
                      BONE(MU,NN) = BONE(MU,NN)+X*S(MU)
                    ENDDO
                  ENDIF
C++++++++++++++++++++++++++++++++++++++++++++++++++
   80             CONTINUE
                  IF (IBRE.EQ.2) GOTO 100
C
                  IMUE = 4
                  IF (IBRE.EQ.4) IMUE = 3
                  K = NU-1
C
                  IF (NCODE.EQ.NN) THEN
                    X = XCODE
                  ELSE
                    ITKMO = NUD-2
                    IF (ITRIG(KS(1),KS(4),ITKMO).EQ.0) GOTO 90
                    IF (ITRIG(KS(2),KS(3),ITKMO).EQ.0) GOTO 90
                    J1(MMOM) = ITKMO
                    CALL GENSUM (JE6C,JE7C,JE8C,JEWC,JE6,JE7,JE8,JEW,
     +                           ICNTE,J2TSTE,J3TSTE,X)
                  ENDIF
C
                  IF (IBUG2.EQ.1) WRITE (IWRITE,3150) NU,K,X
C
                  IF (ABS(X).GE.EPS10) THEN
                    X = X*PROD
                    CALL CXK(S,IS,KAPS,NU,K,IBRE,2)
                    IF (IBUG2.EQ.1) WRITE (IWRITE,3140) (S(III),III=1,IM!
     +UE)
                    DO MU = 1,IMUE
                      BONE(MU,NN) = BONE(MU,NN)+X*S(MU)
                    ENDDO
                  ENDIF
C++++++++++++++++++++++++++++++++++++++++++++++++++
   90             CONTINUE
                  IF (IBRE.EQ.2 .OR. NN.EQ.KBE2) GOTO 100
C
                  NCODE = NN+1
                  XCODE = ZERO
C
                  IMUE = 12
                  IF (IBRE.EQ.4) IMUE = 7
C
                  ITKMO = NUD+2
                  IF (ITRIG(KS(1),KS(4),ITKMO).EQ.0) GOTO 100
                  IF (ITRIG(KS(2),KS(3),ITKMO).EQ.0) GOTO 100
                  K = NU+1
                  J1(MMOM) = ITKMO
C
                  CALL GENSUM (JE6C,JE7C,JE8C,JEWC,JE6,JE7,JE8,JEW,
     +                         ICNTE,J2TSTE,J3TSTE,X)
C
                  XCODE = X
C
                  IF (IBUG2.EQ.1) WRITE (IWRITE,3150) NU,K,X
C
                  IF (ABS(X).GE.EPS10) THEN
                    X = X*PROD
                    CALL CXK(S,IS,KAPS,NU,K,IBRE,2)
                    IF (IBUG2.EQ.1) WRITE (IWRITE,3140) (S(III),III=1,IM!
     +UE)
                    DO MU = 1,IMUE
                      BONE(MU,NN) = BONE(MU,NN)+X*S(MU)
                    ENDDO
                  ENDIF
C++++++++++++++++++++++++++++++++++++++++++++++++++
  100             CONTINUE
                ENDDO
C
              ENDIF
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
              IF (FAILD .AND. FAILE) GOTO 150
C-----------------------------------------------------------------------
  110         CONTINUE
            ENDDO
  120       CONTINUE
          ENDDO
  130     CONTINUE
        ENDDO
  140   CONTINUE
      ENDDO
C-----------------------------------------------------------------------
C
C  Insert factors independent of barred quantum numbers.
C  Output results.
C
C  Begin with common statistical factors, eq.(5).
C
C-----------------------------------------------------------------------
  150 CONTINUE
      CONST = OCON(IA1,IB1,IA2,IB2)
C
      IF (IBUG2.EQ.1) WRITE (IWRITE,3160) CONST
C
      KAP1 = NAK(IA1)
      KAP2 = NAK(IB1)
      KAP3 = NAK(IA2)
      KAP4 = NAK(IB2)
C-----------------------------------------------------------------------
C
C  Compute products of reduced matrix elements,eq.(7).
C
C  CRED for direct terms
C  CREE for exchange terms
C
C-----------------------------------------------------------------------
      IF (KCD2.GT.0) THEN
        PRODD = CONST/SQRT(DBLE(KS(1)*KS(4)))
        IF (MOD(KCD1,2).NE.0) PRODD = -PRODD
        IF (IA1.EQ.IB1 .AND. IA2.EQ.IB2) PRODD = PRODD*HALF
        KK = KCD1-2
        DO K = 1,KCD2
          KK = KK+2
          CRED = CRE(KAP1,KK,KAP3)*CRE(KAP2,KK,KAP4)
          X = PRODD*COND(K)*CRED
          IF (ABS(X).GT.EPS10) CALL SPEAKG(0,8,IA1,IB1,IA2,IB2,KK,X)
        ENDDO
      ENDIF
C
      IF (KCE2.GT.0) THEN
        PRODE = CONST/SQRT(DBLE(KS(1)*KS(3)))
        IF (MOD(KCE1,2).NE.0) PRODE = -PRODE
        PRODE = -PRODE
        KK = KCE1-2
        DO K = 1,KCE2
          KK = KK+2
          CREE = CRE(KAP1,KK,KAP4)*CRE(KAP2,KK,KAP3)
          X = PRODE*CONE(K)*CREE
          IF (ABS(X).GT.EPS10) CALL SPEAKG(0,9,IA1,IB1,IB2,IA2,KK,X)
        ENDDO
      ENDIF
C-----------------------------------------------------------------------
      IF (IBRD.GE.0) THEN
C
        PRODD = CONST/SQRT(DBLE(KS(1)*KS(4)))
        IF (IA1.EQ.IB1 .AND. IA2.EQ.IB2) PRODD = PRODD*HALF
        DO NN = 1,KBD2
          DO MU = 1,12
            BOND(MU,NN) = BOND(MU,NN)*PRODD
          ENDDO
        ENDDO
C======================================================
        DO NN = 1,KBD2
C
          NU = KBD1+2*(NN-1)
C
          IF (IBRD.EQ.2) THEN
            ITYPE = 3
            CALL SPEAKG(0,ITYPE,IA1,IA2,IB1,IB2,NU,BOND(1,NN))
            GOTO 160
          ENDIF
C
          IF (IBRD.EQ.3) THEN
            ITYPE = 4
            CALL SPEAKG(0,ITYPE,IA1,IA2,IB1,IB2,NU,BOND(1,NN))
            GOTO 160
          ENDIF
C
          ITYPE = 1
          CALL SPEAKG(0,ITYPE,IA1,IA2,IB1,IB2,NU,BOND(1,NN))
          CALL SPEAKG(0,ITYPE,IA2,IA1,IB2,IB1,NU,BOND(2,NN))
          CALL SPEAKG(0,ITYPE,IA1,IA2,IB2,IB1,NU,BOND(3,NN))
          CALL SPEAKG(0,ITYPE,IA2,IA1,IB1,IB2,NU,BOND(4,NN))
C
          IF (NN.NE.KBD2) THEN
            NUP1 = NU+1
            ITYPE = 2
            CALL SPEAKG(0,ITYPE,IA1,IA2,IB1,IB2,NUP1,BOND(5,NN))
            CALL SPEAKG(0,ITYPE,IB1,IB2,IA1,IA2,NUP1,BOND(6,NN))
            CALL SPEAKG(0,ITYPE,IA2,IA1,IB2,IB1,NUP1,BOND(7,NN))
            CALL SPEAKG(0,ITYPE,IB2,IB1,IA2,IA1,NUP1,BOND(8,NN))
            CALL SPEAKG(0,ITYPE,IA1,IA2,IB2,IB1,NUP1,BOND(9,NN))
            CALL SPEAKG(0,ITYPE,IB2,IB1,IA1,IA2,NUP1,BOND(10,NN))
            CALL SPEAKG(0,ITYPE,IA2,IA1,IB1,IB2,NUP1,BOND(11,NN))
            CALL SPEAKG(0,ITYPE,IB1,IB2,IA2,IA1,NUP1,BOND(12,NN))
          ENDIF
C
  160     CONTINUE
        ENDDO
C
      ENDIF
C-----------------------------------------------------------------------
      IF (IBRE.GE.0) THEN
C
        PRODE = CONST/SQRT(DBLE(KS(1)*KS(3)))
        PRODE = -PRODE
        DO NN = 1,KBE2
          DO MU = 1,12
            BONE(MU,NN) = BONE(MU,NN)*PRODE
          ENDDO
        ENDDO
C======================================================
        DO NN = 1,KBE2
C
          NU = KBE1+2*(NN-1)
C
          IF (IBRE.EQ.4) THEN
            ITYPE = 5
            CALL SPEAKG(0,ITYPE,IB1,IA1,IB1,IA1,NU,BONE(1,NN))
            CALL SPEAKG(0,ITYPE,IA1,IB1,IB1,IA1,NU,BONE(2,NN))
            CALL SPEAKG(0,ITYPE,IA1,IB1,IA1,IB1,NU,BONE(3,NN))
            IF (NN.NE.KBE2) THEN
              NUP1 = NU+1
              ITYPE = 6
              CALL SPEAKG(0,ITYPE,IA1,IB1,IA1,IB1,NUP1,BONE(4,NN))
              CALL SPEAKG(0,ITYPE,IB1,IA1,IB1,IA1,NUP1,BONE(5,NN))
              CALL SPEAKG(0,ITYPE,IA1,IB1,IB1,IA1,NUP1,BONE(6,NN))
              CALL SPEAKG(0,ITYPE,IB1,IA1,IA1,IB1,NUP1,BONE(7,NN))
            ENDIF
            GOTO 170
          ENDIF
C
          IF (IBRE.EQ.2) THEN
            ITYPE = 3
            CALL SPEAKG(0,ITYPE,IA1,IB2,IB1,IA2,NU,BONE(1,NN))
            GOTO 170
          ENDIF
C
          ITYPE = 1
          CALL SPEAKG(0,ITYPE,IA1,IB2,IB1,IA2,NU,BONE(1,NN))
          CALL SPEAKG(0,ITYPE,IB2,IA1,IA2,IB1,NU,BONE(2,NN))
          CALL SPEAKG(0,ITYPE,IA1,IB2,IA2,IB1,NU,BONE(3,NN))
          CALL SPEAKG(0,ITYPE,IB2,IA1,IB1,IA2,NU,BONE(4,NN))
C
          IF (NN.NE.KBE2) THEN
            NUP1 = NU+1
            ITYPE = 2
            CALL SPEAKG(0,ITYPE,IA1,IB2,IB1,IA2,NUP1,BONE(5,NN))
            CALL SPEAKG(0,ITYPE,IB1,IA2,IA1,IB2,NUP1,BONE(6,NN))
            CALL SPEAKG(0,ITYPE,IB2,IA1,IA2,IB1,NUP1,BONE(7,NN))
            CALL SPEAKG(0,ITYPE,IA2,IB1,IB2,IA1,NUP1,BONE(8,NN))
            CALL SPEAKG(0,ITYPE,IA1,IB2,IA2,IB1,NUP1,BONE(9,NN))
            CALL SPEAKG(0,ITYPE,IA2,IB1,IA1,IB2,NUP1,BONE(10,NN))
            CALL SPEAKG(0,ITYPE,IB2,IA1,IB1,IA2,NUP1,BONE(11,NN))
            CALL SPEAKG(0,ITYPE,IB1,IA2,IB2,IA1,NUP1,BONE(12,NN))
          ENDIF
C
  170     CONTINUE
        ENDDO
C
      ENDIF
C-----------------------------------------------------------------------
 3000 FORMAT (                                                          !
     +' spectator quantum numbers not diagonal for non-interacting she',!
     +'lls')
 3010 FORMAT (' COR called : orbitals                      = ',4I5)
 3020 FORMAT (' COR called : KCD1,KCD2,KCE1,KCE2           = ',4I5)
 3030 FORMAT (/' STOPPING in routine COR'/                              !
     +' recompile and increase dimension of arrays COND,CONE to at lea',!
     +'st ',I5/' i.e. increase parameter IDIM to this value')
 3040 FORMAT (' COR called : KBD1,KBD2,KBE1,KBE2,IBRD,IBRE = ',6I5)
 3050 FORMAT (/' STOPPING in routine COR'/                              !
     +' recompile and increase dimension of arrays BOND,BONE to at lea',!
     +'st ',I5/' i.e. increase parameter IDIM to this value')
 3060 FORMAT (' COR called : NQS                           = ',4I5)
 3070 FORMAT (' COR called : LLS                           = ',4I5)
 3080 FORMAT (' COR called : ILS                           = ',4I5)
 3090 FORMAT (' COR called : LS1,LS2,LS3,LS4               = ',4I5)
 3100 FORMAT (' COR called : IS                            = ',I5/      !
     +' COR called : JBQ1                          = ',3I5/             !
     +' COR called : JBQ2                          = ',3I5)
 3110 FORMAT ('   direct    K recoupling coef      ',I5,2X,1P,E20.9)
 3120 FORMAT (' exchange    K recoupling coef      ',I5,2X,1P,E20.9)
 3130 FORMAT ('   direct NU K recoupling coef ',2I5,2X,1P,E20.9)
 3140 FORMAT (' S = ',1P,4E12.4)
 3150 FORMAT (' exchange NU K recoupling coef ',2I5,2X,1P,E20.9)
 3160 FORMAT (' COR called : statistical factor = ',1P,E20.9/)
      END
C
C                             *******************
C
      SUBROUTINE COULG(NLAST,J)
C
C-----------------------------------------------------------------------
C
C   This subroutine tabulates relativistic wave functions for a Coulomb
C   potential, calculated from the analytic formula.
C   The expressions used are given in, for example,
C   Burke and Grant, Proc. Phys. Soc. (London), 90,297(1967)
c
c   Extended to generate L-spinors           -        nrb 09/01/08
c   Energy norm correct to all orders        -        nrb 30/01/08
c
c     lspin=.true. for L-spinors, flagged by scr.lt.-0.1
c     then lambda=-scr and scr is reset to ne-1 where ne is the no. of 
c     electrons, so that the effective charge is the asymptotic charge
c     seen by one of the target electrons. 
c     lambda=1 is the normal choice for L-spinors c.f. the non-relativ.
c     problem.
c
c     lspin=.false.  for Coulomb, flagged by scr.ge.-0.1
c     then lambda=tlam=2/cpn recovers the Coulomb case.
c 
c     Note, Grant's lambda=tlamg=tlam*zj/2, in both cases,
c     and so we redefine:    zj=zj*cpn*tlam/two
c
C
C   DATA
C   ----
C   NLAST index of last element used in PF and QF
C   J     serial number of function to be computed
C
C   RESULTS
C   -------
C   PF,QF the wave functions are tabulated in these common arrays
C
C
C   Subroutine called: GAMF
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  External functions
C
      EXTERNAL GAMF,rint
      DOUBLE PRECISION GAMF,rint
C
C  Parameter variables
C
      INTEGER N11
      PARAMETER (N11=MXNP+10)
c
      double precision eps4
      parameter (eps4=1.d-4)
C
C  Argument variables
C
      INTEGER J,NLAST
C
C  Local variables
C
      DOUBLE PRECISION AZ,COP,COQ,CPN
      DOUBLE PRECISION CRM,FK,FNJ,FNR
      DOUBLE PRECISION GA,GAM,SCR,WA
      DOUBLE PRECISION WAM,WB,WC,WD
      DOUBLE PRECISION WE,WP,WQ,WX
      DOUBLE PRECISION ZJ
      INTEGER I,IJ,K,NADD
      INTEGER NGRID,NPOINT,NR,nx
c
      double precision tlam,tlamg,ee
      integer ne,ifirst
C
C  Common variables
C
      DOUBLE PRECISION HALF,ONE,TEN,TENTH
      DOUBLE PRECISION THREE,TWO,ZERO
      COMMON / CONS   / ZERO,HALF,TENTH,ONE,TWO,THREE,TEN
C
C  Common variables
C
      DOUBLE PRECISION ACCY,C,EPH,H
      DOUBLE PRECISION RNT,Z
      INTEGER N,NCPRIN,NW1
      COMMON / DEF01  / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN
C
C  Common variables
C
      DOUBLE PRECISION PZ(MXNW),QZ(MXNW)
      COMMON / EXCO   / PZ,QZ
C
C  Common variables
C
      INTEGER IPUNCH,IREAD,IWRITE
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
C
C  Common variables
C
      DOUBLE PRECISION P(MXNP),PC(MXNP),Q(MXNP)
      DOUBLE PRECISION QC(MXNP)
      COMMON / INT2   / P,Q,PC,QC
C
C  Common variables
C
      integer icut(mxnw)
      common /nrbcut/icut
C
C  Common variables
C
      double precision fx
      integer istatx,npmin0
      common /nrbinf/fx,istatx,npmin0
C
C  Common variables
C
      DOUBLE PRECISION E(MXNW)
      COMMON / ORB01  / E
C
C  Common variables
C
      DOUBLE PRECISION CXP(MXNW)
      COMMON / ORB03  / CXP
C
C  Common variables
C
      INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF
      INTEGER NP(MXNW),NW
      COMMON / ORB04  / NW,NCF,NP,NAK,IQ
C
C  Common variables
C
      INTEGER MPOIN(MXNW),MPOS(MXNW)
      COMMON / PATY   / MPOIN,MPOS
C
C  Common variables
C
      DOUBLE PRECISION CUTOFF
      COMMON / PATZ   / CUTOFF
C
C  Common variables
C
      DOUBLE PRECISION TA(N11),TB(N11)
      COMMON / TATB   / TA,TB
C
C  Common variables
C
      DOUBLE PRECISION PF(MXNG),QF(MXNG)
      COMMON / WAVE   / PF,QF
C
C  Common variables
C
      logical lspin
      common /nrb000/lspin
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      data ifirst/0/
C-----------------------------------------------------------------------
c
      SCR = CXP(J)
c
      if(scr.lt.-tenth)then
        lspin=.true.
        if(ifirst.eq.0)write(iwrite,3010)
        ifirst=1
        tlam=-scr
        ne=0
        do i=1,nw
          ne=ne+iq(i,1)
        enddo
        scr=ne-1
      else
        lspin=.false.                             !re-initialize for l>0
      endif
C
C  compute normalising factor
C
      ZJ = Z-SCR
      AZ = ZJ/C
      COQ = AZ*AZ
      K = NAK(J)
      FK = K
      FNJ = NP(J)
      NR = NP(J)-ABS(K)
      FNR = DBLE(NR)
      GA = SQRT(FK*FK-COQ)
      GAM = GA+GA+ONE
      COP = FNR+GA
      CPN = SQRT(COP*COP+COQ)
c
c set-up for L-spinors or Coulomb
c
      if(lspin)then
        zj=zj*cpn*tlam/two
        AZ = ZJ/C
c        CXP(J)=z-zj                        !write(*,*)'SCREEN',j,cxp(j)
      endif
c
      tlamg=zj/cpn                                       !Grant's lambda
      tlamg=tlamg/c                                      !c-scaled
c
c slight modification to energy factor required for L-spinors
c (covers Coulomb case as well, albeit slightly more lengthily)
c
      if(lspin)then
        wp=one+cop/cpn                                   !1+E(coul)/c**2
        wp=wp/tlamg
        wp=wp*wp
        wq=two/(one+wp)
        wq=sqrt(wq)
        wp=one/wp
        wp=two/(one+wp)
        wp=sqrt(wp)
      else
        WP = SQRT(ONE+COP/CPN)
        WQ = AZ/(CPN*WP)
      endif
c
c this imposes unit norm on p and q individually (no energy factor)
c
c      wp=sqrt(two)
c      wq=wp
c
c this imposes overall unit norm on p and q combined (no energy factor)
c
c      wp=one
c      wq=wp
C
      WA = ONE
      WB = ZJ*GAMF(GAM+FNR)/(TWO*(CPN-FK))
      I = NR
   10 CONTINUE
      IF (I.GT.0) THEN
        WB = WB/WA
        WA = WA+ONE
        I = I-1
        GOTO 10
      ENDIF
C
      CRM = SIGN(SQRT(WB),-FK)
      CRM = CRM/(CPN*GAMF(GAM))
      WP = WP*CRM
      WQ = -WQ*CRM
C
C   Compute eigenvalue. This covers both cases: Coulomb and L-spinors.
C   Both were subject to cancellation in non-rel limit, i.e. c->c*1e6,
C   but this e-value was/is not used to determine H, of course. 
c
      ee=sqrt(one-tlamg*tlamg)
      tlamg=tlamg*c
      e(j)=-tlamg*tlamg/(one+ee)
C
C   compute coefficients in hypergeometric functions in TA and TB.
C
      TA(1) = ZERO
      TA(2) = ZERO
      TB(1) = ZERO
      TB(2) = ZERO
C
      IF (NR.GT.0) THEN
        TA(1) = FNR
        WA = ONE-FNR
        WB = GAM
        WC = ONE
        I = 2
   20   CONTINUE
        IF (I.LT.NR+1) THEN
          TA(I) = TA(I-1)*WA/(WB*WC)
          WA = WA+ONE
          WB = WB+ONE
          WC = WC+ONE
          I = I+1
          GOTO 20
        ENDIF
      ENDIF
C
      TB(1) = CPN-FK
      WA = -FNR
      WB = GAM
      WC = ONE
      I = 2
   30 CONTINUE
      IF (I.LT.NR+2) THEN
        TB(I) = TB(I-1)*WA/(WB*WC)
        WA = WA+ONE
        WB = WB+ONE
        WC = WC+ONE
        I = I+1
        GOTO 30
      ENDIF
C
C   tabulate wave functions
C
      WX = TWO*ZJ/CPN
      WA = RNT*WX
      WAM = TWO*FNJ*FNJ*WX/ZJ                       !Outer turning point
C
C   evaluate hypergeometric functions and form wave functions
C
C==================================================
      DO I = 1,N
C
        WC = ZERO
        IF (NR.GT.0) THEN
          IJ = NR
   40     CONTINUE
          WC = WC*WA+TA(IJ)
          IJ = IJ-1
          IF (IJ.GT.0) GOTO 40
        ENDIF
C
        WD = ZERO
        IJ = NR+1
   50   CONTINUE
        WD = WD*WA+TB(IJ)
        IJ = IJ-1
        IF (IJ.GT.0) GOTO 50
C
        WE = WA**GA*EXP(-WA*HALF)
C
        Q(I) = WE*(WC+WD)*WQ
        P(I) = WE*(WD-WC)*WP
C
        WA = WA*EPH
C
        IF (WA.GT.WAM) THEN
          IF (ABS(P(I)).LE.CUTOFF) GOTO 60
        ENDIF
C
      ENDDO
C==================================================
      NGRID = N
      if(lspin.or.np(j).ge.npmin0)icut(j)=n
      write(*,3001)J
      write(iwrite,3001)j
      GOTO 70
C
   60 CONTINUE
      NPOINT = I
c
c add buffer space for subsequent formation of new basis in rritz;
c extend it radially by a factor fx.
c
      if(lspin.or.np(j).ge.npmin0)then
        icut(j)=npoint                                 !store real end
        nx=log(fx)/h
        nx=nx+mod(nx,2)
      else
        nx=0
      endif
C
      IF (NPOINT.LT.N) THEN
        IF (MOD(NPOINT,2).EQ.1) THEN
          NADD = 8
        ELSE
          NADD = 7
        ENDIF
c
        nadd=nadd+nx
c
        IF (NPOINT+NADD.GT.N) NADD = N - NPOINT
        DO I = NPOINT+1,NPOINT+NADD
          P(I) = ZERO
          Q(I) = ZERO
        ENDDO
        NGRID = NPOINT+NADD
      ELSE
        NGRID = NPOINT
      ENDIF
C
   70 CONTINUE
      IF (NLAST+NGRID.GT.MXNG) THEN
        WRITE (IWRITE,3000) NLAST + NGRID,MXNG
        WRITE (IPUNCH,3000) NLAST + NGRID,MXNG
        STOP
      ENDIF
cc
c      ij=ngrid-1
c      write(72,*)j,ngrid,h,rnt*exp(h*ij),cutoff
c      do i=1,ngrid,10
c        ij=i-1
c        write(72,*)i,rnt*exp(h*ij),p(i)
c      enddo
C
      IJ = NLAST+1
      DO I = 1,NGRID
        PF(IJ) = P(I)
        QF(IJ) = Q(I)
        IJ = IJ+1
      ENDDO
C
      MPOS(J) = NLAST+1
      MPOIN(J) = NGRID
      NLAST = NLAST+NGRID
C
      WB = WX**GA
      PZ(J) = WB*WP*(TB(1)-TA(1))
      QZ(J) = WB*WQ*(TA(1)+TB(1))
c
c check normalizations, P**2+Q**2 and Q(0)/P(0), for L-spinors (only)
c as only they should be being formed at high-n. Starts to break-down
c above n=30, as can be seen by examining the norm.
c
      if(lspin)then
c        write(*,*)'*** Q(0)/P(0) = ',j,qz(j)/pz(j),q(1)/p(1),az/(fk-ga)
c     x,(fk+ga)/az*(cpn*tlam/two)**2

        wx=rint(j,j,0)
        if(abs(wx-one).gt.tenth)then
          write(iwrite,3002)
          write(iwrite,*)'COULG: **** NORM **** =',np(j),k,wx
          stop ' FAILURE in COULG...'
        endif
        if(abs(wx-one).gt.eps4)
     x  write(*,*)'COULG: **** NORM **** =',np(j),k,wx
        wx=one/sqrt(wx)
        ij = mpos(j)
        do i = 1,ngrid
          pf(ij) = pf(ij)*wx
          qf(ij) = qf(ij)*wx
          ij = ij+1
        enddo
      endif
C
 3000 FORMAT (/' ERROR in COULG: dimension ... STOPPING'/               !
     +' You must increase MXNG to at least ',I9,                        !
     +' from the present value of ',I9/)
 3001 FORMAT ('***SR.COULG: WAVEFUNCTION TRUNCATED AT RMAX!!! - J=',I4)
 3002 FORMAT (/' FAILURE in COULG: L-spinor normalization deviating'
     x,'from unity - too high in n?')
 3010 FORMAT (/' >>>> routine COULG called : form initial L-spinor basis
     x'/)
      END
C
C                             *******************
C
      SUBROUTINE COUMAT(ICOUL,IO4)
C
C-----------------------------------------------------------------------
C
C  This routine controls the calculation of the Coulomb matrix.
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  Parameter variables
C
      DOUBLE PRECISION EPS10
      PARAMETER (EPS10=1.D-10)
      DOUBLE PRECISION ZERO
      PARAMETER (ZERO=0.D0)
C
C  Argument variables
C
      INTEGER ICOUL,IO4
C
C  Local variables
C
      DOUBLE PRECISION AM,AMAX,EAU,ERY
      DOUBLE PRECISION WA
      INTEGER I,IA,IJ,IP
      INTEGER J
C
C  Common variables
C
      DOUBLE PRECISION COUVEC(MXNC,MXNC)
      COMMON / BRET1  / COUVEC
C
C  Common variables
C
      DOUBLE PRECISION ACCY,C,EPH,H
      DOUBLE PRECISION RNT,Z
      INTEGER N,NCPRIN,NW1
      COMMON / DEF01  / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN
C
C  Common variables
C
      DOUBLE PRECISION BREENG(MXNC),COUENG(MXNC)
      COMMON / ENRG1  / COUENG,BREENG
C
C  Common variables
C
      INTEGER IPUNCH,IREAD,IWRITE
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
C
C  Common variables
C
      INTEGER KTC(20)
      COMMON / OPT03  / KTC
C
C  Common variables
C
      INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF
      INTEGER NP(MXNW),NW
      COMMON / ORB04  / NW,NCF,NP,NAK,IQ
C
C  Common variables
C
      INTEGER ISPAR(MXNC),ITJPO(MXNC)
      COMMON / ORB07  / ITJPO,ISPAR
C
C  Common variables
C
      INTEGER LEV(MXNC)
      COMMON / PAT1   / LEV
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
      WRITE (IWRITE,3010)
      PRINT 3010
C
C  Evaluate the Coulomb matrix
C
      IF (ICOUL.EQ.1) CALL COUMT1(IO4)
C
      IF ((KTC(1)+KTC(2)+KTC(3)).GT.0) WRITE (IWRITE,3000)
C-----------------------------------------------------------------------
C
C  Print Coulomb matrix if option 1 is set.
C
      IF (ICOUL.EQ.1 .AND. KTC(1).EQ.1) CALL MATOUT(IWRITE,COUVEC,NCF,NC!
     +F,MXNC,MXNC,1)
C-----------------------------------------------------------------------
C
C  Diagonalise the Coulomb matrix
C
      IF (ICOUL.EQ.1) CALL COUMT2
C-----------------------------------------------------------------------
C
C  Eigenvector elements less than 1e-10 are set to zero.
C  Set up the array LEV where LEV(J) identifies the dominant CSF for
C  level J.
C  The largest mixing coefficient for each CSF is made positive
C
      DO J = 1,NCF
        IA = 0
        AMAX = ZERO
        DO I = 1,NCF
          WA = ABS(COUVEC(I,J))
          IF (WA.LT.EPS10) COUVEC(I,J) = ZERO
          IF (WA.GT.AMAX) THEN
            AMAX = WA
            IA = I
          ENDIF
        ENDDO
        LEV(J) = IA
        IF (COUVEC(IA,J).LT.ZERO) THEN
          DO I = 1,NCF
            COUVEC(I,J) = -COUVEC(I,J)
          ENDDO
        ENDIF
      ENDDO
C-----------------------------------------------------------------------
C
C  Print Coulomb energies if option 2 is set.
C
      IF (KTC(2).EQ.1) THEN
        WRITE (IWRITE,3020)
        DO J = 1,NCPRIN
          EAU = COUENG(J)
          IF (J.GT.1) EAU = EAU - COUENG(1)
          ERY = EAU+EAU
          I = LEV(J)
          IJ = ITJPO(I)-1
          IP = ISPAR(I)
          AM = COUVEC(I,J)
C
          IF (MOD(IJ,2).EQ.0) THEN
            IJ = IJ/2
            IF (IP.EQ.1) THEN
              WRITE (IWRITE,3060) J,IJ,I,AM,EAU,ERY
            ELSE
              WRITE (IWRITE,3050) J,IJ,I,AM,EAU,ERY
            ENDIF
          ELSE
            IF (IP.EQ.1) THEN
              WRITE (IWRITE,3040) J,IJ,I,AM,EAU,ERY
            ELSE
              WRITE (IWRITE,3030) J,IJ,I,AM,EAU,ERY
            ENDIF
          ENDIF
C
        ENDDO
      ENDIF
C-----------------------------------------------------------------------
C
C  Print Coulomb vectors if option 3 is set.
C
      IF (KTC(3).EQ.1) CALL MATOUT(IWRITE,COUVEC,NCF,NCPRIN,MXNC,MXNC,3)
C-----------------------------------------------------------------------
 3000 FORMAT (/20X,' *****************************************'/20X,    !
     +' *         Coulomb         matrix        *'/20X,                 !
     +' *****************************************')
 3010 FORMAT (/' >>>> routine COUMAT called')
 3020 FORMAT (/' Coulomb            dominant'/                          !
     +' level  J   parity  CSF   mix           a.u.                Ryd.'!
     +/)
 3030 FORMAT (1X,I4,2X,I4,'/2  odd    ',I4,2X,F5.3,3X,1P,2E20.8)
 3040 FORMAT (1X,I4,2X,I4,'/2  even   ',I4,2X,F5.3,3X,1P,2E20.8)
 3050 FORMAT (1X,I4,2X,I4,'    odd    ',I4,2X,F5.3,3X,1P,2E20.8)
 3060 FORMAT (1X,I4,2X,I4,'    even   ',I4,2X,F5.3,3X,1P,2E20.8)
      END
C
C                             *******************
C
      SUBROUTINE COUMT1(IO4)
C
C-----------------------------------------------------------------------
C
C  Routine for evaluating the Coulomb matrix.
C
C  IO4 - stream for MCP coefficients.
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  External functions
C
      EXTERNAL RINTI,SLATER
      DOUBLE PRECISION RINTI,SLATER
C
C  Parameter variables
C
      DOUBLE PRECISION EPS10
      PARAMETER (EPS10=1.D-10)
      DOUBLE PRECISION ZERO
      PARAMETER (ZERO=0.D0)
C
C  Argument variables
C
      INTEGER IO4
C
C  Local variables
C
      CHARACTER IBL,ILAB,IST
      DOUBLE PRECISION COEF,CONTR,ELMNT,ELSTO
      DOUBLE PRECISION XINT,XLAB
      INTEGER I,IA,IB,IC
      INTEGER ID,ISTOR,ISTORE,ITYP
      INTEGER ITYPE,JA,JAP,JB
      INTEGER JBP,K,NCFP,NSTART
      INTEGER NUM,NUMEL,NUMINT,NUMSTO
      INTEGER NUMTOT,NUMX,NWA,NWP
C
C  Common variables
C
      DOUBLE PRECISION COUVEC(MXNC,MXNC)
      COMMON / BRET1  / COUVEC
C
C  Common variables
C
      INTEGER IPUNCH,IREAD,IWRITE
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
C
C  Common variables
C
      INTEGER KTC(20)
      COMMON / OPT03  / KTC
C
C  Common variables
C
      CHARACTER*2 NH(MXNW)
      COMMON / ORB00  / NH
C
C  Common variables
C
      INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF
      INTEGER NP(MXNW),NW
      COMMON / ORB04  / NW,NCF,NP,NAK,IQ
C
C  Common variables
C
      INTEGER MPOIN(MXNW),MPOS(MXNW)
      COMMON / PATY   / MPOIN,MPOS
C
C  Common variables
C
      DOUBLE PRECISION PF(MXNG),QF(MXNG)
      COMMON / WAVE   / PF,QF
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      DATA IBL,IST/' ','S'/
C-----------------------------------------------------------------------
      NSTART = MPOIN(NW)+MPOS(NW)-1
      NUMX = MXNG-NSTART
C
      NUMINT = 0
      NUMSTO = 0
      NUMTOT = 0
      NUMEL = 0
C
      ELSTO = ZERO
C-----------------------------------------------------------------------
C
C  Position stream IO4 which reads in MCP coefficients.
C
      REWIND IO4
      READ (IO4)
      READ (IO4) NCFP,NWP
      NWA = NWP+1
      DO I = 1,7
        READ (IO4)
      ENDDO
C-----------------------------------------------------------------------
      DO JA = 1,NCF
        DO JB = JA,NCF
C
C  Read coefficients for configuration pair JA,JB.
C
          ELMNT = ZERO
          READ (IO4) JAP,JBP
          NUM = 0
C
C  Coefficients stored as : ISTORE,ITYP,COEF
C  Need to decode ISTORE.
C
   10     CONTINUE
          READ (IO4) ISTORE,ITYP,COEF
          IF (ISTORE.EQ.0) GOTO 30
          ISTORE = ABS(ISTORE)
          ITYPE = ABS(ITYP)
          IF (ITYPE.LT.7) GOTO 10
C
          IF (ITYPE.EQ.8 .OR. ITYPE.EQ.9) THEN
            ISTOR = ISTORE
            ID = MOD(ISTOR,NWA)
            ISTOR = ISTOR/NWA
            IC = MOD(ISTOR,NWA)
            ISTOR = ISTOR/NWA
            IB = MOD(ISTOR,NWA)
            ISTOR = ISTOR/NWA
            IA = MOD(ISTOR,NWA)
            K = ISTOR/NWA
          ELSE
            ISTOR = ISTORE
            ID = MOD(ISTOR,NWA)
            IC = ISTOR/NWA
          ENDIF
C
          IF (NUM.EQ.0 .AND. KTC(8).EQ.1) WRITE (IWRITE,3010) JA,JB
          NUM = NUM+1
C
C  Check if the radial integral has been stored.
C
          XLAB = ISTORE*10+ITYPE
          IF (NUMSTO.GT.0) THEN
            DO I = NSTART+1,NSTART+NUMSTO
              IF (ABS(XLAB-PF(I)).LT.EPS10) THEN
                XINT = QF(I)
                ILAB = IST
                GOTO 20
              ENDIF
            ENDDO
          ENDIF
C
C  Evaluate the radial integral.
C
          ILAB = IBL
          IF (ITYPE.EQ.7) THEN
            XINT = RINTI(IC,ID)
          ELSE
            XINT = SLATER(IA,IB,IC,ID,K)
          ENDIF
C
C  Store radial integral.
C
          NUMINT = NUMINT+1
          IF (NUMSTO.LT.NUMX) THEN
            NUMSTO = NUMSTO+1
            PF(NSTART+NUMSTO) = XLAB
            QF(NSTART+NUMSTO) = XINT
          ENDIF
C
   20     CONTINUE
          CONTR = COEF*XINT
          ELMNT = ELMNT+CONTR
C
C  Sum core contributions.
C
          IF (ITYP.LT.0) THEN
            ELSTO = ELSTO+CONTR
            NUMEL = NUMEL+1
          ENDIF
C
C  Write out contributions if requested - option 8 set.
C
          IF (KTC(8).EQ.1) THEN
            IF (ITYPE.EQ.8 .OR. ITYPE.EQ.9) THEN
              WRITE (IWRITE,3090) NP(IA),NH(IA),NP(IB),NH(IB),NP(IC),NH(!
     +IC),NP(ID),NH(ID),K,ITYP,COEF,XINT,CONTR,ILAB
            ELSE
              WRITE (IWRITE,3080) NP(IC),NH(IC),NP(ID),NH(ID),ITYP,COEF,!
     +XINT,CONTR,ILAB
            ENDIF
          ENDIF
C
          GOTO 10
C
C  Store total in COUVEC array.
C  Write out total if requested - option 8 set.
C
   30     CONTINUE
C
          NUMTOT = NUMTOT+NUM
C
          IF (NUM.GT.0 .AND. KTC(8).EQ.1) WRITE (IWRITE,3020) ELMNT
C
          COUVEC(JA,JB) = ELMNT
C         COUVEC(JB,JA) = ELMNT
C
C  Add in core contribution if applicable.
C  Write out contribution if option 8 is set.
C
          IF (JA.EQ.JB .AND. JA.GT.1 .AND. NUMEL.GT.0) THEN
            COUVEC(JA,JA) = COUVEC(JA,JA)+ELSTO
            IF (KTC(8).EQ.1) THEN
              WRITE (IWRITE,3030) ELSTO
              WRITE (IWRITE,3020) COUVEC(JA,JA)
            ENDIF
          ENDIF
C
          IF (JA.EQ.JB) PRINT 3000,JA,JA,ELSTO,COUVEC(JA,JA)
C
        ENDDO
      ENDDO
C-----------------------------------------------------------------------
      REWIND IO4
C-----------------------------------------------------------------------
      WRITE (IWRITE,3040) NUMTOT
      WRITE (IWRITE,3050) NUMEL
      WRITE (IWRITE,3060) NUMINT
      WRITE (IWRITE,3070) NUMSTO
      PRINT 3040,NUMTOT
      PRINT 3050,NUMEL
      PRINT 3060,NUMINT
      PRINT 3070,NUMSTO
C-----------------------------------------------------------------------
 3000 FORMAT (' COUMAT : ',2I5,1P,2E12.4)
 3010 FORMAT (/' contributions to matrix element (',I2,',',I2,')'//     !
     +'   A    B    C    D    K  ITYPE  coeff.           integral     ',!
     +'   contribution'/)
 3020 FORMAT (1X,62X,'---------------'/1X,62X,1P,E15.8)
 3030 FORMAT (1X,'core contribution = ',48X,1P,E15.8)
 3040 FORMAT (/1X,I5,' MCP  (Coulomb) angular coefficients read')
 3050 FORMAT (1X,I5,' core (Coulomb) angular coefficients read')
 3060 FORMAT (/1X,I5,' radial integrals evaluated')
 3070 FORMAT (1X,I5,' radial integrals stored')
 3080 FORMAT (11X,2(I2,A2,1X),5X,I4,1X,1P,3E16.8,1X,A1)
 3090 FORMAT (1X,4(I2,A2,1X),I4,2X,I4,1X,1P,3E16.8,1X,A1)
      END
C
C                             *******************
C
      SUBROUTINE COUMT2
C
C-----------------------------------------------------------------------
C
C  This routine is used to determine the eigenvalues and eigenvectors
C  of the zero order matrix (Coulomb).
C
C  Subroutine called: DSYEV
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  Parameter variables
C
      DOUBLE PRECISION ZERO
      PARAMETER (ZERO=0.D0)
      INTEGER LWORK
      PARAMETER (LWORK=MXNC*3-1)
C
C  Local variables
C
      DOUBLE PRECISION EAV,WORK(LWORK)
      INTEGER I,INFO
C
C  Common variables
C
      DOUBLE PRECISION COUVEC(MXNC,MXNC)
      COMMON / BRET1  / COUVEC
C
C  Common variables
C
      DOUBLE PRECISION BREENG(MXNC),COUENG(MXNC)
      COMMON / ENRG1  / COUENG,BREENG
C
C  Common variables
C
      INTEGER IPUNCH,IREAD,IWRITE
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
C
C  Common variables
C
      INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF
      INTEGER NP(MXNW),NW
      COMMON / ORB04  / NW,NCF,NP,NAK,IQ
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
      WRITE (IWRITE,3020)
C
C  calculate the average energy and subtract from diagonal
C
      EAV = ZERO
      DO I = 1,NCF
        EAV = EAV+COUVEC(I,I)
      ENDDO
      EAV = EAV/DBLE(NCF)
      WRITE (IWRITE,3030) EAV
      PRINT 3030,EAV
      DO I = 1,NCF
        COUVEC(I,I) = COUVEC(I,I)-EAV
      ENDDO
C
C  diagonalise the matrix
C
C  use a LAPACK routine
C
      WRITE (IWRITE,3000)
      CALL DSYEV ('V','U',NCF,COUVEC,MXNC,COUENG,WORK,LWORK,INFO)
      IF (INFO.NE.0) THEN
        WRITE (IWRITE,3010)
        STOP
      ENDIF
C
      DO I = 1,NCF
        COUENG(I) = COUENG(I)+EAV
      ENDDO
C
 3000 FORMAT (/' diagonalisation using the DSYEV routine')
 3010 FORMAT (/' ERROR using the DSYEV routine'/' STOPPING')
 3020 FORMAT (/                                                         !
     +' >>>> routine COUMT2 called : diagonalise the Coulomb matrix')
 3030 FORMAT (/' average energy (a.u.) ',1P,E18.10)
      END
C
C                             *******************
C
      SUBROUTINE COUP(IWRITE,NL,NQ,JI,JF,JQS,IQ,JCUP,ICASE,MODE,ICASEX)
C
C-----------------------------------------------------------------------
C
C   IWRITE = output stream for printer
C   NL     = L value
C   NQ     = occupation number
C   JI     = initial 2J
C   JF     = final   2J
C   JQS,IQ,JCUP - results
C   ICASE  = number of relativistic subshells
C   MODE   =0 if JF is not fixed,
C          =1 if JF is fixed
C   ICASEX = dimension of arrays
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
C
C  Statement functions
C
      LOGICAL ITRG
C
C  Argument variables
C
      INTEGER ICASEX
      INTEGER ICASE,IQ(2,ICASEX)
      INTEGER IWRITE,JCUP(ICASEX),JF
      INTEGER JI,JQS(3,2,ICASEX),MODE
      INTEGER NL,NQ
C
C  Local variables
C
      INTEGER I1,I2,I3,ISA
      INTEGER ISB,ITA,ITB,ITBX
      INTEGER IXA,IXB,IXJA,IXJB
      INTEGER J1,J2,J3,J4
      INTEGER JMAX,JMIN,K,NC
      INTEGER NCA,NCB,NJA,NJB
      INTEGER NQA,NQB,NX
C
C  Common variables
C
      INTEGER ITAB(16),JTAB(16),NROWS
      INTEGER NTAB(255)
      COMMON / TERMS  / NROWS,ITAB,JTAB,NTAB
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      ITRG(J1,J2,J3) = ABS(J1-J2).LE.J3.AND.J3.LE.J1+J2.AND.MOD(J1+J2+J3!
     +,2).EQ.0
C-----------------------------------------------------------------------
      ICASE = 0
      IF (NQ.EQ.0) GOTO 10
      IF (NL.EQ.0) GOTO 20
C
      NJA = NL+NL
      NJB = NJA+2
      IXJA = 1+(NJA*(NJA-2))/8
      IXJB = 1+(NJB*(NJB-2))/8
      NX = MIN(NQ,NJA)+1
C
      DO I1 = 1,NX
        NQA = NX-I1
        NQB = NQ-NQA
        NCA = MIN(NQA,NJA-NQA)
        NCB = MIN(NQB,NJB-NQB)
C
        IF (NCB.GE.0) THEN
C
          IF (NCA.EQ.0) THEN
            IXA = 1
          ELSE
            IXA = NCA+IXJA
            IF (IXA.GT.NROWS) GOTO 50
          ENDIF
C
          IF (NCB.EQ.0) THEN
            IXB = 1
          ELSE
            IXB = NCB+IXJB
            IF (IXB.GT.NROWS) GOTO 50
          ENDIF
C
          ISA = ITAB(IXA)
          ITA = JTAB(IXA)
          ISB = ITAB(IXB)
          ITB = JTAB(IXB)
C
          DO I2 = 1,ISA
            J1 = NTAB(ITA+3)-1
            JMIN = ABS(J1-JI)
            JMAX = J1+JI
            DO J4 = JMIN,JMAX,2
              ITBX = ITB
              DO I3 = 1,ISB
                J2 = NTAB(ITBX+3)-1
                IF (MODE.EQ.0 .OR. ITRG(J4,J2,JF)) THEN
                  ICASE = ICASE+1
                  IF (ICASE.GT.ICASEX) GOTO 40
                  DO K = 1,3
                    JQS(K,1,ICASE) = NTAB(ITA+K)
                    JQS(K,2,ICASE) = NTAB(ITBX+K)
                  ENDDO
                  IQ(1,ICASE) = NQA
                  IQ(2,ICASE) = NQB
                  JCUP(ICASE) = J4+1
                ENDIF
                ITBX = ITBX+3
              ENDDO
            ENDDO
            ITA = ITA+3
          ENDDO
C
        ENDIF
C
      ENDDO
      RETURN
C
C   NQ=0   occupation number is zero
C
   10 CONTINUE
      IF (MODE.EQ.1 .AND. JI.NE.JF) RETURN
      ICASE = 1
      DO K = 1,3
        JQS(K,1,1) = NTAB(K)
        JQS(K,2,1) = NTAB(K)
      ENDDO
      IQ(1,1) = 0
      IQ(2,1) = 0
      JCUP(1) = JI+1
      RETURN
C
C   NL=0  L-value is zero
C
   20 CONTINUE
      J2 = 0
      IF (NQ.EQ.1) J2 = 1
      IF (MODE.EQ.0) GOTO 30
      IF (ITRG(JI,J2,JF)) GOTO 30
      RETURN
C
   30 CONTINUE
      NC = MIN(NQ,2-NQ)*3
      ICASE = 1
      DO K = 1,3
        JQS(K,1,1) = NTAB(K)
        JQS(K,2,1) = NTAB(K+NC)
      ENDDO
      IQ(1,1) = 0
      IQ(2,1) = NQ
      JCUP(1) = JI+1
      RETURN
C
C    Error messages
C
   40 CONTINUE
      WRITE (IWRITE,3000)
      STOP
C
   50 CONTINUE
      WRITE (IWRITE,3010)
      STOP
C
 3000 FORMAT (/' ERROR in COUP : dimension for ICASE ... STOPPING')
 3010 FORMAT (/' ERROR in COUP : dimension for NROWS ... STOPPING')
      END
C
C                             *******************
C
      FUNCTION CRE(KAP1,K,KAP2)
C
C-----------------------------------------------------------------------
C
C    Computes the relativistic reduced matrix element
C           (J1 // C(K) // J2)
C    defined by eq.(5.15), I.P.Grant, Advances in Physics (1970),
C    vol.19, p.762.
C
C    KAP1,KAP2 are the kappa values corresponding to J1,J2.
C
C    The triangle conditions are tested by the 3J-coefficient
C    routine, CLRX.
C
C    Subroutine called: CLRX
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      DOUBLE PRECISION CRE
C
C  External functions
C
      EXTERNAL CLRX
      DOUBLE PRECISION CLRX
C
C  Argument variables
C
      INTEGER K,KAP1,KAP2
C
C  Local variables
C
      INTEGER K1,K2
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
      K1 = ABS(KAP1)
      K2 = ABS(KAP2)
      CRE = SQRT(DBLE(K1*K2))*CLRX(KAP1,K,KAP2)
      IF (MOD(K1,2).EQ.1) CRE = -CRE
      CRE = CRE+CRE
      END
C
C                             *******************
C
      SUBROUTINE CSFM(ASFA,ASFB,LEV1,LEV2)
C
C-----------------------------------------------------------------------
C
C  This routine calculates the CSF Coulomb, Babuskin, and magnetic
C  matrix elements for a transition between levels separated by energy
C  OMEGA.
C
C  Option 8 gives a debug print from this routine.
C
C  Subroutine called: SPME
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  Parameter variables
C
      DOUBLE PRECISION EPS10
      PARAMETER (EPS10=1.D-10)
      INTEGER N18
      PARAMETER (N18=MXNC*(MXNC+1)/2)
C
C  Argument variables
C
      DOUBLE PRECISION ASFA,ASFB
      INTEGER LEV1,LEV2
C
C  Local variables
C
      DOUBLE PRECISION COUVX,CSFA,CSFB,FACT
      DOUBLE PRECISION FACT1,FACT2,HBAB,HCOUL
      DOUBLE PRECISION HMAG,XCOEF
      DOUBLE PRECISION MIX(6)
      INTEGER I,IC,ID,IDL
      INTEGER IL,ILDA,ILDB,ILDN
      INTEGER IRS,ISTOR(MXNW,MXNW),ITEMP
      INTEGER ITR,IX,IXX,J
      INTEGER JTR,NSTART,NUMSTO,NUMX
      INTEGER NWA
      INTEGER NCOUNT,CSF(6)
C
C  Common variables
C
      DOUBLE PRECISION COUVEC(MXNC,MXNC)
      COMMON / BRET1  / COUVEC
C
C  Common variables
C
      DOUBLE PRECISION HALF,ONE,TEN,TENTH
      DOUBLE PRECISION THREE,TWO,ZERO
      COMMON / CONS   / ZERO,HALF,TENTH,ONE,TWO,THREE,TEN
C
C  Common variables
C
      INTEGER IPUNCH,IREAD,IWRITE
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
C
C  Common variables
C
      DOUBLE PRECISION XSLDR(MXNM)
      INTEGER ISLDR(MXNM),NMCP
      COMMON / MCPA   / XSLDR,ISLDR,NMCP
C
C  Common variables
C
      INTEGER NNLDR(N18),NSLDF(N18)
      COMMON / MCPB   / NNLDR,NSLDF
C
C  Common variables
C
      INTEGER LTC(20)
      COMMON / OPT04  / LTC
C
C  Common variables
C
      CHARACTER*2 NH(MXNW)
      COMMON / ORB00  / NH
C
C  Common variables
C
      INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF
      INTEGER NP(MXNW),NW
      COMMON / ORB04  / NW,NCF,NP,NAK,IQ
C
C  Common variables
C
      INTEGER NKJ(MXNW),NKL(MXNW)
      COMMON / ORB05  / NKL,NKJ
C
C  Common variables
C
      INTEGER ISPAR(MXNC),ITJPO(MXNC)
      COMMON / ORB07  / ITJPO,ISPAR
C
C  Common variables
C
      INTEGER KK,LK
      COMMON / OSC2   / LK,KK
C
C  Common variables
C
      INTEGER MPOIN(MXNW),MPOS(MXNW)
      COMMON / PATY   / MPOIN,MPOS
C
C  Common variables
C
      DOUBLE PRECISION PF(MXNG),QF(MXNG)
      COMMON / WAVE   / PF,QF
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
      NWA = NW+1
      NSTART = MPOIN(NW)+MPOS(NW)-1
      NUMX = MXNG-NSTART
      NUMSTO = 0
      DO I = 1,NW
        DO J = 1,NW
          ISTOR(I,J) = 0
        ENDDO
      ENDDO
C
      ASFA = ZERO
      ASFB = ZERO
C
      IF (LTC(8).EQ.1) THEN
C
        IF (KK.EQ.0) THEN
          WRITE (IWRITE,3000)
          WRITE (IWRITE,3010)
          WRITE (IWRITE,3020) LEV1,LEV2
          WRITE (IPUNCH,3000)
          WRITE (IPUNCH,3010)
          WRITE (IPUNCH,3030) LEV1,LEV2
        ELSE
          WRITE (IWRITE,3000)
          WRITE (IWRITE,3010)
          WRITE (IWRITE,3040) LEV1,LEV2
        ENDIF
C
        WRITE (IWRITE,3050) LEV1
        NCOUNT = 0
        DO ITR = 1,NCF
          IF (ABS(COUVEC(ITR,LEV1)).GT.0.01D0) THEN
            NCOUNT = NCOUNT+1
            CSF(NCOUNT) = ITR
            MIX(NCOUNT) = COUVEC(ITR,LEV1)
            IF (NCOUNT.EQ.6) THEN
              WRITE (IWRITE,3060) (CSF(I),MIX(I),I=1,NCOUNT)
              NCOUNT = 0
            ENDIF
          ENDIF
        ENDDO
        IF (NCOUNT.GT.0) THEN
          WRITE (IWRITE,3060) (CSF(I),MIX(I),I=1,NCOUNT)
        ENDIF
C
        WRITE (IWRITE,3050) LEV2
        NCOUNT = 0
        DO ITR = 1,NCF
          IF (ABS(COUVEC(ITR,LEV2)).GT.0.01D0) THEN
            NCOUNT = NCOUNT+1
            CSF(NCOUNT) = ITR
            MIX(NCOUNT) = COUVEC(ITR,LEV2)
            IF (NCOUNT.EQ.6) THEN
              WRITE (IWRITE,3060) (CSF(I),MIX(I),I=1,NCOUNT)
              NCOUNT = 0
            ENDIF
          ENDIF
        ENDDO
        IF (NCOUNT.GT.0) THEN
          WRITE (IWRITE,3060) (CSF(I),MIX(I),I=1,NCOUNT)
        ENDIF
C
        WRITE (IWRITE,3070)
        IF (KK.EQ.0) THEN
          WRITE (IPUNCH,3070)
        ENDIF
C
      ENDIF
C
C  Loop over CSF pairs
C  -------------------
C
      DO ITR = 1,NCF
        DO JTR = 1,NCF
C
          COUVX = COUVEC(ITR,LEV1)*COUVEC(JTR,LEV2)
          IF (ABS(COUVX).LT.EPS10) GOTO 10
C
C  Find MCT coefficients for these configurations and accumulate
C  contributions.
C
          IF (ITR.LT.JTR) THEN
            IRS = (ITR-1)*(NCF+NCF-ITR)/2+JTR
          ELSE
            IRS = (JTR-1)*(NCF+NCF-JTR)/2+ITR
          ENDIF
C
          ILDN = NNLDR(IRS)
          IF (ILDN.EQ.0) GOTO 10
C
          ILDA = NSLDF(IRS)
          ILDB = ILDA+ILDN-1
C
          DO IL = ILDA,ILDB
C
            IC = ISLDR(IL)/NWA
            ID = ISLDR(IL)-IC*NWA
            XCOEF = XSLDR(IL)
C
C  The following code allows interchange of CSF labels.
C
            IF (ITR.GT.JTR) THEN
              ITEMP = IC
              IC = ID
              ID = ITEMP
              FACT1 = DBLE(ITJPO(JTR)*(NKJ(IC)+1))
              FACT2 = DBLE(ITJPO(ITR)*(NKJ(ID)+1))
              FACT = SQRT(FACT1/FACT2)
              IDL = (ITJPO(ITR)-ITJPO(JTR)+NKJ(IC)-NKJ(ID))/2
              IF (MOD(IDL,2).NE.0) FACT = -FACT
              XCOEF = FACT*XCOEF
            ENDIF
C
            IF (KK.EQ.0) THEN
C
C  electric case
C  -------------
C
              IXX = ISTOR(IC,ID)
C
C  the integrals are stored when the code is positive
C
              IF (IXX.GT.0) THEN
                HCOUL = PF(IXX)
                HBAB = QF(IXX)
C
              ELSE
C
C  calculate the Babushkin integral when the code is negative
C
                IF (IXX.LT.0) THEN
                  IXX = -IXX
                  HCOUL = PF(IXX)
                  CALL SPME(IC,ID,HCOUL,HBAB,HMAG,1)
                  ISTOR(IC,ID) = IXX
                  QF(IXX) = HBAB
C
                ELSE
C
C  calculate the integrals when the code is zero
C
                  HCOUL = ZERO
                  CALL SPME(IC,ID,HCOUL,HBAB,HMAG,0)
C
C  store the integrals if possible
C
                  IF (NUMSTO.LT.NUMX) THEN
                    NUMSTO = NUMSTO+1
                    IX = NSTART+NUMSTO
                    ISTOR(IC,ID) = IX
                    PF(IX) = HCOUL
                    QF(IX) = HBAB
C
C  use the symmetry of the COULOMB integral
C  store it provided option 19 is NOT set
C  When option 19 is set the COULOMB may have a gauge contribution.
C
                    IF (NUMSTO.LT.NUMX) THEN
                      IF (LTC(19).EQ.0) THEN
                        FACT = SQRT(DBLE(NKJ(IC)+1)/DBLE(NKJ(ID)+1))
                        IDL = (NKJ(IC)-NKJ(ID))/2
                        IF (MOD(IDL,2).NE.0) FACT = -FACT
                        NUMSTO = NUMSTO+1
                        IX = NSTART+NUMSTO
                        ISTOR(ID,IC) = -IX
                        PF(IX) = -HCOUL*FACT
                      ENDIF
                    ENDIF
C
                  ENDIF
C
                ENDIF
C
              ENDIF
C
              ASFA = ASFA+COUVX*XCOEF*HCOUL
              ASFB = ASFB+COUVX*XCOEF*HBAB
C
              IF (LTC(8).EQ.1) THEN
                CSFA = COUVX*XCOEF*HCOUL
                CSFB = COUVX*XCOEF*HBAB
                WRITE (IWRITE,3080)ITR,JTR,COUVX,NP(IC),NH(IC),NP(ID),NH!
     +(ID),XCOEF,HCOUL,CSFA,ASFA
                WRITE (IPUNCH,3080)ITR,JTR,COUVX,NP(IC),NH(IC),NP(ID),NH!
     +(ID),XCOEF,HBAB,CSFB,ASFB
              ENDIF
C
            ELSE
C
C  magnetic case
C  -------------
C
              IXX = ISTOR(IC,ID)
C
C  the integral is stored when the code is positive
C
              IF (IXX.GT.0) THEN
                HMAG = PF(IXX)
C
              ELSE
C
C  calculate the integral when the code is zero
C
                CALL SPME(IC,ID,HCOUL,HBAB,HMAG,0)
C
C  store the integral if possible
C
                IF (NUMSTO.LT.NUMX) THEN
                  NUMSTO = NUMSTO+1
                  IX = NSTART+NUMSTO
                  ISTOR(IC,ID) = IX
                  PF(IX) = HMAG
C
C  use the symmetry of the magnetic integral
C
                  IF (NUMSTO.LT.NUMX) THEN
                    FACT = SQRT(DBLE(NKJ(IC)+1)/DBLE(NKJ(ID)+1))
                    IDL = (NKJ(IC)-NKJ(ID))/2
                    IF (MOD(IDL,2).NE.0) FACT = -FACT
                    NUMSTO = NUMSTO+1
                    IX = NSTART+NUMSTO
                    ISTOR(ID,IC) = IX
                    PF(IX) = HMAG*FACT
                  ENDIF
C
                ENDIF
C
              ENDIF
C
              ASFA = ASFA+COUVX*XCOEF*HMAG
C
              IF (LTC(8).EQ.1) THEN
                CSFA = COUVX*XCOEF*HMAG
                WRITE (IWRITE,3080)ITR,JTR,COUVX,NP(IC),NH(IC),NP(ID),NH!
     +(ID),XCOEF,HMAG,CSFA,ASFA
              ENDIF
C
            ENDIF
C
          ENDDO
C
   10     CONTINUE
        ENDDO
      ENDDO
      IF (LTC(8).EQ.1) THEN
        WRITE (IWRITE,3000)
      ENDIF
C
 3000 FORMAT (1X,70('-'))
 3010 FORMAT (1X,'Debug print from routine CSFM in OSCL module')
 3020 FORMAT (1X,' electric case - first gauge'/1X,                     !
     +' levels : LEV1,LEV2 : ',2I4)
 3030 FORMAT (1X,' electric case - second gauge'/1X,                    !
     +' levels : LEV1,LEV2 : ',2I4)
 3040 FORMAT (1X,' magnetic case'/1X,' levels : LEV1,LEV2 : ',2I4)
 3050 FORMAT (/' mixing coefficients (|c|>.01) for level ',I4)
 3060 FORMAT (1X,6(I4,' : ',F5.2))
 3070 FORMAT (/' ITR,JTR ... CSF labels'/                               !
     +' mixing  ... product of mixing coefficients ... = C(ITR,LEV1)*C',!
     +'(JTR,LEV2)'/                                                     !
     +' angular ... integral (MCT) ... d(ITR,JTR;ORB1,ORB2)'/           !
     +' radial  ... integral       ... I(ORB1,ORB2)'/                   !
     +' product ... = mixing*angular*radial'/                           !
     +' total   ... running total'//                                    !
     +'  ITR JTR  mixing    ORB1 ORB2  angular    radial     product  ',!
     +'   total'/)
 3080 FORMAT (1X,2I4,1P,E11.3,2(1X,I2,A2),4E11.3)
      END
C
C                             *******************
C
      SUBROUTINE CXK(S,IS,KAPS,NU,K,IBR,IEX)
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
C
C  External functions
C
      EXTERNAL CRE
      DOUBLE PRECISION CRE
C
C  Parameter variables
C
      DOUBLE PRECISION ZERO
      PARAMETER (ZERO=0.D0)
      DOUBLE PRECISION TWO
      PARAMETER (TWO=2.D0)
C
C  Argument variables
C
      DOUBLE PRECISION S(12)
      INTEGER IBR,IEX,IS(4),K
      INTEGER KAPS(4),NU
C
C  Local variables
C
      DOUBLE PRECISION A,B,D,DK
      DOUBLE PRECISION DK1,DK2,F1,F2
      DOUBLE PRECISION F3,F4,FK,G1
      DOUBLE PRECISION G2,G3,G4,GK
      DOUBLE PRECISION H
      INTEGER IA,IB,IC,ID
      INTEGER IK,IP,KA,KB
      INTEGER KC,KD,KK,MU
C
C  Common variables
C
      INTEGER IPUNCH,IREAD,IWRITE
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
      DO MU = 1,12
        S(MU) = ZERO
      ENDDO
C
      IA = IS(1)
      IB = IS(2)
      IC = IS(3)
      ID = IS(4)
C
      KA = KAPS(1)/2
      KB = KAPS(2)/2
      KC = KAPS(3)/2
      KD = KAPS(4)/2
C
      IF (IEX.NE.2) GOTO 10
C
      KK = KD
      IK = ID
      KD = KC
      ID = IC
      KC = KK
      IC = IK
C
   10 CONTINUE
      IF (IBR.EQ.1) GOTO 20
      IF (IBR.EQ.2) GOTO 60
      IF (IBR.EQ.3) GOTO 90
      IF (IBR.EQ.4) GOTO 100
      GOTO 150
C-----------------------------------------------------------------------
   20 CONTINUE
      IF (NU-K) 50,30,40
C
   30 CONTINUE
      S(1) = -((KA+KC)*(KD+KB))
      IF (K.EQ.0) GOTO 140
      D = DBLE(K*(K+1))
      H = CRE(KA,K,KC)*CRE(KB,K,KD)
      IF (MOD(K,2).NE.0) H = -H
      S(1) = S(1)*H/D
      DO MU = 2,4
        S(MU) = S(1)
      ENDDO
      RETURN
C
   40 CONTINUE
      DK1 = DBLE(KC-KA)
      DK2 = DBLE(KD-KB)
      FK = DBLE(K)
      GK = DBLE(K+1)
      G1 = DK1-GK
      G2 = DK1+GK
      G3 = DK2-GK
      G4 = DK2+GK
      KK = K+K+1
      H = CRE(KA,K,KC)*CRE(KB,K,KD)
      IF (MOD(K,2).NE.0) H = -H
      A = H*FK/GK/(KK*(KK+2))
      S(1) = A*G1*G3
      S(2) = A*G2*G4
      S(3) = A*G1*G4
      S(4) = A*G2*G3
      RETURN
C
   50 CONTINUE
      DK1 = DBLE(KC-KA)
      DK2 = DBLE(KD-KB)
      FK = DBLE(K)
      GK = DBLE(K+1)
      F1 = DK1-FK
      F2 = DK1+FK
      F3 = DK2-FK
      F4 = DK2+FK
      G1 = DK1-GK
      G2 = DK1+GK
      G3 = DK2-GK
      G4 = DK2+GK
      KK = K+K+1
      H = CRE(KA,K,KC)*CRE(KB,K,KD)
      IF (MOD(K,2).NE.0) H = -H
      A = H*GK/FK/(KK*(KK-2))
      S(1) = A*F2*F4
      S(2) = A*F1*F3
      S(3) = A*F2*F3
      S(4) = A*F1*F4
      B = H/(KK*KK)
      S(5) = B*F2*G3
      S(6) = B*F4*G1
      S(7) = B*F1*G4
      S(8) = B*F3*G2
      S(9) = B*F2*G4
      S(10) = B*F3*G1
      S(11) = B*F1*G3
      S(12) = B*F4*G2
      RETURN
C-----------------------------------------------------------------------
   60 CONTINUE
      IF (IA.EQ.IC .AND. IB.NE.ID) GOTO 80
      IF (IA.NE.IC .AND. IB.EQ.ID) GOTO 70
      GOTO 150
C
   70 CONTINUE
      IK = IB
      IB = IA
      IA = IK
      IK = ID
      ID = IC
      IC = IK
      KK = KB
      KB = KA
      KA = KK
      KK = KD
      KD = KC
      KC = KK
C
   80 CONTINUE
      IF (MOD(K,2).NE.1) RETURN
C
      DK = DBLE(K*(K+1))
      H = CRE(KA,K,KC)*CRE(KB,K,KD)/DK
      S(1) = H*(4*KA*(KB+KD))
      RETURN
C-----------------------------------------------------------------------
   90 CONTINUE
      IF (IA.NE.IC .OR. IB.NE.ID) GOTO 150
      IF (MOD(K,2).NE.1) RETURN
      DK = DBLE(K*(K+1))
      H = CRE(KA,K,KA)*CRE(KB,K,KB)/DK
      S(1) = H*(16*KA*KB)
      RETURN
C-----------------------------------------------------------------------
  100 CONTINUE
      IF (IA.NE.ID .OR. IB.NE.IC) GOTO 150
C
      IF (NU-K) 130,110,120
C
  110 CONTINUE
      S(1) = DBLE(KA+KB)*CRE(KA,K,KB)
      IP = ABS(KA)-ABS(KB)+K+1
      S(1) = S(1)*S(1)/(K*(K+1))
      IF (MOD(IP,2).NE.0) S(1) = -S(1)
      S(3) = S(1)
      S(2) = S(1)+S(1)
      RETURN
C
  120 CONTINUE
      DK = DBLE(KB-KA)
      GK = DBLE(K+1)
      FK = DBLE(K)
      G1 = DK+GK
      G2 = DK-GK
      KK = K+K+1
      H = CRE(KA,K,KB)**2
      IF (KA*KB.LT.0) H = -H
      A = H*FK/GK/(KK*(KK+2))
      S(1) = -A*G1*G1
      S(2) = -TWO*A*G1*G2
      S(3) = -A*G2*G2
      RETURN
C
  130 CONTINUE
      DK = DBLE(KB-KA)
      FK = DBLE(K)
      GK = DBLE(K+1)
      F1 = DK+FK
      F2 = DK-FK
      G1 = DK+GK
      G2 = DK-GK
      KK = K+K+1
      H = CRE(KA,K,KB)**2
      IF (KA*KB.LT.0) H = -H
      A = H*GK/FK/(KK*(KK-2))
      S(1) = -A*F2*F2
      S(2) = -TWO*A*F1*F2
      S(3) = -A*F1*F1
      B = H/(KK*KK)
      B = B+B
      S(4) = -B*F1*G2
      S(5) = -B*F2*G1
      S(6) = -B*F1*G1
      S(7) = -B*F2*G2
      RETURN
C-----------------------------------------------------------------------
  140 CONTINUE
      WRITE (IWRITE,3000) IS(1),IS(2),IS(3),IS(4),NU,IBR,IEX
      WRITE (IPUNCH,3000) IS(1),IS(2),IS(3),IS(4),NU,IBR,IEX
      STOP
C-----------------------------------------------------------------------
  150 CONTINUE
      WRITE (IWRITE,3010) IBR,IS(1),IS(2),IS(3),IS(4),NU,K,IEX
      WRITE (IPUNCH,3010) IBR,IS(1),IS(2),IS(3),IS(4),NU,K,IEX
      STOP
C-----------------------------------------------------------------------
 3000 FORMAT (/' CXK halted on illegal value K = 0'/                    !
     +' IS(1),IS(2),IS(3),IS(4),NU,IBR,IEX : ',4I3,2X,I3,2X,2I2)
 3010 FORMAT (/' CXK halted on type ',I2/                               !
     +' IBR,IS(1),IS(2),IS(3),IS(4),NU,K,IEX : ',I2,3X,4I3,2X,2I3,2X,I2)
      END
C
C                             *******************
C
      SUBROUTINE DAMP(CHECK,IC)
C
C-----------------------------------------------------------------------
C
C  This routine checks for convergence of the configuration mixing
C  coefficients, returning IC=0 at convergence and IC=1 otherwise.
C  This routine also damps the predicted changes to the above
C  coefficients if any change is large. This is done by taking a
C  linear combination of the old and new C.I. coefficients
C  in such a way that the largest change is CHECK.
C  The first C.I. vector is then re-normalised and the remainder
C  Schmidt orthogonalised in order of increasing energy and
C  then normalised.
C  The old coefficients are stored in an array CHK.
C  The predicted ones are stored in array CCR.
C
C  No subroutines called.
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  Parameter variables
C
      DOUBLE PRECISION EPS9
      PARAMETER (EPS9=1.D-9)
      INTEGER N10
      PARAMETER (N10=MXNX*MXNC)
C
C  Argument variables
C
      DOUBLE PRECISION CHECK
      INTEGER IC
C
C  Local variables
C
      DOUBLE PRECISION COM,DAM,FACTOR,OVLAP
      DOUBLE PRECISION RNORM,TBIG,TEST
      INTEGER I,IA,IADD,IAS
      INTEGER IB,IBIG,IBIGC,IBS
      INTEGER IEL,IELM,II,J
      INTEGER JJ,NCFTT,NF,NS
C
C  Common variables
C
      DOUBLE PRECISION HALF,ONE,TEN,TENTH
      DOUBLE PRECISION THREE,TWO,ZERO
      COMMON / CONS   / ZERO,HALF,TENTH,ONE,TWO,THREE,TEN
C
C  Common variables
C
      DOUBLE PRECISION ACCY,C,EPH,H
      DOUBLE PRECISION RNT,Z
      INTEGER N,NCPRIN,NW1
      COMMON / DEF01  / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN
C
C  Common variables
C
      INTEGER ICCMIN(MXNC),NCMIN
      COMMON / DEF07  / NCMIN,ICCMIN
C
C  Common variables
C
      DOUBLE PRECISION BREENG(MXNC),COUENG(MXNC)
      COMMON / ENRG1  / COUENG,BREENG
C
C  Common variables
C
      DOUBLE PRECISION EAV,UCF(MXNW)
      COMMON / HMAT   / EAV,UCF
C
C  Common variables
C
      INTEGER IPUNCH,IREAD,IWRITE
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
C
C  Common variables
C
      INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF
      INTEGER NP(MXNW),NW
      COMMON / ORB04  / NW,NCF,NP,NAK,IQ
C
C  Common variables
C
      DOUBLE PRECISION CCR(N10),CHK(N10)
      COMMON / SEMI   / CHK,CCR
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
      WRITE (IWRITE,3030)
      WRITE (IWRITE,3020) (UCF(I),I=1,NW)
      WRITE (IWRITE,3040)
      WRITE (IWRITE,3020) (COUENG(I),I=1,NCF)
      NCFTT = NCF*NCMIN
C
C   Examine each of the NCMIN (the number of levels the sum of whose
C   energy is to be minimised) vectors in turn and change sign of a
C   vector if its largest element has opposite sign to that of same
C   element in new vector. Then test magnitudes of predicted changes
C   to coefficients.
C
      IADD = 0
      IBIGC = 0
      IC = 0
      TBIG = ZERO
      DO IEL = 1,NCMIN
        IBIG = 1+IADD
        NS = 1+IBIG
        NF = NS+NCF-2
C
C   Find largest coefficient
C
        TEST = ABS(CHK(IBIG))+EPS9
        DO I = NS,NF
          IF (ABS(CHK(I)).LT.TEST) GOTO 10
          TEST = ABS(CHK(I))
          IBIG = I
   10     CONTINUE
        ENDDO
        NS = NS-1
        TEST = CHK(IBIG)*CCR(IBIG)
        IF (TEST.GT.ZERO) GOTO 20
C
C   Change sign of old vector if neccessary
C
        DO I = NS,NF
          CHK(I) = -CHK(I)
        ENDDO
C
C   Examine predicted changes in CI coefficients
C
   20   CONTINUE
        DO I = NS,NF
          TEST = ABS(CCR(I)-CHK(I))
          IF (TEST.GT.ACCY) IC = 1
          IF (TEST.LT.CHECK .OR. TEST.LT.TBIG) GOTO 30
          TBIG = TEST
          IBIGC = 1
   30     CONTINUE
        ENDDO
        IADD = IADD+NCF
      ENDDO
      IF (IBIGC.NE.0) GOTO 40
      WRITE (IWRITE,3000)
      GOTO 70
C
   40 CONTINUE
      IC = 1
C
C   Calculate damping factor
C
      DAM = ONE-CHECK/TBIG
      COM = ONE-DAM
      WRITE (IWRITE,3010) DAM
C
C   Calculate new CI coefficients
C
      DO I = 1,NCFTT
        CCR(I) = COM*CCR(I)+DAM*CHK(I)
      ENDDO
C
C   Renormalise lowest energy eigenvector
C
      RNORM = ZERO
      DO I = 1,NCF
        RNORM = RNORM+CCR(I)*CCR(I)
      ENDDO
      RNORM = ONE/SQRT(RNORM)
      DO I = 1,NCF
        CCR(I) = CCR(I)*RNORM
      ENDDO
      IF (NCMIN.EQ.1) GOTO 50
C
C   Schmidt orthogonalize remaining vectors
C
      IAS = 1+NCF
      DO IEL = 2,NCMIN
        IELM = IEL-1
        IBS = 1
        DO II = 1,IELM
C
C   Calculate overlap
C
          OVLAP = ZERO
          IA = IAS
          IB = IBS
          DO I = 1,NCF
            OVLAP = OVLAP+CCR(IA)*CCR(IB)
            IA = IA+1
            IB = IB+1
          ENDDO
C
C   Orthogonalise pair of vectors
C
          IA = IAS
          IB = IBS
          DO I = 1,NCF
            CCR(IA) = CCR(IA)-OVLAP*CCR(IB)
            IA = IA+1
            IB = IB+1
          ENDDO
          IBS = IBS+NCF
        ENDDO
C
C   Normalise vector which is now orthogonal to those of lower energy
C
        RNORM = ZERO
        NF = IAS+NCF-1
        DO I = IAS,NF
          RNORM = RNORM+CCR(I)*CCR(I)
        ENDDO
        RNORM = ONE/SQRT(RNORM)
        DO I = IAS,NF
          CCR(I) = CCR(I)*RNORM
        ENDDO
        IAS = IAS+NCF
      ENDDO
C
C   Evaluate mixing coefficients
C
      FACTOR = ONE/DBLE(NCMIN)
      DO I = 1,NCF
        COUENG(I) = ZERO
        II = I
        DO JJ = 1,NCMIN
          COUENG(I) = COUENG(I)+CCR(II)*CCR(II)
          II = II+NCF
        ENDDO
        COUENG(I) = SQRT(FACTOR*COUENG(I))
      ENDDO
      GOTO 60
C
   50 CONTINUE
      DO I = 1,NCF
        COUENG(I) = CCR(I)
      ENDDO
C
C   Evaluate generalised occupation numbers
C
   60 CONTINUE
      DO J = 1,NW
        UCF(J) = ZERO
        DO I = 1,NCF
          UCF(J) = UCF(J)+COUENG(I)*COUENG(I)*DBLE(IQ(J,I))
        ENDDO
      ENDDO
C
C   Store new CI coefficients in array of old coefficients for
C   next call to DAMP
C
   70 CONTINUE
      DO I = 1,NCFTT
        CHK(I) = CCR(I)
      ENDDO
      IF (IBIGC.EQ.0) RETURN
      WRITE (IWRITE,3030)
      WRITE (IWRITE,3020) (UCF(I),I=1,NW)
      WRITE (IWRITE,3040)
      WRITE (IWRITE,3020) (COUENG(I),I=1,NCF)
C
 3000 FORMAT (/' Change in CI mixing coefficients not damped')
 3010 FORMAT (/' Change in CI mixing coefficients damped by',1P,E13.5)
 3020 FORMAT (1X,1P,4E15.7)
 3030 FORMAT (/' generalised occupation numbers'/)
 3040 FORMAT (/' CI mixing coefficients'/)
      END
C
C                             *******************
C
      SUBROUTINE DATAIN(ISTOP,IO1,IO2,IO3,IR2,IR3,IP3)
C
C-----------------------------------------------------------------------
C
C   This subroutine controls the reading of the input data.
C   The free format input record reading routine CARDIN is used.
C
C
C     DATAIN
C         CARDIN
C         CFOUT
C         DATNR
C             CARDIN
C             MAN4
C                 COUP
C             MANOUT
C             REORDR
C         DATR
C         DATSCF
C             CARDIN
C         NROUT
C             MATOUT
C         TRANS
C             NRCSF
C                 JCLIST
C                 JJLS
C                     DRACAH
C                     GENSUM ---
C                     SSTC
C                         GENSUM ---
C                 LSTERM
C                 NJSYM ---
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  Parameter variables
C
      DOUBLE PRECISION EPS6
      PARAMETER (EPS6=1.D-6)
      DOUBLE PRECISION ZERO
      PARAMETER (ZERO=0.D0)
      DOUBLE PRECISION ONE
      PARAMETER (ONE=1.D0)
      DOUBLE PRECISION TWO
      PARAMETER (TWO=2.D0)
C
C---------- ND - max. no. of numbers read by CARDIN
C
      INTEGER ND
      PARAMETER (ND=MXNC+3)
C
C  Argument variables
C
      INTEGER IO1,IO2,IO3,IP3
      INTEGER IR2,IR3,ISTOP
C
C  Local variables
C
      CHARACTER*4 LAB(8)
      CHARACTER*2 NA
      CHARACTER*4 NB
      DOUBLE PRECISION BB,RT(ND)
      INTEGER I,IOP,IT(ND),J
      INTEGER JJ,NMAN,NN,NWM
C
C  Common variables
C
      DOUBLE PRECISION ATW,FACTAN,FACTCM,FACTEV
      DOUBLE PRECISION FACTRY
      COMMON / ATOM   / ATW,FACTRY,FACTCM,FACTEV,FACTAN
C
      INTEGER LABEL
      COMMON / CARD   / LABEL
C
      DOUBLE PRECISION ACCY,C,EPH,H
      DOUBLE PRECISION RNT,Z
      INTEGER N,NCPRIN,NW1
      COMMON / DEF01  / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN
C
      INTEGER IPUNCH,IREAD,IWRITE
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
C
      INTEGER LEVELS(MXNC),NLEV
      COMMON / LEVL   / NLEV,LEVELS
C
      DOUBLE PRECISION ENLEV(MXNC),GAUGE1,GAUGE2
      COMMON / LEVM   / ENLEV,GAUGE1,GAUGE2
C
      INTEGER IOPAR,KA
      COMMON / MCTA   / KA,IOPAR
C
      INTEGER ITC(50)
      COMMON / OPT01  / ITC
C
      INTEGER JTC(20)
      COMMON / OPT02  / JTC
C
      INTEGER KTC(20)
      COMMON / OPT03  / KTC
C
      INTEGER LTC(20)
      COMMON / OPT04  / LTC
C
      INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF
      INTEGER NP(MXNW),NW
      COMMON / ORB04  / NW,NCF,NP,NAK,IQ
C
      INTEGER ICHOP(MXNW,MXNC),IEXC
      INTEGER JCUP(10,MXNC),JQS(3,MXNW,MXNC)
      COMMON / ORB06  / JQS,JCUP,ICHOP,IEXC
C
      DOUBLE PRECISION CUTOFF
      COMMON / PATZ   / CUTOFF
C
      CHARACTER*80 IHED
      CHARACTER*20 RECORD
      COMMON / TITL   / IHED,RECORD
C
      DOUBLE PRECISION WFACT
      COMMON / WFAC   / WFACT
C
      DOUBLE PRECISION XCON1
      DOUBLE PRECISION XCON2
      DOUBLE PRECISION XCON3
      DOUBLE PRECISION XCON4
      DOUBLE PRECISION XCL
      DOUBLE PRECISION XPI
      DOUBLE PRECISION XTAU
      COMMON / XCONS / XCON1, XCON2, XCON3, XCON4, XCL, XPI, XTAU
C
      INTEGER IBUG1,IBUG2,IBUG3,IBUG4
      INTEGER IBUG5,IBUG6
      COMMON / DEBUG  / IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6
C
      CHARACTER*2 NH(MXNW)
      COMMON / ORB00  / NH
C
      INTEGER NKJ(MXNW),NKL(MXNW)
      COMMON / ORB05  / NKL,NKJ
C
      INTEGER ISPAR(MXNC),ITJPO(MXNC)
      COMMON / ORB07  / ITJPO,ISPAR
C
      INTEGER ITAB(16),JTAB(16),NROWS
      INTEGER NTAB(255)
      COMMON / TERMS  / NROWS,ITAB,JTAB,NTAB
C
      INTEGER MAXDIM(20),NAXDIM(20)
      COMMON / MAXDIM / MAXDIM,NAXDIM
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      DATA LAB/'MCP ','MCDF','END ','MCT ','MCBP','BENA','OSCL','STOP'/
C-----------------------------------------------------------------------
C
C ************************************************
C ***** Read a title and orbital data ************
C ************************************************
C
C   This READ statement uses an END parameter to find the end of data.
C   Replace if this is not available.
C
      LABEL = 1
      READ (IREAD,3000,END=120) IHED
      WRITE (IWRITE,3010) LABEL,IHED(1:40),IHED(41:80)
C
C   Set the options to 0.
C
C   If option J is to be set then at the appropriate place
C   input the number J. This will set JTC(J)=1 for example.
C   If JTC(J)=0 the option is not set .
C
C   ITC contains options for the MCDF program.
C
C   JTC(J) ,J=1,9 contains options for the angular programs.
C
C   JTC(J) ,J=10,20  control which programs are called.
C
C       10 - CFOUT called
C       11 - switch set on ANG input record to control calls to
C            all angular packages
C       12 - MCP  called
C       13 - MCDF called
C       14 - MCT  called
C       15 - MCBP called
C       16 - BENA called
C       17 - OSCL called
C
C   KTC contains options for BENA program.
C
C   LTC contains options for OSCL program.
C
      DO I = 1,50
        ITC(I) = 0
      ENDDO
C
      DO I = 1,20
        JTC(I) = 0
        KTC(I) = 0
        LTC(I) = 0
      ENDDO
C-----------------------------------------------------------------------
C
C   Input record 2
C
      CALL CARDIN(IREAD,IWRITE,0,LABEL,0,NA,NB,NN,RT,IT,ND)
      IF (NN.LT. 2.OR. NN.GT.6) GOTO 110
      NMAN = IT(1)
      NWM = IT(2)
C
      IF (NN.GE.3) THEN
        IOP = IT(3)
        IF (IOP.LT.-1 .OR. IOP.GT.3) GOTO 110
      ELSE
        IOP = 0
      ENDIF
C
      IF (NN.GE.4) THEN
        ATW = RT(4)
        IF (ATW.GT.EPS6) THEN
          BB = ONE/(ONE+XCON1/ATW)
        ELSE
          BB = ONE
        ENDIF
      ELSE
        ATW = ZERO
        BB = ONE
      ENDIF
C
C   Work out conversion factors taking account of atomic weight.
C
      FACTCM = XCON2*BB
      FACTEV = XCON3*BB
      FACTAN = XCON4
      FACTRY = TWO
C
      IF (NN.GE.5) THEN
        NCPRIN = IT(5)
      ELSE
        NCPRIN = -999
      ENDIF
C
      IF (NN.EQ.6) THEN
        CUTOFF = RT(6)
      ELSE
        CUTOFF = 1.D-10
      ENDIF
C-----------------------------------------------------------------------
C
C   Call routine DATR or DATNR for the orbital/CSF data.
C
C-----------------------------------------------------------------------
      IF (IOP.EQ.-1) THEN
        CALL DATR (NMAN, NWM,
     +             IWRITE, IREAD, LABEL, ND, RT, IT,
     +             ITAB, JTAB, NTAB,
     +             NH, IBUG1, IBUG2, IBUG3, IBUG4, IBUG5, IBUG6,
     +             ICHOP, IQ, ISPAR, ITJPO, JCUP, JQS, JTC, NAK, NCF,
     +             NKJ, NKL, NP, NW)
      ELSE
        CALL DATNRG (RT,IT,NMAN,NWM,ND)
      ENDIF
C
      IF (NW .GT.MAXDIM(1)) MAXDIM(1) = NW
      IF (NCF.GT.MAXDIM(2)) MAXDIM(2) = NCF
C
      IF (IOP.GT.0) THEN
        ITC(30) = 1
        CALL TRANS(NWM,NMAN)
        IF (IOP.EQ.3) ITC(31) = 1
      ENDIF
C
      IF (NCPRIN.LE.0 .OR. NCPRIN.GT.NCF) NCPRIN = NCF
C-----------------------------------------------------------------------
C
C   Process labels
C
C-----------------------------------------------------------------------
   10 CONTINUE
      CALL CARDIN(IREAD,IWRITE,0,LABEL,2,NA,NB,NN,RT,IT,ND)
      IF (LAB(1).EQ.NB) GOTO 20
      IF (LAB(2).EQ.NB) GOTO 50
      IF (LAB(3).EQ.NB) GOTO 80
      IF (LAB(4).EQ.NB) GOTO 30
      IF (LAB(5).EQ.NB) GOTO 40
      IF (LAB(6).EQ.NB) GOTO 60
      IF (LAB(7).EQ.NB) GOTO 70
      IF (LAB(8).EQ.NB) GOTO 90
      GOTO 100
C
C ***********
C *** MCP ***
C ***********
C
   20 CONTINUE
      IF (NN.GT.2) GOTO 110
      JTC(12) = JTC(11)
C
      DO I = 1,1
        JTC(I) = 0
      ENDDO
C
      IF (NN.GE.1) THEN
        IO1 = IT(1)
      ELSE
        IO1 = 1
      ENDIF
C
      IF (NN.GT.1) THEN
        DO I = 2,2
          JJ = IT(I)
          J = ABS(JJ)
          IF (J.LT. 1.OR. J.GT.1) GOTO 110
          JTC(J) = SIGN(1,JJ)
        ENDDO
      ENDIF
C
      IEXC = JTC(1)
      GOTO 10
C
C ***********
C *** MCT ***
C ***********
C
   30 CONTINUE
      IF (NN.LT. 1.OR. NN.GT.3) GOTO 110
      JTC(14) = JTC(11)
      KA = IT(1)
      IOPAR = 0
C
      IF (NN.GT.1) THEN
        IOPAR = IT(2)
      ENDIF
C
      IF (NN.EQ.3) THEN
        IO2 = IT(3)
      ELSE
        IO2 = 1
      ENDIF
C
      GOTO 10
C
C ************
C *** MCBP ***
C ************
C
   40 CONTINUE
      IF (NN.GT.1) GOTO 110
      JTC(15) = JTC(11)
      IF (NN.EQ.1) THEN
        IO3 = IT(1)
      ELSE
        IO3 = 1
      ENDIF
      GOTO 10
C
C ***********
C *** MCDF **
C ***********
C
C   Input record 9 --- MCDF call and options
C
   50 CONTINUE
      IF (NN.GT.50) GOTO 110
      JTC(13) = 1
      IF (NN.GT.0) THEN
        DO I = 1,NN
          J = IT(I)
          IF (J.LT. 1.OR. J.GT.50) GOTO 110
          ITC(J) = 1
        ENDDO
        IF (ITC(20).EQ.1) JTC(13) = 0
      ENDIF
C
      CALL DATSCF(RT,IT,ND,NMAN,IR2,IR3,IP3)
C
      GOTO 10
C
C ************
C *** BENA ***
C ************
C
C   Input record 20 --- Call BENA section of GRASP.
C
   60 CONTINUE
      IF (NN.GT.20) GOTO 110
      JTC(16) = 1
      IF (NN.GT.0) THEN
        DO I = 1,NN
          J = IT(I)
          IF (J.LT. 1.OR. J.GT.20) GOTO 110
          KTC(J) = 1
        ENDDO
        IF (KTC(20).EQ.1) JTC(16) = 0
      ENDIF
C
C set default for printing
C
      IF (KTC(16)+KTC(17)+KTC(18)+KTC(19).EQ.0) THEN
        KTC(16) = 1
        KTC(17) = 1
      ENDIF
C
C   Input record 21 --- BENA data
C
      CALL CARDIN(IREAD,IWRITE,0,LABEL,0,NA,NB,NN,RT,IT,ND)
      IF (NN.GT.1) GOTO 110
C
      IF (NN.GT.0) THEN
        WFACT = RT(1)
      ELSE
        WFACT = ONE
      ENDIF
C
      GOTO 10
C
C ************
C *** OSCL ***
C ************
C
C   Input record 22 --- Call OSCL section of GRASP.
C
   70 CONTINUE
      IF (NN.GT.20) GOTO 110
      JTC(17) = 1
C
      IF (NN.GT.0) THEN
        DO I = 1,NN
          J = IT(I)
          IF (J.LT. 1.OR. J.GT.20) GOTO 110
          LTC(J) = 1
        ENDDO
        IF (LTC(20).EQ.1) JTC(17) = 0
      ENDIF
C
C   Input record 23 --- OSCL data --- levels.
C
      CALL CARDIN(IREAD,IWRITE,0,LABEL,0,NA,NB,NN,RT,IT,ND)
      IF (NN.GT.NCF) GOTO 110
C
      IF (NN.GT.0) THEN
        NLEV = NN
        DO I = 1,NLEV
          J = IT(I)
          IF (J.LT. 1.OR. J.GT.NCF) GOTO 110
          LEVELS(I) = J
        ENDDO
      ELSE
        NLEV = NCF
        DO I = 1,NLEV
          LEVELS(I) = I
        ENDDO
      ENDIF
C
C   Input record 24 --- OPTIONAL --- Level energies
C
C   OPTIONAL if OSCL option 17 is set
C
      IF (LTC(17).EQ.1) THEN
        CALL CARDIN(IREAD,IWRITE,0,LABEL,0,NA,NB,NN,RT,IT,ND)
        IF (NN.NE.NLEV) GOTO 110
        DO I = 1,NLEV
          ENLEV(I) = RT(I)
        ENDDO
      ENDIF
C
C   Input record 25 --- OPTIONAL --- Gauge parameters
C
C   OPTIONAL if OSCL option 19 is set
C
      IF (LTC(19).EQ.1) THEN
        CALL CARDIN(IREAD,IWRITE,0,LABEL,0,NA,NB,NN,RT,IT,ND)
        IF (NN.NE.2) GOTO 110
        GAUGE1 = RT(1)
        GAUGE2 = RT(2)
      ENDIF
C
      GOTO 10
C
C *******************
C *** END or STOP ***
C *******************
C
C   Input record 26 --- End of input data block
C
   80 CONTINUE
      ISTOP = 0
      IF (JTC(10).EQ.1) CALL CFOUT
      CALL NROUT (NMAN,NWM,IOP,IWRITE)
      RETURN
C
   90 CONTINUE
      ISTOP = 1
      IF (JTC(10).EQ.1) CALL CFOUT
      CALL NROUT (NMAN,NWM,IOP,IWRITE)
      RETURN
C-----------------------------------------------------------------------
C
C   error messages
C
  100 CONTINUE
      WRITE (IWRITE,3040) NB
      STOP
C
  110 CONTINUE
      WRITE (IWRITE,3020)
      STOP
C
C   end of data encountered
C
  120 CONTINUE
      WRITE (IWRITE,3050)
      WRITE (IWRITE,3030)
      CALL DIMPRT
      PRINT 3030
      STOP
C-----------------------------------------------------------------------
 3000 FORMAT (A80)
 3010 FORMAT (/' Input records'//1X,I4,1X,'=',1X,A40/7X,A40)
 3020 FORMAT (/' ERROR in DATAIN : on above input record ... STOPPING')
 3030 FORMAT (/' **************************'/
     +' *** end of input data  ***'/' *** STOPPING in DATAIN ***'/
     +' **************************')
 3040 FORMAT (/' ERROR in DATAIN : incorrect label read - ',A4,
     +' ... STOPPING')
 3050 FORMAT (/1X,71('*'))
      END
C
C                             *******************
C
      SUBROUTINE DATNRG(RT,IT,NMAN,NWM,ND)
C
C-----------------------------------------------------------------------
C
C   This subroutine reads input record input defining non-relativistic
C   configurations and uses it to generate all possible relativistic
C   configurations which produce the required total J-value.
C
C        RT    - array of real numbers
C        IT    - array of integer numbers
C        NMAN  - number of NR config. to be defined
C        NWM   - number of NR orbitals to be defined
C        ND    - maximum number of numbers that can be read in CARDIN
C                i.e. the dimension of RT and IT
C
C-----------------------------------------------------------------------
C
C   NOPENX - maximum number of open shells in any configuration
C            that can be handled by this routine.
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  Parameter variables
C
      INTEGER NOPENX
      PARAMETER (NOPENX=4)
      INTEGER JSTMAX
      PARAMETER (JSTMAX=40)
C
C  Argument variables
C
      INTEGER ND
      DOUBLE PRECISION RT(ND)
      INTEGER IT(ND),NMAN,NWM
C
C  Local variables
C
      CHARACTER*2 LABT,NA
      CHARACTER*4 NB
      CHARACTER*2 NG(5),NHX
      INTEGER I,II,IPAR,ITEST
      INTEGER J,JF,JMAN,JMAX
      INTEGER JMAXX(MXNC),JMIN,JMINX(MXNC),JST
      INTEGER JST1,JST2,JSTORE(0:JSTMAX)
      INTEGER K,KCHOP(MXNW),M,NAKX
      INTEGER NELEC,NELEC1,NFULL,NL
      INTEGER NN,NOPEN1,NPN,NQ
      INTEGER NST
      LOGICAL MFAIL
C
C  Common variables
C
      INTEGER LABEL
      COMMON / CARD   / LABEL
C
C  Common variables
C
      INTEGER IBUG1,IBUG2,IBUG3,IBUG4
      INTEGER IBUG5,IBUG6
      COMMON / DEBUG  / IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6
C
C  Common variables
C
      INTEGER IPUNCH,IREAD,IWRITE
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
C
C  Common variables
C
      INTEGER MAXDIM(20),NAXDIM(20)
      COMMON / MAXDIM / MAXDIM,NAXDIM
C
C  Common variables
C
      INTEGER JPOS(4),MLX(4),MQX(4),NOPEN
      COMMON / NRD01  / MLX,MQX,JPOS,NOPEN
C
C  Common variables
C
      INTEGER NLX(MXNW),NPX(MXNW),NQX(MXNW,MXNC)
      COMMON / NRD03  / NPX,NLX,NQX
C
C  Common variables
C
      INTEGER IPOS(MXNW),KPOS(4,MXNC)
      INTEGER NPOS(MXNC)
      COMMON / NRD04  / IPOS,NPOS,KPOS
C
C  Common variables
C
      INTEGER JFX(MXNC),KOPEN(MXNC)
      COMMON / NRD08  / JFX,KOPEN
C
C  Common variables
C
      INTEGER JTC(20)
      COMMON / OPT02  / JTC
C
C  Common variables
C
      CHARACTER*2 NH(MXNW)
      COMMON / ORB00  / NH
C
C  Common variables
C
      INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF
      INTEGER NP(MXNW),NW
      COMMON / ORB04  / NW,NCF,NP,NAK,IQ
C
C  Common variables
C
      INTEGER NKJ(MXNW),NKL(MXNW)
      COMMON / ORB05  / NKL,NKJ
C
C  Common variables
C
      INTEGER ICHOP(MXNW,MXNC),IEXC
      INTEGER JCUP(10,MXNC),JQS(3,MXNW,MXNC)
      COMMON / ORB06  / JQS,JCUP,ICHOP,IEXC
C
C  Common variables
C
      INTEGER JCHOP(MXNW,MXNC)
      COMMON / SAVE2  / JCHOP
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      DATA NG/'P-','D-','F-','G-','H-'/
C-----------------------------------------------------------------------
      IF (NWM.GT.MXNW) THEN
        WRITE (IWRITE,3020)
        STOP
      ENDIF
      IF (NMAN.GT.MXNC) THEN
        WRITE (IWRITE,3030)
        STOP
      ENDIF
C
      IF (NWM.GT.MAXDIM(1)) MAXDIM(1) = NWM
      IF (NMAN.GT.MAXDIM(2)) MAXDIM(2) = NMAN
C
C   Input record 3 --- ORBITAL DATA
C
      NW = 0
      DO I = 1,NWM
        NW = NW+2
        CALL CARDIN(IREAD,IWRITE,0,LABEL,1,NHX,NB,NN,RT,IT,ND)
        NPN = IT(1)
        NAKX = IT(2)
        NL = -(NAKX+1)
        NFULL = 4*NL+2
C
        IF (NN.EQ.2) THEN
          DO K = 1,NMAN
            NQX(I,K) = NFULL
          ENDDO
        ELSE
          IF (NN.EQ.3) THEN
            DO K = 1,NMAN
              NQX(I,K) = IT(3)
            ENDDO
          ELSE
            IF (NN.EQ.NMAN+2) THEN
              DO K = 1,NMAN
                NQX(I,K) = IT(K+2)
              ENDDO
            ELSE
              GOTO 50
            ENDIF
          ENDIF
        ENDIF
C
        IF (NL.EQ.0) NW = NW - 1
        IF (NW.GT.MXNW) GOTO 60
C
        NPX(I) = NPN
        NLX(I) = NL
        IPOS(I) = NW
        DO K = 1,NMAN
          IF (NQX(I,K).EQ.0) THEN
            JCHOP(NW,K) = -1
          ELSE
            JCHOP(NW,K) = 0
          ENDIF
        ENDDO
        NP(NW) = NPN
        NAK(NW) = NAKX
        NKL(NW) = NL
        NKJ(NW) = NL+NL+1
        NH(NW) = NHX
C
        IF (NL.GT.0) THEN
          DO K = 1,NMAN
            IF (NQX(I,K).EQ.0) THEN
              JCHOP(NW-1,K) = -1
            ELSE
              JCHOP(NW-1,K) = 0
            ENDIF
          ENDDO
          NP(NW-1) = NPN
          NAK(NW-1) = NL
          NKL(NW-1) = NL
          NKJ(NW-1) = NL+NL-1
          NH(NW-1) = NG(NL)
        ENDIF
C
      ENDDO
C
      IF (NW.GT.MAXDIM(1)) MAXDIM(1) = NW
C
C   Check number of electrons in each configuration
C
      IF (NMAN.GT.1) THEN
        NELEC1 = 0
        DO J = 1,NWM
          NELEC1 = NELEC1+NQX(J,1)
        ENDDO
        DO I = 2,NMAN
          NELEC = 0
          DO J = 1,NWM
            NELEC = NELEC+NQX(J,I)
          ENDDO
          IF (NELEC.NE.NELEC1) GOTO 80
        ENDDO
      ENDIF
C
C ************
C *** ANG ****
C ************
C
C   Input record 4
C
C   OPTIONS FOR THE ANGULAR MOMENTUM PROGRAMS
C
      CALL CARDIN(IREAD,IWRITE,0,LABEL,2,NA,NB,NN,RT,IT,ND)
      IF (NN.GT.10) GOTO 50
C
      DO I = 1,10
        JTC(I) = 0
      ENDDO
C
      IF (NN.GT.0) THEN
        DO I = 1,NN
          J = IT(I)
          IF (J.LT.1 .OR. J.GT.10) GOTO 50
          JTC(J) = 1
        ENDDO
      ENDIF
C
C  use option 20 rather than 10
C
      JTC(20) = JTC(10)
C
      IF (JTC(7).EQ.1) THEN
        JTC(10) = 0
      ELSE
        JTC(10) = 1
      ENDIF
C
      IF (JTC(8).EQ.1) THEN
        JTC(11) = 0
      ELSE
        JTC(11) = 1
      ENDIF
C
      IBUG1 = JTC(1)
      IBUG2 = JTC(2)
      IBUG3 = JTC(3)
      IBUG4 = JTC(4)
      IBUG5 = JTC(5)
      IBUG6 = JTC(6)
C
C   Input record 5 --- non-relativistic CSF total J values
C
      CALL CARDIN(IREAD,IWRITE,0,LABEL,0,NA,NB,NN,RT,IT,ND)
C
      IF (NN.EQ.1 .AND. IT(1).GE.-1) THEN
        JF = NINT(RT(1)+RT(1))
        DO JMAN = 1,NMAN
          JMINX(JMAN) = JF
          JMAXX(JMAN) = JF
          JFX(JMAN) = JF
        ENDDO
      ELSE
        IF (NN.EQ.1) THEN
          DO JMAN = 1,NMAN
            CALL CARDIN(IREAD,IWRITE,0,LABEL,0,NA,NB,NN,RT,IT,ND)
            IF (NN.NE.2) GOTO 50
            JMIN = NINT(RT(1)+RT(1))
            JMAX = NINT(RT(2)+RT(2))
            IF (JMIN.LT.0 .OR. JMAX.LT.0 .OR. JMAX.LT.JMIN) GOTO 50
            JMINX(JMAN) = JMIN
            JMAXX(JMAN) = JMAX
            JFX(JMAN) = -2
          ENDDO
        ELSE
          IF (NN.EQ.3 .AND. IT(1).LT.0) THEN
            JMIN = NINT(RT(2)+RT(2))
            JMAX = NINT(RT(3)+RT(3))
            IF (JMIN.LT.0 .OR. JMAX.LT.0 .OR. JMAX.LT.JMIN) GOTO 50
            DO JMAN = 1,NMAN
              JMINX(JMAN) = JMIN
              JMAXX(JMAN) = JMAX
              JFX(JMAN) = -2
            ENDDO
          ELSE
            IF (NN.EQ.NMAN) THEN
              DO JMAN = 1,NMAN
                JF = NINT(RT(JMAN)+RT(JMAN))
                IF (JF.LT.0) GOTO 50
                JMINX(JMAN) = JF
                JMAXX(JMAN) = JF
                JFX(JMAN) = JF
              ENDDO
            ELSE
              GOTO 50
            ENDIF
          ENDIF
        ENDIF
      ENDIF
C-----------------------------------------------------------------------
C
C   Loop over each non-relativistic configuration in turn.
C    (1) determine which shells are open
C    (2) set up arrays KCHOP,MLX,MQX,JPOS for call to MAN4
C        which generates relativistic configurations
C
      MFAIL = .FALSE.
      NCF = 0
      JST1 = 0
      JST2 = 0
      DO JMAN = 1,NMAN
        JMIN = JMINX(JMAN)
        JMAX = JMAXX(JMAN)
        JF = JFX(JMAN)
C
        DO I = 1,NW
          KCHOP(I) = JCHOP(I,JMAN)
        ENDDO
C
C  Select open shells
C
        NOPEN = 0
        DO I = 1,NWM
          NL = NLX(I)
          NQ = NQX(I,JMAN)
          NFULL = 4*NL+2
          IF (NQ.EQ.NFULL .OR. NQ.EQ.0) GOTO 10
          NOPEN = NOPEN+1
          IF (NOPEN.GT.NOPENX) GOTO 70
          MLX(NOPEN) = NL
          MQX(NOPEN) = NQ
          JPOS(NOPEN) = IPOS(I)
          KPOS(NOPEN,JMAN) = I
   10     CONTINUE
        ENDDO
C
C   Set the parity
C
        IF (NOPEN.EQ.0) THEN
          IF (JF.GT.0) GOTO 20
          IPAR = 1
        ELSE
          ITEST = 0
          DO I = 1,NOPEN
            ITEST = ITEST+MLX(I)*MQX(I)
          ENDDO
          IF (MOD(ITEST,2).NE.0) THEN
            IPAR = -1
          ELSE
            IPAR = 1
          ENDIF
        ENDIF
C
C   Four open shells must always be defined in MAN4
C   and the following code includes extra dummy orbitals
C   to ensure this.
C
        IF (NOPEN.LT.NOPENX) THEN
          NOPEN1 = NOPEN+1
          II = 1
          DO I = NOPEN1,NOPENX
            MLX(I) = 0
            MQX(I) = 0
            JPOS(I) = NW+II
            II = II+1
          ENDDO
        ENDIF
C
        NST = NCF+1
        CALL MAN4(IWRITE,KCHOP,IPAR,JMIN,JMAX,MFAIL,JSTORE)
C
        DO JST = JSTMAX,0,-1
          IF (JSTORE(JST).GT.0) THEN
            JST1 = JST2+1
            JST2 = JST1+JSTORE(JST)-1
            IF (MOD(JST,2).EQ.0) THEN
              IF (IPAR.EQ.1) THEN
                WRITE (IWRITE,3070) JMAN,JSTORE(JST),JST/2,JST1,JST2
                WRITE (IPUNCH,3070) JMAN,JSTORE(JST),JST/2,JST1,JST2
              ELSE
                WRITE (IWRITE,3080) JMAN,JSTORE(JST),JST/2,JST1,JST2
                WRITE (IPUNCH,3080) JMAN,JSTORE(JST),JST/2,JST1,JST2
              ENDIF
            ELSE
              IF (IPAR.EQ.1) THEN
                WRITE (IWRITE,3090) JMAN,JSTORE(JST),JST,JST1,JST2
                WRITE (IPUNCH,3090) JMAN,JSTORE(JST),JST,JST1,JST2
              ELSE
                WRITE (IWRITE,3100) JMAN,JSTORE(JST),JST,JST1,JST2
                WRITE (IPUNCH,3100) JMAN,JSTORE(JST),JST,JST1,JST2
              ENDIF
            ENDIF
          ENDIF
        ENDDO
C
        NPOS(JMAN) = NCF
        KOPEN(JMAN) = NOPEN
C
        IF (.NOT.MFAIL) THEN
          IF (NCF.GT.NST .AND. JF.LT.0) THEN
            CALL REORDR(NST)
          ENDIF
        ENDIF
C
   20   CONTINUE
      ENDDO
C
      IF (MFAIL) THEN
        WRITE (IWRITE,3110) NCF,MXNC
        STOP
      ENDIF
C
C   Check for orbitals with zero occupation in all CSF and eliminate
C
      M = 0
      DO J = 1,NW
        DO I = 1,NCF
          IF (IQ(J,I).NE.0) GOTO 30
        ENDDO
        M = M+1
        GOTO 40
C
   30   CONTINUE
        IF (M.EQ.0) GOTO 40
        NP(J-M) = NP(J)
        LABT = NH(J)
        NH(J-M) = LABT
        NAK(J-M) = NAK(J)
        NKJ(J-M) = NKJ(J)
        NKL(J-M) = NKL(J)
        DO I = 1,NCF
          DO K = 1,3
            JQS(K,J-M,I) = JQS(K,J,I)
          ENDDO
          IQ(J-M,I) = IQ(J,I)
          ICHOP(J-M,I) = ICHOP(J,I)
        ENDDO
   40   CONTINUE
      ENDDO
      NW = NW-M
C
C   The equivalent input which could be read by DATR is now output
C   by a call to MANOUT.
C
      IF (JTC(20).EQ.1) THEN
        WRITE (IWRITE,3010)
        CALL MANOUT(0)
        WRITE (IWRITE,3010)
      ENDIF
C
      RETURN
C
C   Error messages
C
   50 CONTINUE
      WRITE (IWRITE,3000)
      STOP
C
   60 CONTINUE
      WRITE (IWRITE,3040)
      STOP
C
   70 CONTINUE
      WRITE (IWRITE,3050)
      STOP
C
   80 CONTINUE
      WRITE (IWRITE,3060)
      STOP
C
 3000 FORMAT (/' ERROR in DATNRG : on input record ... STOPPING')
 3010 FORMAT (1X)
 3020 FORMAT (/' ERROR in DATNRG : dimension ERROR for NWM ... STOPPING'!
     +)
 3030 FORMAT (/                                                         !
     +' ERROR in DATNRG : dimension ERROR for NMAN ... STOPPING')
 3040 FORMAT (/' ERROR in DATNRG : dimension ERROR for NW ... STOPPING')
 3050 FORMAT (/                                                         !
     +' ERROR in DATNRG : dimension ERROR for NOPEN ... STOPPING')
 3060 FORMAT (/                                                         !
     +' ERROR in DATNRG : inconsistency in the number of electrons ...',!
     +' STOPPING'/' Check orbital data')
 3070 FORMAT (' NR CSF ',I4,' ---> ',I4,' rel. CSFs with J = ',I4,      !
     +'   even (',I5,',',I5,')')
 3080 FORMAT (' NR CSF ',I4,' ---> ',I4,' rel. CSFs with J = ',I4,      !
     +'   odd  (',I5,',',I5,')')
 3090 FORMAT (' NR CSF ',I4,' ---> ',I4,' rel. CSFs with J = ',I4,      !
     +'/2 even (',I5,',',I5,')')
 3100 FORMAT (' NR CSF ',I4,' ---> ',I4,' rel. CSFs with J = ',I4,      !
     +'/2 odd  (',I5,',',I5,')')
 3110 FORMAT (/                                                         !
     +' ERROR in DATNRG : the number of CSFs generated in MAN4 exceeds',!
     +' the dimensions ... STOPPING'/'     NCF is ',I6,                 !
     +'    maximum allowed is ',I6)
      END
C
C                             *******************
C
      SUBROUTINE DATR (NMAN, NWM,
     + IWRITE, IREAD, LABEL, ND, RT, IT,
     + ITAB, JTAB, NTAB,
     + NH, IBUG1, IBUG2, IBUG3, IBUG4, IBUG5, IBUG6,
     + ICHOP, IQ, ISPAR, ITJPO, JCUP, JQS, JTC, NAK, NCF,
     + NKJ, NKL, NP, NW)
C
C $Log: DATR.f,v $
C Revision 1.2  2004/01/06 10:09:24  phn
C *** empty log message ***
C
C Revision 1.1  2003/12/11 10:24:45  phn
C Version grasp80d
C
C
CX
CX\routine{DATR}{(NMAN, NWM,\\
CX  IWRITE, IREAD, LABEL, ND, RT, IT,\\
CX  ITAB, JTAB, NTAB,\\
CX  NH, IBUG1, IBUG2, IBUG3, IBUG4, IBUG5, IBUG6,\\
CX  ICHOP, IQ, ISPAR, ITJPO, JCUP, JQS, JTC, NAK, NCF,\\
CX  NKJ, NKL, NP, NW)}
CX
CX  This routine reads the card input defining relativistic
CX  CSFs as described in the CPC write-up.
CX
CX i {\tt NMAN}             --- number of relativistic CSFs to be 
CX                              defined
CX
CX i {\tt NWM}              --- number of relativistic orbitals to be 
CX                              defined
CX
CX i {\tt IWRITE}           --- stream number for output
CX
CX i {\tt IREAD}            --- stream number for input
CX
CX   {\tt LABEL}            --- input record number
CX
CX   {\tt ND}               --- maximum number of numbers that can be 
CX                              read in CARDIN \ie the dimension of 
CX                              {\tt RT} and {\tt IT}
CX
CX   {\tt RT(ND)}           --- array of real numbers
CX
CX   {\tt IT(ND)}           --- array of integer numbers
CX
CX i {\tt ITAB(16)}         --- table of shell quantum numbers
CX
CX i {\tt JTAB(16)}         --- table of shell quantum numbers
CX
CX i {\tt NTAB(255)}        --- table of shell quantum numbers
CX
CX o {\tt NH(MXNW)}         --- orbital spectroscopic label
CX
CX o {\tt IBUG1}            --- debug parameter
CX
CX o {\tt IBUG2}            --- debug parameter
CX
CX o {\tt IBUG3}            --- debug parameter
CX
CX o {\tt IBUG4}            --- debug parameter
CX
CX o {\tt IBUG5}            --- debug parameter
CX
CX o {\tt IBUG6}            --- debug parameter
CX
CX o {\tt ICHOP(MXNW,MXNC)} --- open/closed flag for shells in CSFs
CX
CX o {\tt IQ(MXNW,MXNC)}    --- shell occupation in CSFs
CX
CX o {\tt ISPAR(MXNC)}      --- CSF parity
CX
CX o {\tt ITJPO(MXNC)}      --- CSF $2J+1$-value
CX
CX o {\tt JCUP(10,MXNC)}    --- shell coupling in CSFs
CX
CX o {\tt JQS(3,MXNW,MXNC)} --- shell quantum numbers in CSFs
CX
CX o {\tt JTC(20)}          --- options
CX
CX o {\tt NAK(MXNW)}        --- orbital $\kappa$-value
CX
CX o {\tt NCF}              --- number of CSFs
CX
CX o {\tt NKJ(MXNW)}        --- orbital $2j$-value
CX
CX o {\tt NKL(MXNW)}        --- orbital $l$-value
CX
CX o {\tt NP(MXNW)}         --- orbital $n$-value
CX
CX o {\tt NW}               --- number of orbitals
CX
C
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  Argument variables
C
      INTEGER NMAN
      INTEGER NWM
C
      INTEGER IWRITE
      INTEGER IREAD
      INTEGER LABEL
      INTEGER ND
      DOUBLE PRECISION RT(*)
      INTEGER IT(*)
C
      INTEGER ITAB(*)
      INTEGER JTAB(*)
      INTEGER NTAB(*)
C
      CHARACTER*2 NH(*)
      INTEGER IBUG1
      INTEGER IBUG2
      INTEGER IBUG3
      INTEGER IBUG4
      INTEGER IBUG5
      INTEGER IBUG6
      INTEGER ICHOP(MXNW,*)
      INTEGER IQ(MXNW,*)
      INTEGER ISPAR(*)
      INTEGER ITJPO(*)
      INTEGER JCUP(10,*)
      INTEGER JQS(3,MXNW,*)
      INTEGER JTC(20)
      INTEGER NAK(*)
      INTEGER NCF
      INTEGER NKJ(*)
      INTEGER NKL(*)
      INTEGER NP(*)
      INTEGER NW
C
C  Parameter variables
C
      DOUBLE PRECISION EPS
      PARAMETER (EPS=1.0D-05)
      DOUBLE PRECISION TWO
      PARAMETER (TWO=2.0D0)
      DOUBLE PRECISION ZERO
      PARAMETER (ZERO=0.0D0)
C
C  Statement functions
C
      LOGICAL ITRG
C
C  Local variables
C
      CHARACTER*4 LABEL4
      CHARACTER*2 NA
      CHARACTER*4 NB
      INTEGER I,IQF
      INTEGER ITEST,J
      INTEGER K,MK,NELEC,NELEC1
      INTEGER NN
      INTEGER IERR
      INTEGER J1,J2,J3,JBIG
      INTEGER JX,JXA,JXB,KTAB
      INTEGER MM,N1,N2,NFULL
      INTEGER NJ,NOCC,NOPEN
      INTEGER NQ,NRCUP,NRCUPX,NS
      LOGICAL OKAY
C
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C
      DATA LABEL4/'ANG '/
C-----------------------------------------------------------------------
      ITRG(J1,J2,J3) = J3.GE.ABS(J1-J2).AND.
     +                 J3.LE.J1+J2.AND.
     +                 MOD(J1+J2+J3,2).EQ.0
C-----------------------------------------------------------------------
      NCF = NMAN
      NW = NWM
      IF (NCF.GT.MXNC) GOTO 30
      IF (NW.GT.MXNW) GOTO 40
C
C  Card 2a
C  See description in DATAIN.
C
      DO J = 1,NW
C
        CALL CARDIN (IREAD,IWRITE,0,LABEL,1,NH(J),NB,NN,RT,IT,ND)
C
        NP(J) = IT(1)
        NAK(J) = IT(2)
C
        K = NAK(J)
        MK = ABS(K)
        IQF = MK+MK
        NKJ(J) = IQF-1
        NKL(J) = MK+(SIGN(1,K)-1)/2
C
        IF (NN.EQ.2) THEN
          DO I = 1,NCF
            IQ(J,I) = IQF
          ENDDO
        ELSEIF (NN.EQ.3) THEN
            DO I = 1,NCF
              IQ(J,I) = IT(3)
            ENDDO
        ELSEIF (NN.EQ.NCF+2) THEN
          DO I = 1,NCF
            IQ(J,I) = IT(I+2)
          ENDDO
        ELSE
          GOTO 20
        ENDIF
C
      ENDDO
C
C  Check number of electrons in each CSF
C
      IF (NCF.GT.1) THEN
        NELEC1 = 0
        DO J = 1,NW
          NELEC1 = NELEC1+IQ(J,1)
        ENDDO
        DO I = 2,NCF
          NELEC = 0
          DO J = 1,NW
            NELEC = NELEC+IQ(J,I)
          ENDDO
          IF (NELEC.NE.NELEC1) GOTO 50
        ENDDO
      ENDIF
C
C  Set up array ISPAR defining parity of the CSF
C
      DO I = 1,NCF
        ISPAR(I) = 1
        ITEST = 0
        DO J = 1,NW
          ITEST = ITEST+NKL(J)*IQ(J,I)
        ENDDO
        IF (MOD(ITEST,2).NE.0) ISPAR(I)=-1
      ENDDO
C
C ************
C *** ANG ****
C ************
C
C  Card 2b
C  See description in DATAIN.
C
      CALL CARDIN (IREAD,IWRITE,0,LABEL,2,NA,NB,NN,RT,IT,ND)
      IF (NB.NE.LABEL4) GOTO 60
      IF (NN.GT.8) GOTO 20
      JTC(10) = 1
      JTC(11) = 1
      IF (NN.GT.0) THEN
        DO I = 1,NN
          J = IT(I)
          IF (J.LT.1.OR.J.GT.8) GOTO 20
          JTC(J) = 1
        ENDDO
        IF (JTC(7).EQ.1) JTC(10)=0
        IF (JTC(8).EQ.1) JTC(11)=0
      ENDIF
C
C  Set the debug parameters
C
      IBUG1 = JTC(1)
      IBUG2 = JTC(2)
      IBUG3 = JTC(3)
      IBUG4 = JTC(4)
      IBUG5 = JTC(5)
      IBUG6 = JTC(6)
C
C  NRCUPX+1 is the maximum number of open shells per configuration
C  allowed by arrays used in the angular sections of the package
C
      NRCUPX = 8
C
C  Card 2c
C  See description in DATAIN.
C
      IERR = 0
C
      DO I = 1,NCF
C
        JBIG = 1
        NOPEN = 0
        NJ = 0
        NS = 0
C
        DO J = 1,NW
C
          NFULL = NKJ(J)+1
          NQ = IQ(J,I)
          NOCC = MIN(NQ,NFULL-NQ)
C
C Set the ICHOP array
C
C  ICHOP(J,I) = 1   ... shell J in CSF I is full
C  ICHOP(J,I) = -1  ... shell J in CSF I is empty
C  ICHOP(J,I) = 0   ... shell J in CSF I is open
C
          IF (NOCC.GT.4) GOTO 70
          IF (NOCC.GT.2.AND.NFULL.GT.8) GOTO 80
C
          IF (NOCC.EQ.0) THEN
            ICHOP(J,I) = 1
            IF (NQ.EQ.0) ICHOP(J,I)=-1
          ELSE
            NOPEN = NOPEN+1
            ICHOP(J,I) = 0
            IF (NOCC.GT.1) NJ = NJ+1
            IF (NOCC.EQ.4) NS = NS+1
          ENDIF
C
        ENDDO
C
        NRCUP = MAX(NOPEN-1,0)
        IF (NRCUP.GT.NRCUPX) GOTO 110
C
        N1 = NRCUP+NJ+1
        N2 = N1+NS
        MM = 0
        NN = 0
C
        IF (N2.GT.1) THEN
          CALL CARDIN (IREAD,IWRITE,0,LABEL,0,NA,NB,NN,RT,IT,ND)
          IF (I.NE.IT(1).OR.NN.LT.N1.OR.NN.GT.N2) GOTO 90
          MM = 1
        ENDIF
C
        DO J = 1,NW
C
          NFULL = NKJ(J)+1
          NQ = IQ(J,I)
          NOCC = MIN(NQ,NFULL-NQ)
          JQS(2,J,I) = 0
C
          IF (NOCC.EQ.0) THEN
            JQS(1,J,I) = 0
            JQS(3,J,I) = 1
          ELSEIF (NOCC.EQ.1) THEN
            JQS(1,J,I) = 1
            JQS(3,J,I) = NFULL
            JBIG = NFULL
          ELSE
C
            MM = MM+1
            JBIG = INT(TWO*RT(MM)+EPS)+1
            KTAB = 1+NOCC+(NFULL*(NFULL-2))/8
            JXA = ITAB(KTAB)
            JXB = JTAB(KTAB)
            OKAY = .FALSE.
            DO JX = 1,JXA
              JXB = JXB+3
              IF (JBIG.EQ.NTAB(JXB)) OKAY = .TRUE.
            ENDDO
C
            IF (.NOT.OKAY) THEN
              IERR = IERR+1
              WRITE (IWRITE,3100) J
              GOTO 10
            ENDIF
C
            JQS(3,J,I) = JBIG
C
            IF (NOCC.EQ.2) THEN
              JQS(1,J,I) = 2
              IF (JBIG.EQ.1) JQS(1,J,I)=0
            ELSEIF (NOCC.EQ.3) THEN
              JQS(1,J,I) = 3
              IF (JBIG.EQ.NFULL) JQS(1,J,I)=1
            ELSEIF (NOCC.EQ.4) THEN
              IF (JBIG.EQ.5.OR.JBIG.EQ.9) THEN
                MM = MM+1
                JQS(1,J,I) = IT(MM)
                JXB = JTAB(KTAB)
                OKAY = .FALSE.
                DO JX = 1,JXA
                  JXB = JXB+3
                  IF (JBIG.EQ.NTAB(JXB).AND.
     +                IT(MM).EQ.NTAB(JXB-2)) OKAY = .TRUE.
                ENDDO
                IF (.NOT.OKAY) THEN
                  IERR = IERR+1
                  WRITE (IWRITE,3110) J
                  GOTO 10
                ENDIF
              ELSE
                JQS(1,J,I) = 4
                IF (JBIG.EQ.1 ) JQS(1,J,I)=0
                IF (JBIG.EQ.13) JQS(1,J,I)=2
              ENDIF
            ENDIF
C
          ENDIF
C
        ENDDO
C
        IF (NRCUP.GT.0) THEN
          DO J = 1,NRCUP
            MM = MM+1
            JCUP(J,I) = INT(TWO*RT(MM)+EPS)+1
          ENDDO
          JBIG = JCUP(NRCUP,I)
        ENDIF
C
C  Set the ITJPO array
C
        ITJPO(I) = JBIG
C
        IF (MM.NE.NN) GOTO 100
C
C  Check if the coupling scheme is consistent
C
        IF (NRCUP.GT.0) THEN
          MM = -1
          J1 = 0
          J2 = 0
          J3 = 0
          DO J = 1,NW
            NFULL = NKJ(J)+1
            NQ = IQ(J,I)
            NOCC = MIN(NQ,NFULL-NQ)
            IF (NOCC.GT.0) THEN
              J2 = JQS(3,J,I)-1
              IF (MM.LT.0) THEN
                MM = MM+1
                J1 = J2
              ELSE
                MM = MM+1
                J3 = JCUP(MM,I)-1
                IF (.NOT.ITRG(J1,J2,J3)) THEN
                  WRITE (IWRITE,3090) I
                  IERR = IERR+1
                ENDIF
                J1 = J3
              ENDIF
            ENDIF
          ENDDO
        ENDIF
C
   10   CONTINUE
C
      ENDDO
C
      IF (IERR.GT.0) THEN
        WRITE (IWRITE,3130)
        STOP
      ENDIF
C
      RETURN
C
C  Error messages
C
   20 CONTINUE
      WRITE (IWRITE,3000)
      STOP
   30 CONTINUE
      WRITE (IWRITE,3010)
      STOP
   40 CONTINUE
      WRITE (IWRITE,3020)
      STOP
   50 CONTINUE
      WRITE (IWRITE,3030)
      STOP
   60 CONTINUE
      WRITE (IWRITE,3040)
      STOP
   70 CONTINUE
      WRITE (IWRITE,3050) NOCC
      STOP
   80 CONTINUE
      WRITE (IWRITE,3060) NKJ(J),NOCC
      STOP
   90 CONTINUE
      WRITE (IWRITE,3070) I,N1,N2
      STOP
  100 CONTINUE
      WRITE (IWRITE,3080) MM
      STOP
  110 CONTINUE
      WRITE (IWRITE,3120) I
      STOP
C
 3000 FORMAT (
     +/' Stopping in routine DATR.'
     +/' Error on above data card.')
 3010 FORMAT (
     +/' Stopping in routine DATR.'
     +/' Dimension error for NCF.')
 3020 FORMAT (
     +/' Stopping in routine DATR.'
     +/' Dimension error for NW.')
 3030 FORMAT (
     +/' Stopping in routine DATR.'/
     +/' Inconsistency in the number of electrons.'
     +/' Check orbital data.')
 3040 FORMAT (
     +/' Stopping in routine DATR.'
     +/' Label ANG not found.'
     +/' Check input data.')
 3050 FORMAT (
     +/' Stopping in routine DATR.'
     +/' Program cannot handle shells with NOCC = ',I2)
 3060 FORMAT (
     +/' Stopping in routine DATR.'
     +/' Program cannot handle shells with 2J = ',I2,' and NOCC = ',I2)
 3070 FORMAT (
     +/' Stopping in routine DATR.'
     +/' Expect card for CSF ',I2,
     +' with between ',I2,' and ',I2,' numbers')
 3080 FORMAT (
     +/' Stopping in routine DATR.'
     +/1X,I2,' numbers expected')
 3090 FORMAT (
     +/' Incorrect coupling for CSF ',I2)
 3100 FORMAT (
     +/' Incorrect J value for subshell ',I2)
 3110 FORMAT (
     +/' Incorrect seniority for subshell ',I2)
 3120 FORMAT (
     +/' Stopping in routine DATR.'/
     +/' Too many open shells for CSF ',I2)
 3130 FORMAT (
     +/' Stopping in routine DATR.')
      END
C
C                             *******************
C
      SUBROUTINE DATSCF(RT,IT,ND,NCN,IR2,IR3,IP3)
C
C-----------------------------------------------------------------------
C
C   Input data for the MCDF program
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  Parameter variables
C
      DOUBLE PRECISION EPS30
      PARAMETER (EPS30=1.D-30)
C
C---------- NPARMX - max. no. of nuclear parameters
C
      INTEGER NPARMX
      PARAMETER (NPARMX=4)
C
C  Argument variables
C
      INTEGER NCN,ND
      DOUBLE PRECISION RT(ND)
      INTEGER IP3,IR2,IR3,IT(ND)
C
C  Local variables
C
      CHARACTER*4 LAB(7)
      CHARACTER*2 NA
      CHARACTER*4 NB,NTY(5)
      DOUBLE PRECISION CON,SCR,WA
      INTEGER I,II,IMARK(7),J
      INTEGER JJ,LLR,LUP,NN
C
C  Common variables
C
      DOUBLE PRECISION ATW,FACTAN,FACTCM,FACTEV
      DOUBLE PRECISION FACTRY
      COMMON / ATOM   / ATW,FACTRY,FACTCM,FACTEV,FACTAN
C
      INTEGER LABEL
      COMMON / CARD   / LABEL
C
      DOUBLE PRECISION HALF,ONE,TEN,TENTH
      DOUBLE PRECISION THREE,TWO,ZERO
      COMMON / CONS   / ZERO,HALF,TENTH,ONE,TWO,THREE,TEN
C
      DOUBLE PRECISION XCAX
      COMMON / CONVG  / XCAX
C
      DOUBLE PRECISION ACCY,C,EPH,H
      DOUBLE PRECISION RNT,Z
      INTEGER N,NCPRIN,NW1
      COMMON / DEF01  / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN
C
      DOUBLE PRECISION CHECK
      INTEGER NITIT
      COMMON / DEF04  / CHECK,NITIT
C
      DOUBLE PRECISION WT(MXNC)
      INTEGER ITY
      COMMON / DEF05  / WT,ITY
C
      INTEGER ICCMIN(MXNC),NCMIN
      COMMON / DEF07  / NCMIN,ICCMIN
C
      INTEGER JFIX(MXNW)
      COMMON / FIXD   / JFIX
C
      INTEGER IPUNCH,IREAD,IWRITE
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
C
      INTEGER NBPAR,NCPAR,NMOTYP
      COMMON / MPAR1  / NMOTYP,NBPAR,NCPAR
C
      DOUBLE PRECISION APAR,BBPAR(4),BPAR(4)
      DOUBLE PRECISION CCPAR(4),CPAR(4)
      COMMON / MPAR2  / APAR,BPAR,BBPAR,CPAR,CCPAR
c
      double precision fx
      integer istatx,npmin0
      common /nrbinf/fx,istatx,npmin0
C
      DOUBLE PRECISION PARM(4),Z1
      INTEGER NPARM,NUCTYP
      COMMON / NPAR   / PARM,Z1,NUCTYP,NPARM
C
      INTEGER IPOS(MXNW),KPOS(4,MXNC)
      INTEGER NPOS(MXNC)
      COMMON / NRD04  / IPOS,NPOS,KPOS
C
      INTEGER ITC(50)
      COMMON / OPT01  / ITC
C
      DOUBLE PRECISION CXP(MXNW)
      COMMON / ORB03  / CXP
C
      INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF
      INTEGER NP(MXNW),NW
      COMMON / ORB04  / NW,NCF,NP,NAK,IQ
C
      INTEGER NKJ(MXNW),NKL(MXNW)
      COMMON / ORB05  / NKL,NKJ
C
      INTEGER ISPAR(MXNC),ITJPO(MXNC)
      COMMON / ORB07  / ITJPO,ISPAR
C
      INTEGER NPOTYP
      COMMON / PPAR1  / NPOTYP
C
      DOUBLE PRECISION POLPAR(2)
      COMMON / PPAR2  / POLPAR
C
      INTEGER ILO(MXNW),IWO(MXNW),NWO
      COMMON / WRO    / NWO,IWO,ILO
C
      DOUBLE PRECISION XCON1
      DOUBLE PRECISION XCON2
      DOUBLE PRECISION XCON3
      DOUBLE PRECISION XCON4
      DOUBLE PRECISION XCL
      DOUBLE PRECISION XPI
      DOUBLE PRECISION XTAU
      COMMON / XCONS / XCON1, XCON2, XCON3, XCON4, XCL, XPI, XTAU
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      DATA NTY/'AL  ','EAL ','EOL ','OL  ','CI  '/
      DATA LAB/'VNUC','FIX ','LOAD','ORB ','SCR ','VMOD','VPOL'/
C-----------------------------------------------------------------------
C
C   Input record 10 --- Dataset I/O stream numbers.
C
      CALL CARDIN(IREAD,IWRITE,0,LABEL,0,NA,NB,NN,RT,IT,ND)
      IF (NN.GT.3) GOTO 210
      IR2 = 0
      IR3 = 0
      IP3 = 0
      IF (NN.GT.0) IR2 = IT(1)
      IF (NN.GT.1) IR3 = IT(2)
      IF (NN.GT.2) IP3 = IT(3)
C
C   Input record 11 --- Basic data.
C
      CALL CARDIN(IREAD,IWRITE,0,LABEL,0,NA,NB,NN,RT,IT,ND)
      IF (NN.EQ.0 .OR. NN.GT.9) GOTO 210
      Z = RT(1)
      H = 0.05D0
      RNT = 1.0D-05
      ACCY = 1.0D-08
      CON = ONE
      XCAX = ONE
      fx=three
      istatx=0
      npmin0=9999
C
      GOTO (60,50,40,30,20,10,9,8,7),NN
C
    7 continue
      if(it(9).gt.0)npmin0=it(9)
    8 continue
      istatx=it(8)
    9 continue
      if(rt(7).ge.one)fx=rt(7)
   10 CONTINUE
      XCAX = RT(6)
   20 CONTINUE
      IF (RT(5).GT.EPS30) CON = RT(5)
   30 CONTINUE
      IF (RT(4).GT.EPS30) ACCY = RT(4)
   40 CONTINUE
      IF (RT(3).GT.EPS30) RNT = RT(3)
   50 CONTINUE
      IF (RT(2).GT.EPS30) H = RT(2)
C
   60 CONTINUE
      C = XCL
      IF (ITC(25).EQ.1) CON=1.D4
      C = C*CON
C
      EPH = EXP(H)
      NW1 = NW+1
C
C   Optional input records.
C
      NUCTYP = 0
      NPOTYP = 0
      NMOTYP = 0
      NPARM = 0
      NWO = 0
      DO J = 1,NW
        JFIX(J) = 0
        ILO(J) = 0
        IWO(J) = 0
      ENDDO
C
      IF (ITC(33).EQ.1) THEN
        DO J = 1,NW
          CXP(J) = ZERO
        ENDDO
      ELSE
        DO J = 1,NW
          SCR = ZERO
          DO I = 1,NW
            IF (NP(I)-NP(J)) 80,70,90
   70       CONTINUE
            IF (NKL(I)-NKL(J)) 80,90,90
   80       CONTINUE
            SCR = SCR+IQ(I,1)
   90       CONTINUE
          ENDDO
          CXP(J) = SCR
        ENDDO
      ENDIF
C
      DO I = 1,7
        IMARK(I) = 0
      ENDDO
C
  100 CONTINUE
      CALL CARDIN(IREAD,IWRITE,0,LABEL,2,NA,NB,NN,RT,IT,ND)
      IF (NB.EQ.LAB(1)) GOTO 110
      IF (NB.EQ.LAB(2)) GOTO 130
      IF (NB.EQ.LAB(3)) GOTO 140
      IF (NB.EQ.LAB(4)) GOTO 150
      IF (NB.EQ.LAB(5)) GOTO 160
      IF (NB.EQ.LAB(6)) GOTO 170
      IF (NB.EQ.LAB(7)) GOTO 180
      IF (NB.EQ.NTY(1) .OR. NB.EQ.NTY(2)
     +                 .OR. NB.EQ.NTY(3)
     +                 .OR. NB.EQ.NTY(4)
     +                 .OR. NB.EQ.NTY(5)) GOTO 190
      GOTO 210
C
C   Input record 12 --- OPTIONAL --- Nuclear Type
C
  110 CONTINUE
      IF (IMARK(1).EQ.1) GOTO 210
      IF (NN.LT.1 .OR. NN.GT.NPARMX+1) GOTO 210
      NUCTYP = IT(1)
      IF (NUCTYP.EQ.0) GOTO 120
      NPARM = NN-1
C
      IF (NUCTYP.EQ.1) THEN
        IF (NPARM.GT.1) GOTO 210
        IF (NPARM.EQ.0) THEN
          PARM(1) = ATW
        ELSE
          PARM(1) = RT(2)
        ENDIF
        NPARM = 1
        GOTO 120
      ENDIF
C
      IF (NUCTYP.EQ.2) THEN
        IF (NPARM.GT.2) GOTO 210
        IF (NPARM.EQ.0) THEN
          IF (ATW.EQ.ZERO) GOTO 210
          PARM(1) = 2.2291D-05*(ATW**(ONE/THREE))-0.90676D-05
          PARM(2) = 1.039D-05
        ELSE
          IF (NPARM.EQ.1) THEN
            PARM(1) = RT(2)
            PARM(2) = 1.039D-05
          ELSE
            PARM(1) = RT(2)
            PARM(2) = RT(3)
          ENDIF
        ENDIF
        NPARM = 2
        GOTO 120
      ENDIF
C
      IF (NPARM.GT.0) THEN
        DO I = 1,NPARM
          PARM(I) = RT(I+1)
        ENDDO
      ENDIF
C
  120 CONTINUE
      IMARK(1) = 1
      GOTO 100
C
C   Input record 13 --- OPTIONAL --- Fixed Orbitals
C
  130 CONTINUE
      IF (IMARK(2).EQ.1) GOTO 210
      IF (NN.EQ.0 .OR. NN.GT.NW) GOTO 210  !Was NW-1. Allow for CI check
      DO J = 1,NN
        I = IT(J)
        JFIX(I) = 1
      ENDDO
      IMARK(2) = 1
      GOTO 100
C
C   Input record 14 --- OPTIONAL --- Source of orbitals.
C
  140 CONTINUE
      IF (IMARK(3).EQ.1) GOTO 210
      IF (NN.NE.NW) GOTO 210
      DO J = 1,NW
        ILO(J) = IT(J)
      ENDDO
      IMARK(3) = 1
      GOTO 100
C
C   Input record 15 --- OPTIONAL --- Orbitals to be dumped
C
  150 CONTINUE
      IF (IMARK(4).EQ.1) GOTO 210
      IF (NN.GT.NW) GOTO 210
      IF (IP3.EQ.0) GOTO 210
C
      IF (NN.GT.0) THEN
        DO J = 1,NN
          I = IT(J)
          IF (JFIX(I).EQ.0) THEN
            NWO = NWO+1
            IWO(NWO) = I
          ENDIF
        ENDDO
      ENDIF
C
      IMARK(4) = 1
      GOTO 100
C
C   Input record 16 --- OPTIONAL --- Orbital Screening
C
  160 CONTINUE
      IF (IMARK(5).EQ.1) GOTO 210
      IF (NN.NE.NW) GOTO 210
      DO J = 1,NN
        CXP(J) = RT(J)
      ENDDO
      IMARK(5) = 1
      GOTO 100
C
C   Input record 17 --- OPTIONAL --- Polarisation Potential
C
  170 CONTINUE
      IF (IMARK(6).EQ.1) GOTO 210
      IF (NN.LT.1) GOTO 210
      NPOTYP = IT(1)
      IF (NPOTYP.NE.0) THEN
        IF (NPOTYP.NE.1) GOTO 210
        IF (NN.LT.3) GOTO 210
        POLPAR(1) = RT(2)
        POLPAR(2) = RT(3)
      ENDIF
      IMARK(6) = 1
      GOTO 100
C
C   Input record 18 --- OPTIONAL --- Model Potential
C
  180 CONTINUE
      IF (IMARK(7).EQ.1) GOTO 210
      IF (NN.LT.1) GOTO 210
      NMOTYP = IT(1)
C
      IF (NMOTYP.NE.0) THEN
C
        IF (NMOTYP.NE.1) GOTO 210
        IF (NN.LT.3) GOTO 210
        NBPAR = IT(2)
        NCPAR = IT(3)
C
        IF (NN.NE.4+2*NBPAR+2*NCPAR) GOTO 210
        IF (NBPAR.GT.4) GOTO 210
        IF (NCPAR.GT.4) GOTO 210
C
        APAR = RT(3)
C
        DO I = 1,NBPAR
          BPAR(I) = RT(4+I)
        ENDDO
        DO I = 1,NBPAR
          BBPAR(I) = RT(4+NBPAR+I)
        ENDDO
        DO I = 1,NCPAR
          CPAR(I) = RT(4+NBPAR+NBPAR+I)
        ENDDO
        DO I = 1,NCPAR
          CCPAR(I) = RT(4+NBPAR+NBPAR+NCPAR+I)
        ENDDO
C
      ENDIF
C
      IMARK(7) = 1
      GOTO 100
C
C   Input record 19 --- Calculation type
C
  190 CONTINUE
      ITY = 1
      NCMIN = 0
      NITIT = 3
C
C   CI calculation
C
      IF (NB.EQ.NTY(5)) THEN
        IF (NN.GT.0) GOTO 210
        NITIT = 0
        GOTO 200
      ENDIF
C
C   Average level calculation
C
      IF (NB.EQ.NTY(1)) THEN
        IF (NN.EQ.0) GOTO 200
        IF (NN.GT.1) GOTO 210
        NITIT = IT(1)
        GOTO 200
      ENDIF
C
C   Extended average level calculation
C
      IF (NB.EQ.NTY(2)) THEN
C
        ITY = 2
        IF (NN.GT.NCF+1) GOTO 210
C
        IF (NN.EQ.0 .OR. NN.EQ.1) THEN
          IF (NN.EQ.1) NITIT = IT(1)
          DO I = 1,NCF
            WT(I) = DBLE(ITJPO(I))
          ENDDO
          GOTO 200
        ENDIF
C
        IF (NN.EQ.NCF .OR. NN.EQ.NCF+1) THEN
          IF (NN.EQ.NCF+1) NITIT = IT(NCF+1)
          DO I = 1,NCF
            WT(I) = RT(I)
          ENDDO
          GOTO 200
        ENDIF
C
        IF (NN.EQ.NCN .OR. NN.EQ.NCN+1) THEN
          IF (NN.EQ.NCN+1) NITIT = IT(NCN+1)
          LLR = 1
          DO J = 1,NCN
            LUP = NPOS(J)
            WA = RT(J)
            DO I = LLR,LUP
              WT(I) = WA
            ENDDO
            LLR = LUP+1
          ENDDO
          GOTO 200
        ELSE
          GOTO 210
        ENDIF
C
      ENDIF
C
C   Extended optimal level or optimal level calculation
C
      NITIT = 6
      CHECK = 0.15D0
      ITY = 3
C
      IF (NB.EQ.NTY(3)) THEN
        IF (NN.GT.NCF+3) GOTO 210
        NCMIN = IT(1)
        II = NCMIN+1
        JJ = 1
      ELSE
        IF (NB.NE.NTY(4)) GOTO 210
        IF (NN.GT.3 .OR. NN.LT.1) GOTO 210
        NCMIN = 1
        II = 1
        JJ = 0
      ENDIF
C
      IF (NN.LT.II .OR. NN.GT.II+2) GOTO 210
      DO I = 1,NCMIN
        ICCMIN(I) = IT(I+JJ)
      ENDDO
C
      IF (NN.EQ.II) GOTO 200
      NITIT = IT(II+1)
      IF (NN.EQ.II+1) GOTO 200
      CHECK = RT(II+2)
C
  200 CONTINUE
      IF (NCF.EQ.1) NCMIN = 0
      RETURN
C
C   Error message
C
  210 CONTINUE
      WRITE (IWRITE,3000)
      STOP
C
 3000 FORMAT (/' ERROR in DATSCF : on above input record ... STOPPING')
      END
C
C                             *******************
C
      SUBROUTINE DIMPRT
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
C
C  Common variables
C
      INTEGER IPUNCH,IREAD,IWRITE
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
C
C  Common variables
C
      INTEGER MAXDIM(20),NAXDIM(20)
      COMMON / MAXDIM / MAXDIM,NAXDIM
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
      WRITE (IWRITE,3000)
C
      IF (NAXDIM(2).GT.0) THEN
        WRITE (IWRITE,3010) MAXDIM(2),NAXDIM(2)
      ENDIF
C
      IF (NAXDIM(5).GT.0) THEN
        WRITE (IWRITE,3020) MAXDIM(5),NAXDIM(5)
      ENDIF
C
      IF (NAXDIM(17).GT.0) THEN
        WRITE (IWRITE,3030) MAXDIM(17),NAXDIM(17)
      ENDIF
C
      IF (NAXDIM(4).GT.0) THEN
        WRITE (IWRITE,3040) MAXDIM(4),NAXDIM(4)
      ENDIF
C
      IF (NAXDIM(3).GT.0) THEN
        WRITE (IWRITE,3050) MAXDIM(3),NAXDIM(3)
      ENDIF
C
      IF (NAXDIM(7).GT.0) THEN
        WRITE (IWRITE,3060) MAXDIM(7),NAXDIM(7)
      ENDIF
C
      IF (NAXDIM(1).GT.0) THEN
        WRITE (IWRITE,3070) MAXDIM(1),NAXDIM(1)
      ENDIF
C
      IF (NAXDIM(9).GT.0) THEN
        WRITE (IWRITE,3080) MAXDIM(9),NAXDIM(9)
      ENDIF
C
 3000 FORMAT (/' >>>> routine DIMPRT called'//                          !
     +' dimension                               max. used      max. set'!
     +/)
 3010 FORMAT (' NC  relativistic CSFs                 ',3X,I10,9X,I10)
 3020 FORMAT (' NE  exchange terms                    ',3X,I10,9X,I10)
 3030 FORMAT (' NG  radial grid points for /WAVE/     ',3X,I10,9X,I10)
 3040 FORMAT (' NM  angular coefficients              ',3X,I10,9X,I10)
 3050 FORMAT (' NO  Lagrange multipliers              ',3X,I10,9X,I10)
 3060 FORMAT (' NP  radial grid points                ',3X,I10,9X,I10)
 3070 FORMAT (' NW  relativistic orbitals             ',3X,I10,9X,I10)
 3080 FORMAT (' NX  dimension for EOL (=1 for AL,OL   ',3X,I10,9X,I10)
      END
C
C                             *******************
C
      SUBROUTINE DIMSET(IWRITE)
C
C-----------------------------------------------------------------------
C
C  This routine sets the dimensions for the code.
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  Argument variables
C
      INTEGER IWRITE
C
C  Local variables
C
      INTEGER I
C
C  Common variables
C
      INTEGER MAXDIM(20),NAXDIM(20)
      COMMON / MAXDIM / MAXDIM,NAXDIM
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
      DO I = 1,20
        MAXDIM(I) = 0
        NAXDIM(I) = 0
      ENDDO
C
      NAXDIM(1) = MXNW
      NAXDIM(2) = MXNC
      NAXDIM(3) = MXNO
      NAXDIM(4) = MXNM
      NAXDIM(5) = MXNE
      NAXDIM(7) = MXNP
      NAXDIM(9) = MXNX
      NAXDIM(17) = MXNG
C
C  The following code writes out information on the processed
C  version of the code.
C
      WRITE (IWRITE,3000)
      WRITE (IWRITE,3020)
      WRITE (IWRITE,3030) MXNC
      WRITE (IWRITE,3040) MXNE
      WRITE (IWRITE,3050) MXNG
      WRITE (IWRITE,3060) MXNM
      WRITE (IWRITE,3070) MXNO
      WRITE (IWRITE,3080) MXNP
      WRITE (IWRITE,3090) MXNW
      WRITE (IWRITE,3100) MXNX
      WRITE (IWRITE,3010)
C
 3000 FORMAT (/1X,71('*')/                                              !
     +' routine DIMSET : the code has been dimensioned as follows'/1X,71!
     +('*'))
 3010 FORMAT (/1X,71('*'))
 3020 FORMAT (/' The following dimensions have been set :'/)
 3030 FORMAT (1X,I10,' = NC  relativistic CSFs')
 3040 FORMAT (1X,I10,' = NE  exchange terms')
 3050 FORMAT (1X,I10,' = NG  radial grid points for /WAVE/')
 3060 FORMAT (1X,I10,' = NM  angular coefficients')
 3070 FORMAT (1X,I10,' = NO  Lagrange multipliers')
 3080 FORMAT (1X,I10,' = NP  radial grid points')
 3090 FORMAT (1X,I10,' = NW  relativistic orbitals')
 3100 FORMAT (1X,I10,' = NX  dimension for EOL (=1 for AL,EAL,OL)')
      END
C
C                             *******************
C
      SUBROUTINE DRACAH(I,J,K,L,M,N,RAC)
C
C-----------------------------------------------------------------------
C
C   Evaluates Racah coefficient
C
C-----------------------------------------------------------------------
C
C This table shows results from calling DRACAH for all values of the
C arguments from 0 to jmax.
C   numc   --- number of coefficients calculated
C   numr   --- number of coefficients read from table
C   numsto --- number of non-zero coefficients stored
C              (only non-zero coefficients are stored in aray XSTO)
C If you choose MXNY to be one of these jmax values then
C numsto would be the dimension required for array XSTO. 
C
C jmax : 0 numc :      1 numr :       0 numsto :      1
C jmax : 1 numc :     19 numr :      45 numsto :      4
C jmax : 2 numc :    144 numr :     585 numsto :     17
C jmax : 3 numc :    676 numr :    3420 numsto :     48
C jmax : 4 numc :   2350 numr :   13275 numsto :    128
C jmax : 5 numc :   6651 numr :   40005 numsto :    288
C jmax : 6 numc :  16219 numr :  101430 numsto :    613
C jmax : 7 numc :  35344 numr :  226800 numsto :   1176
C jmax : 8 numc :  70551 numr :  460890 numsto :   2171
C jmax : 9 numc : 131275 numr :  868725 numsto :   3757
C jmax :10 numc : 230626 numr : 1540935 numsto :   6273
C
C  MXNY = NY  dimension used for table in DRACAH
C
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C
      IMPLICIT NONE
C
C  Parameter variables
C
      INTEGER MXNY
      PARAMETER (MXNY=8)
      DOUBLE PRECISION ZERO
      PARAMETER (ZERO=0.D0)
      DOUBLE PRECISION ONE
      PARAMETER (ONE=1.D0)
      DOUBLE PRECISION TWO
      PARAMETER (TWO=2.D0)
      DOUBLE PRECISION EPS10
      PARAMETER (EPS10=1.D-10)
C
C  Argument variables
C
      INTEGER I,J,K,L
      INTEGER M,N
      DOUBLE PRECISION RAC
C
C  Local variables
C
      DOUBLE PRECISION RAC1,RAC2
      INTEGER ICODE,ICOUNT,IMARK,J1
      INTEGER J2,J3,J4,J5
      INTEGER J6,J7,KI,KK
      INTEGER NUMAX,NUMIN
C
C  Common variables
C
      DOUBLE PRECISION GAM(500)
      COMMON / RACAHG / GAM
C
C  Common variables
C
      DOUBLE PRECISION XSTO(2171)
      COMMON / RACAHS / XSTO
C
C  Common variables
C
      INTEGER*2 ISTO(0:MXNY,0:MXNY,0:MXNY,0:MXNY,0:MXNY,0:MXNY)
      COMMON / RACAHT / ISTO
C
C  Common variables
C
      INTEGER NUMC,NUMR,NUMSTO
      COMMON / RACAHV / NUMC,NUMR,NUMSTO
C
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IF (I.LE.MXNY .AND. J.LE.MXNY .AND. 
     +    K.LE.MXNY .AND. L.LE.MXNY .AND.
     +    M.LE.MXNY .AND. N.LE.MXNY) THEN
C
        IF (ISTO(I,J,K,L,M,N).GE.0) THEN
          ICODE = ISTO(I,J,K,L,M,N)
          IF (ICODE.EQ.0) THEN
            RAC = ZERO
          ELSE
            RAC = XSTO(ICODE)
          ENDIF
          NUMR = NUMR+1
          GOTO 20
        ENDIF
C
        IMARK = 1
      ELSE
        IMARK = 0
      ENDIF
C-----------------------------------------------------------------------
C
C   Test the triangular conditions
C
C-----------------------------------------------------------------------
      RAC = ZERO
C
      J1 = I+J+M
      IF ((2*MAX(I,J,M)-J1).GT.0 .OR. MOD(J1,2).NE.0) GOTO 10
      J2 = K+L+M
      IF ((2*MAX(K,L,M)-J2).GT.0 .OR. MOD(J2,2).NE.0) GOTO 10
      J3 = I+K+N
      IF ((2*MAX(I,K,N)-J3).GT.0 .OR. MOD(J3,2).NE.0) GOTO 10
      J4 = J+L+N
      IF ((2*MAX(J,L,N)-J4).GT.0 .OR. MOD(J4,2).NE.0) GOTO 10
C
      J1 = J1/2
      J2 = J2/2
      J3 = J3/2
      J4 = J4/2
      J5 = (I+J+K+L)/2
      J6 = (I+L+M+N)/2
      J7 = (J+K+M+N)/2
C
      NUMIN = MAX(J1,J2,J3,J4)+1
      NUMAX = MIN(J5,J6,J7)+1
      RAC = ONE
C
      IF (NUMIN.NE.NUMAX) THEN
        NUMIN = NUMIN+1
        ICOUNT = 0
        DO KK = NUMIN,NUMAX
          KI = NUMAX-ICOUNT
          RAC1 = KI*(J5-KI+2)*(J6-KI+2)*(J7-KI+2)
          RAC2 = (KI-1-J1)*(KI-1-J2)*(KI-1-J3)*(KI-1-J4)
          RAC = ONE-(RAC*RAC1/RAC2)
          ICOUNT = ICOUNT+1
        ENDDO
        NUMIN = NUMIN-1
      ENDIF
C
      RAC = RAC*((-ONE)**(J5+NUMIN+1))*EXP((GAM(NUMIN+1)-GAM(NUMIN-J1)-G!
     +AM(NUMIN-J2)-GAM(NUMIN-J3)-GAM(NUMIN-J4)-GAM(J5+2-NUMIN)-GAM(J6+2-!
     +NUMIN)-GAM(J7+2-NUMIN))+((GAM(J1+1-I)+GAM(J1+1-J)+GAM(J1+1-M)-GAM(!
     +J1+2)+GAM(J2+1-K)+GAM(J2+1-L)+GAM(J2+1-M)-GAM(J2+2)+GAM(J3+1-I)+GA!
     +M(J3+1-K)+GAM(J3+1-N)-GAM(J3+2)+GAM(J4+1-J)+GAM(J4+1-L)+GAM(J4+1-N!
     +)-GAM(J4+2))/TWO))
C-----------------------------------------------------------------------
   10 CONTINUE
      NUMC = NUMC+1
      IF (IMARK.EQ.1) THEN
C
        IF (ABS(RAC).GT.EPS10) THEN
          IF (NUMSTO.EQ.2171) GOTO 20
          NUMSTO = NUMSTO+1
          XSTO(NUMSTO) = RAC
          ICODE = NUMSTO
        ELSE
          ICODE = 0
        ENDIF
C
        ISTO(I,J,K,L,M,N) = ICODE
        ISTO(L,K,J,I,M,N) = ICODE
        ISTO(L,J,K,I,N,M) = ICODE
        ISTO(I,K,J,L,N,M) = ICODE
        ISTO(J,I,L,K,M,N) = ICODE
        ISTO(K,L,I,J,M,N) = ICODE
        ISTO(K,I,L,J,N,M) = ICODE
        ISTO(J,L,I,K,N,M) = ICODE
C
      ENDIF
C-----------------------------------------------------------------------
   20 CONTINUE
      END
C
C                             *******************
C
      SUBROUTINE DUMP(IC,IP2)
C
C-----------------------------------------------------------------------
C
C  Dump to file with DS number IP2.
C
C  No routines called.
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  Parameter variables
C
      DOUBLE PRECISION ZERO
      PARAMETER (ZERO=0.D0)
      INTEGER N10
      PARAMETER (N10=MXNX*MXNC)
C
C  Argument variables
C
      INTEGER IC,IP2
C
C  Local variables
C
      DOUBLE PRECISION ZX
      INTEGER I,IJ,J,K
      INTEGER NCFTT,NGRID
C
C  Common variables
C
      DOUBLE PRECISION COUVEC(MXNC,MXNC)
      COMMON / BRET1  / COUVEC
C
C  Common variables
C
      DOUBLE PRECISION ACCY,C,EPH,H
      DOUBLE PRECISION RNT,Z
      INTEGER N,NCPRIN,NW1
      COMMON / DEF01  / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN
C
C  Common variables
C
      INTEGER ICCMIN(MXNC),NCMIN
      COMMON / DEF07  / NCMIN,ICCMIN
C
C  Common variables
C
      DOUBLE PRECISION BREENG(MXNC),COUENG(MXNC)
      COMMON / ENRG1  / COUENG,BREENG
C
C  Common variables
C
      DOUBLE PRECISION PZ(MXNW),QZ(MXNW)
      COMMON / EXCO   / PZ,QZ
C
C  Common variables
C
      DOUBLE PRECISION EAV,UCF(MXNW)
      COMMON / HMAT   / EAV,UCF
C
C  Common variables
C
      INTEGER IPUNCH,IREAD,IWRITE
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
C
C  Common variables
C
      DOUBLE PRECISION P(MXNP),PC(MXNP),Q(MXNP)
      DOUBLE PRECISION QC(MXNP)
      COMMON / INT2   / P,Q,PC,QC
C
C  Common variables
C
      DOUBLE PRECISION PARM(4),Z1
      INTEGER NPARM,NUCTYP
      COMMON / NPAR   / PARM,Z1,NUCTYP,NPARM
C
C  Common variables
C
      DOUBLE PRECISION ZZ(MXNP)
      COMMON / NPOT   / ZZ
C
C  Common variables
C
      DOUBLE PRECISION ECV(MXNO)
      INTEGER IECC(MXNO),NEC
      COMMON / OFFD   / ECV,IECC,NEC
C
C  Common variables
C
      CHARACTER*2 NH(MXNW)
      COMMON / ORB00  / NH
C
C  Common variables
C
      DOUBLE PRECISION E(MXNW)
      COMMON / ORB01  / E
C
C  Common variables
C
      INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF
      INTEGER NP(MXNW),NW
      COMMON / ORB04  / NW,NCF,NP,NAK,IQ
C
C  Common variables
C
      INTEGER ICHOP(MXNW,MXNC),IEXC
      INTEGER JCUP(10,MXNC),JQS(3,MXNW,MXNC)
      COMMON / ORB06  / JQS,JCUP,ICHOP,IEXC
C
C  Common variables
C
      INTEGER ISPAR(MXNC),ITJPO(MXNC)
      COMMON / ORB07  / ITJPO,ISPAR
C
C  Common variables
C
      INTEGER MPOIN(MXNW),MPOS(MXNW)
      COMMON / PATY   / MPOIN,MPOS
C
C  Common variables
C
      DOUBLE PRECISION CCR(N10),CHK(N10)
      COMMON / SEMI   / CHK,CCR
C
C  Common variables
C
      CHARACTER*80 IHED
      CHARACTER*20 RECORD
      COMMON / TITL   / IHED,RECORD
C
C  Common variables
C
      DOUBLE PRECISION PF(MXNG),QF(MXNG)
      COMMON / WAVE   / PF,QF
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
      IF (IP2.EQ.0) RETURN
C
      REWIND IP2
C-----------------------------------------------------------------------
      IF (IC.EQ.0) THEN
C
C...marks unconverged dump
C
        ZX = -Z
C
      ELSE
        ZX = Z
      ENDIF
C-----------------------------------------------------------------------
      WRITE (IP2) IHED,RECORD
      WRITE (IP2) NCMIN,NW,NCF,N
      WRITE (IP2) ZX,RNT,H,C
C-----------------------------------------------------------------------
      DO I = 1,NW
C
        NGRID = MPOIN(I)
        IJ = MPOS(I)
C
        DO J = 1,NGRID
          P(J) = PF(IJ)
          Q(J) = QF(IJ)
          IJ = IJ+1
        ENDDO
C
        IF (N.GT.NGRID) THEN
          DO J = NGRID+1,N
            P(J) = ZERO
            Q(J) = ZERO
          ENDDO
        ENDIF
C
        WRITE (IP2) NH(I),NP(I),NAK(I),E(I)
        WRITE (IP2) PZ(I),QZ(I)
        WRITE (IP2) (P(J),J=1,N), (Q(J),J=1,N)
C
      ENDDO
C-----------------------------------------------------------------------
      WRITE (IP2) (COUENG(I),I=1,NCF)
      WRITE (IP2) (UCF(I),I=1,NW)
      IF (NCMIN.GT.0) THEN
        NCFTT = NCF*NCMIN
        WRITE (IP2) (CCR(I),I=1,NCFTT)
        WRITE (IP2) (ICCMIN(I),I=1,NCMIN)
      ENDIF
C-----------------------------------------------------------------------
      WRITE (IP2) ((IQ(I,J),J=1,NCF),I=1,NW)
      WRITE (IP2) EAV, ((COUVEC(I,J),J=1,NCF),I=1,NCF),(BREENG(I),I=1,NC!
     +F)
C-----------------------------------------------------------------------
      WRITE (IP2) NEC
      IF (NEC.GT.0) WRITE (IP2) (IECC(I),I=1,NEC), (ECV(I),I=1,NEC)
C-----------------------------------------------------------------------
      WRITE (IP2) NUCTYP
      WRITE (IP2) (ZZ(I),I=1,N)
      WRITE (IP2) Z1
      WRITE (IP2) NPARM
      IF (NPARM.GT.0) WRITE (IP2) (PARM(I),I=1,NPARM)
C-----------------------------------------------------------------------
      WRITE (IP2) ((ICHOP(I,J),I=1,NW),J=1,NCF)
      WRITE (IP2) (((JQS(K,I,J),I=1,NW),J=1,NCF),K=1,3)
      WRITE (IP2) ((JCUP(I,J),I=1,8),J=1,NCF)
      WRITE (IP2) (ITJPO(J),J=1,NCF)
      WRITE (IP2) (ISPAR(J),J=1,NCF)
C-----------------------------------------------------------------------
      REWIND IP2
C-----------------------------------------------------------------------
      WRITE (IWRITE,3000)
C-----------------------------------------------------------------------
 3000 FORMAT (/' >>>> MCDF dump written')
      END
C
C                             *******************
C
      SUBROUTINE DUMPB(IO6)
C
C-----------------------------------------------------------------------
C
C   This routine writes a BENA dump in a form which can be
C   read by the routine LOAD and used in OSCL.
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  Parameter variables
C
      DOUBLE PRECISION ZERO
      PARAMETER (ZERO=0.D0)
      INTEGER N11
      PARAMETER (N11=MXNP+10)
C
C  Argument variables
C
      INTEGER IO6
C
C  Local variables
C
      INTEGER I,IJ,J,NEC
      INTEGER NGRID
C
C  Common variables
C
      DOUBLE PRECISION COUVEC(MXNC,MXNC)
      COMMON / BRET1  / COUVEC
C
C  Common variables
C
      DOUBLE PRECISION ACCY,C,EPH,H
      DOUBLE PRECISION RNT,Z
      INTEGER N,NCPRIN,NW1
      COMMON / DEF01  / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN
C
C  Common variables
C
      INTEGER ICCMIN(MXNC),NCMIN
      COMMON / DEF07  / NCMIN,ICCMIN
C
C  Common variables
C
      DOUBLE PRECISION BREENG(MXNC),COUENG(MXNC)
      COMMON / ENRG1  / COUENG,BREENG
C
C  Common variables
C
      DOUBLE PRECISION EAV,UCF(MXNW)
      COMMON / HMAT   / EAV,UCF
C
C  Common variables
C
      INTEGER IPUNCH,IREAD,IWRITE
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
C
C  Common variables
C
      DOUBLE PRECISION PARM(4),Z1
      INTEGER NPARM,NUCTYP
      COMMON / NPAR   / PARM,Z1,NUCTYP,NPARM
C
C  Common variables
C
      DOUBLE PRECISION ZZ(MXNP)
      COMMON / NPOT   / ZZ
C
C  Common variables
C
      CHARACTER*2 NH(MXNW)
      COMMON / ORB00  / NH
C
C  Common variables
C
      DOUBLE PRECISION E(MXNW)
      COMMON / ORB01  / E
C
C  Common variables
C
      INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF
      INTEGER NP(MXNW),NW
      COMMON / ORB04  / NW,NCF,NP,NAK,IQ
C
C  Common variables
C
      INTEGER MPOIN(MXNW),MPOS(MXNW)
      COMMON / PATY   / MPOIN,MPOS
C
C  Common variables
C
      DOUBLE PRECISION TA(N11),TB(N11)
      COMMON / TATB   / TA,TB
C
C  Common variables
C
      CHARACTER*80 IHED
      CHARACTER*20 RECORD
      COMMON / TITL   / IHED,RECORD
C
C  Common variables
C
      DOUBLE PRECISION PF(MXNG),QF(MXNG)
      COMMON / WAVE   / PF,QF
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
C
C  write basic information
C
C-----------------------------------------------------------------------
      REWIND IO6
      WRITE (IO6) IHED,RECORD
      WRITE (IO6) NCMIN,NW,NCF,N
      WRITE (IO6) Z,RNT,H,C
C-----------------------------------------------------------------------
C
C  write orbital information
C
C-----------------------------------------------------------------------
      DO I = 1,NW
        NGRID = MPOIN(I)
        IJ = MPOS(I)
        DO J = 1,NGRID
          TA(J) = PF(IJ)
          TB(J) = QF(IJ)
          IJ = IJ+1
        ENDDO
        IF (N.GT.NGRID) THEN
          DO J = NGRID+1,N
            TA(J) = ZERO
            TB(J) = ZERO
          ENDDO
        ENDIF
        WRITE (IO6) NH(I),NP(I),NAK(I),E(I)
        WRITE (IO6)
        WRITE (IO6) (TA(J),J=1,N), (TB(J),J=1,N)
      ENDDO
C-----------------------------------------------------------------------
C
C  write generalised occupation and mixing numbers
C
C-----------------------------------------------------------------------
      WRITE (IO6)
      WRITE (IO6) (UCF(I),I=1,NW)
      IF (NCMIN.GT.0) THEN
        WRITE (IO6)
        WRITE (IO6) (ICCMIN(I),I=1,NCMIN)
      ENDIF
C-----------------------------------------------------------------------
C
C  write occupation numbers and eigenvectors
C
C-----------------------------------------------------------------------
      EAV = ZERO
      WRITE (IO6) ((IQ(I,J),J=1,NCF),I=1,NW)
      WRITE (IO6) EAV, ((COUVEC(I,J),J=1,NCF),I=1,NCF),(COUENG(I),I=1,NC!
     +F)
C-----------------------------------------------------------------------
C
C  skip over Lagrange multipliers
C
C-----------------------------------------------------------------------
      NEC = 0
      WRITE (IO6) NEC
C-----------------------------------------------------------------------
C
C  write nuclear information
C
C-----------------------------------------------------------------------
      WRITE (IO6) NUCTYP
      WRITE (IO6) (ZZ(I),I=1,N)
      WRITE (IO6) Z1
      WRITE (IO6) NPARM
      IF (NPARM.GT.0) THEN
        WRITE (IO6) (PARM(I),I=1,NPARM)
      ENDIF
C-----------------------------------------------------------------------
      WRITE (IO6)
      WRITE (IO6)
      WRITE (IO6)
      WRITE (IO6)
      WRITE (IO6)
C-----------------------------------------------------------------------
      WRITE (IWRITE,3000)
C-----------------------------------------------------------------------
 3000 FORMAT (/' >>>> BENA dump has been written with the current data')
      END
C
C                             *******************
C
      FUNCTION EIGENV(J)
C
C-----------------------------------------------------------------------
C
C   This function computes an estimate of the eigenvalue E(J)
C   by use of the Rayleigh quotient. The appropriate
C   functions must be tabulated in the arrays YP, XTP and XTQ,
C   and the Rayleigh quotient is computed in terms of the
C   estimated wave functions stored in the arrays PF and QF.
C
C   The derivatives of P(R) and Q(R) are approximated by a
C   finite difference formula involving 5 consecutive points.
C   The integrand is therefore taken to be zero at two points
C   at each end of the table.
C
C   Subroutines called : QUAD
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      DOUBLE PRECISION EIGENV
      INCLUDE 'grasp0.inc'
C
C  Parameter variables
C
      DOUBLE PRECISION ZA
      PARAMETER (ZA=12.D0)
      DOUBLE PRECISION ZB
      PARAMETER (ZB=8.D0)
      INTEGER N11
      PARAMETER (N11=MXNP+10)
C
C  Argument variables
C
      INTEGER J
C
C  Local variables
C
      DOUBLE PRECISION RESULT,WA,WC,WD
      INTEGER I,IJ,L,M
      INTEGER NGRID,NN
C
C  Common variables
C
      DOUBLE PRECISION HALF,ONE,TEN,TENTH
      DOUBLE PRECISION THREE,TWO,ZERO
      COMMON / CONS   / ZERO,HALF,TENTH,ONE,TWO,THREE,TEN
C
C  Common variables
C
      DOUBLE PRECISION ACCY,C,EPH,H
      DOUBLE PRECISION RNT,Z
      INTEGER N,NCPRIN,NW1
      COMMON / DEF01  / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN
C
C  Common variables
C
      DOUBLE PRECISION RGRID(MXNP)
      COMMON / GRID   / RGRID
C
C  Common variables
C
      INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF
      INTEGER NP(MXNW),NW
      COMMON / ORB04  / NW,NCF,NP,NAK,IQ
C
C  Common variables
C
      INTEGER MPOIN(MXNW),MPOS(MXNW)
      COMMON / PATY   / MPOIN,MPOS
C
C  Common variables
C
      DOUBLE PRECISION XTP(MXNP),XTQ(MXNP),YP(MXNP)
      DOUBLE PRECISION YQ(MXNP)
      COMMON / POTE   / YP,YQ,XTP,XTQ
C
C  Common variables
C
      DOUBLE PRECISION TA(N11),TB(N11)
      COMMON / TATB   / TA,TB
C
C  Common variables
C
      DOUBLE PRECISION PF(MXNG),QF(MXNG)
      COMMON / WAVE   / PF,QF
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
      NGRID = MPOIN(J)
      M = 2
      DO I = 1,M
        TA(I) = ZERO
        L = NGRID+1-I
        TA(L) = ZERO
      ENDDO
C
      NN = NGRID-M
      M = M+1
C
      WC = C+C
      WA = WC*C
      WC = WC*NAK(J)
      WD = C/(ZA*H)
C
      IJ = MPOS(J)+M-1
      DO I = M,NN
        TA(I) = WA*RGRID(I)*QF(IJ)**2+YP(I)*(PF(IJ)**2+QF(IJ)**2)-WC*PF(!
     +IJ)*QF(IJ)+C*(PF(IJ)*XTQ(I)-QF(IJ)*XTP(I))-WD*(QF(IJ)*(PF(IJ-2)+ZB!
     +*(PF(IJ+1)-PF(IJ-1))-PF(IJ+2))-PF(IJ)*(QF(IJ-2)+ZB*(QF(IJ+1)-QF(IJ!
     +-1))-QF(IJ+2)))
        IJ = IJ+1
      ENDDO
C
      CALL QUAD(NGRID,RESULT)
      EIGENV = RESULT
C
      END
C
C                             *******************
C
      SUBROUTINE ENGOUT(E,N,IWRITE)
C
C-----------------------------------------------------------------------
C
C  This routine prints energy levels in a.u., cm-1, and eV using the
C  correct value for the Rydberg.
C
C  No subroutines called.
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  Argument variables
C
      DOUBLE PRECISION E(MXNC)
      INTEGER IWRITE,N
C
C  Local variables
C
      DOUBLE PRECISION EAU,ECM,EEV
      INTEGER I
C
C  Common variables
C
      DOUBLE PRECISION ATW,FACTAN,FACTCM,FACTEV
      DOUBLE PRECISION FACTRY
      COMMON / ATOM   / ATW,FACTRY,FACTCM,FACTEV,FACTAN
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
      WRITE (IWRITE,3000)
C
      DO I = 1,N
        EAU = E(I)
        ECM = EAU*FACTCM
        EEV = EAU*FACTEV
        WRITE (IWRITE,3010) I,EAU,ECM,EEV
      ENDDO
C
      IF (N.EQ.1) RETURN
      WRITE (IWRITE,3020)
      DO I = 2,N
        EAU = E(I)-E(1)
        ECM = EAU*FACTCM
        EEV = EAU*FACTEV
        WRITE (IWRITE,3010) I,EAU,ECM,EEV
      ENDDO
C
 3000 FORMAT (//' Eigenenergies'//                                      !
     +' Level       a.u.                cm-1                    eV'/)
 3010 FORMAT (1X,I4,4X,1P,3E20.10)
 3020 FORMAT (//' Eigenenergies relative to the lowest'//               !
     +' Level       a.u.                cm-1                    eV'/)
      END
C
C                             *******************
C
      SUBROUTINE FACTT
C
C-----------------------------------------------------------------------
C
C   Calculates the logs of factorials required by the Racah coefficient
C   routine DRACAH
C
C-----------------------------------------------------------------------
C  MXNY = NY  dimension used for table in DRACAH
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C
      IMPLICIT NONE
C
C  Parameter variables
C
      INTEGER MXNY
      PARAMETER (MXNY=8)
      DOUBLE PRECISION THIRTY
      PARAMETER (THIRTY=3.D1)
      DOUBLE PRECISION ONE
      PARAMETER (ONE=1.D0)
      DOUBLE PRECISION TWO
      PARAMETER (TWO=2.D0)
C
C  Local variables
C
      DOUBLE PRECISION X
      INTEGER I,J,K,L
      INTEGER M,N
C
C  Common variables
C
      DOUBLE PRECISION GAM(500)
      COMMON / RACAHG / GAM
C
C  Common variables
C
      INTEGER*2 ISTO(0:MXNY,0:MXNY,0:MXNY,0:MXNY,0:MXNY,0:MXNY)
      COMMON / RACAHT / ISTO
C
C  Common variables
C
      INTEGER NUMC,NUMR,NUMSTO
      COMMON / RACAHV / NUMC,NUMR,NUMSTO
C
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      GAM(1) = ONE
      GAM(2) = ONE
      X = TWO
      DO I = 3,30
        GAM(I) = GAM(I-1)*X
        X = X+ONE
      ENDDO
      DO I = 1,30
        GAM(I) = LOG(GAM(I))
      ENDDO
      X = THIRTY
      DO I = 31,500
        GAM(I) = GAM(I-1)+LOG(X)
        X = X+ONE
      ENDDO
C
      IF (NUMSTO.EQ.0) THEN
        DO I = 0,MXNY
          DO J = 0,MXNY
            DO K = 0,MXNY
              DO L = 0,MXNY
                DO M = 0,MXNY
                  DO N = 0,MXNY
                    ISTO(I,J,K,L,M,N) = -1
                  ENDDO
                ENDDO
              ENDDO
            ENDDO
          ENDDO
        ENDDO
      ENDIF
C
      END
C
C                             *******************
C
      SUBROUTINE FIXJ(JA1,JA2,KA,IS,KS,NS,KJ23)
C
C-----------------------------------------------------------------------
C
C  Sets up the arrays J1 ,J2 ,J3 required
C  by the recoupling package.
C
C  No subroutines called.
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  Parameter variables
C
      INTEGER MANGM
      PARAMETER (MANGM=60)
      INTEGER MTRIAD
      PARAMETER (MTRIAD=20)
      INTEGER NPLX
      PARAMETER (NPLX=14)
C
C  Argument variables
C
      INTEGER IS(2),JA1,JA2,KA
      INTEGER KJ23,KS(2),NS
C
C  Local variables
C
      INTEGER II,IJ,JAF1,JJ
      INTEGER JK,JWW,N2,N3
      INTEGER NM1,NS1
C
C  Common variables
C
      INTEGER J1(MANGM),J2(MTRIAD,3)
      INTEGER J3(MTRIAD,3),MMOM,NMOM
      LOGICAL FREE(MANGM)
      COMMON / ANG00  / MMOM,NMOM,J1,J2,J3,FREE
C
C  Common variables
C
      INTEGER JBQ1(3,MXNW),JBQ2(3,MXNW)
      INTEGER JTQ1(3),JTQ2(3)
      COMMON / ANG08  / JBQ1,JBQ2,JTQ1,JTQ2
C
C  Common variables
C
      INTEGER JJC1(NPLX),JJC2(NPLX)
      COMMON / ANG10  / JJC1,JJC2
C
C  Common variables
C
      INTEGER JJQ1(3,MXNW),JJQ2(3,MXNW)
      COMMON / ANG12  / JJQ1,JJQ2
C
C  Common variables
C
      INTEGER JLIST(NPLX),KLIST(MXNW),NCORE,NPEEL
      COMMON / ANG13  / JLIST,KLIST,NPEEL,NCORE
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
C
C   SET UP THE J2 AND J3 ARRAYS
C
C-----------------------------------------------------------------------
      NM1 = NS-1
      IF (KJ23.EQ.1) GOTO 30
      NS1 = NS+1
      N2 = NS+NS
      N3 = N2+NS
C
      J2(1,1) = N3+2
      J2(1,2) = N3+3
      J2(1,3) = N3+1
      J2(2,1) = JA1
      J2(2,2) = N3+1
      J2(2,3) = N3-1
C
      J3(1,1) = JA2
      J3(1,2) = N3+2
      J3(1,3) = N3
C
      IF (NS.EQ.1) GOTO 20
C
      DO JWW = 1,NM1
        JJ = JWW+2
        J2(JJ,1) = NS+JWW-1
        J2(JJ,2) = JWW+1
        J2(JJ,3) = NS+JWW
C
        JK = JWW+1
        J3(JK,1) = N2+JWW-2
        J3(JK,2) = JWW+1
        J3(JK,3) = N2+JWW-1
      ENDDO
C
      J2(3,1) = 1
      IF (JA1.EQ.1) J2(3,1) = N3 - 1
C
      J3(2,1) = 1
      IF (JA2.EQ.1) J3(2,1) = N3
C
      J2(NS1,3) = N2-1
C
      J3(NS1,1) = N3-2
      J3(NS1,2) = N3+3
      J3(NS1,3) = N2-1
C
      IF (JA1.EQ.1) GOTO 10
      JAF1 = JA1+1
      J2(JAF1,2) = N3-1
C
   10 CONTINUE
      IF (JA2.EQ.1) GOTO 30
      J3(JA2,2) = N3
C
      IF (NS.GT.1) GOTO 30
   20 CONTINUE
      J3(2,1) = N3
      J3(2,2) = N3+3
      J3(2,3) = N3-1
C-----------------------------------------------------------------------
C
C   SET THE J1 ARRAY
C
C-----------------------------------------------------------------------
   30 CONTINUE
      II = 0
C
      DO JWW = 1,NS
        IJ = JLIST(JWW)
        II = II+1
        J1(II) = JBQ2(3,IJ)
      ENDDO
C
      IF (NS.EQ.1) GOTO 40
C
      DO JWW = 1,NM1
        II = II+1
        J1(II) = JJC1(JWW)
      ENDDO
C
      DO JWW = 1,NM1
        II = II+1
        J1(II) = JJC2(JWW)
      ENDDO
C
   40 CONTINUE
      II = II+1
      IJ = IS(1)
      J1(II) = JJQ1(3,IJ)
      J1(II+2) = KS(1)
      II = II+1
      IJ = IS(2)
      J1(II) = JJQ2(3,IJ)
      J1(II+2) = KS(2)
C
      II = II+3
      J1(II) = KA+KA+1
      MMOM = II
      NMOM = NS+2
C
      END
C
C                             *******************
C
      SUBROUTINE FZALF(ZEFF,I,SLFE)
C
C-----------------------------------------------------------------------
C
C  This routine obtains an estimate of the self energy contribution
C  to the energy resulting from either 1s, 2s, 2p- or 2p orbital in
C  the field of a point nucleus with effective charge ZEFF.
C  The values are interpolated among the values supplied by P.J. Mohr
C
C  Subroutine called: INTRPG
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  Argument variables
C
      DOUBLE PRECISION SLFE,ZEFF
      INTEGER I
C
C  Local variables
C
      DOUBLE PRECISION ARG(11),VAL1S(11),VAL2P1(11)
      DOUBLE PRECISION VAL2P3(11),VAL2S(11)
      INTEGER NUMVAL
C
C  Common variables
C
      INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF
      INTEGER NP(MXNW),NW
      COMMON / ORB04  / NW,NCF,NP,NAK,IQ
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C
C  1s data :
C
      DATA VAL1S/4.654D0,3.246D0,2.5519D0,2.1351D0,1.8644D0,1.6838D0,1.5!
     +675D0,1.5032D0,1.4880D0,1.5317D0,1.6614D0/
C
C  2s data :
C
      DATA VAL2S/4.8930D0,3.5063D0,2.8391D0,2.4550D0,2.2244D0,2.0948D0,2!
     +.0435D0,2.0650D0,2.1690D0,2.3870D0,2.7980D0/
C
C  2p- data :
C
      DATA VAL2P1/-0.1145D0,-0.0922D0,-0.0641D0,-0.0308D0,0.0082D0,0.054!
     +9D0,0.1129D0,0.1884D0,0.2934D0,0.4530D0,0.7250D0/
C
C  2p data
C
      DATA VAL2P3/0.1303D0,0.1436D0,0.1604D0,0.1794D0,0.1999D0,0.2215D0,!
     +0.2440D0,0.2671D0,0.2906D0,0.3141D0,0.3367D0/
C
C  Z data values :
C
      DATA ARG/10.0D0,20.0D0,30.0D0,40.0D0,50.0D0,60.0D0,70.0D0,80.0D0,9!
     +0.0D0,100.0D0,110.0D0/
C
C  Number of data points
C
      DATA NUMVAL/11/
C-----------------------------------------------------------------------
      IF (NP(I).GT.1) GOTO 10
C
C  1s case
C
      CALL INTRPG(ARG,VAL1S,ZEFF,NUMVAL,SLFE)
      RETURN
C
C  ns case
C
   10 CONTINUE
      IF (NAK(I).EQ.-1) CALL INTRPG(ARG,VAL2S,ZEFF,NUMVAL,SLFE)
C
C  np- case
C
      IF (NAK(I).EQ.1) CALL INTRPG(ARG,VAL2P1,ZEFF,NUMVAL,SLFE)
C
C  np case
C
      IF (NAK(I).EQ.-2) CALL INTRPG(ARG,VAL2P3,ZEFF,NUMVAL,SLFE)
C
      END
C
C                             *******************
C
      FUNCTION GAMF(XA)
C
C-----------------------------------------------------------------------
C
C  The value of this function is the gamma function of the
C  argument XA.
C
C  The recurrence relation for the gamma function is used to
C  reduce the argument to a corresponding value in the range
C  (1,2). In this range the Chebyshev series is used,
C  the coefficients being taken from Chebyshev Series for
C  Mathematical Functions, by C.W.Clenshaw, Maths Tables Vol 5,
C  H.M.S.O., London, 1962.
C
C  No subroutines called.
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      DOUBLE PRECISION GAMF
C
C  Parameter variables
C
      DOUBLE PRECISION Z1
      PARAMETER (Z1=-.3339646306868D-7)
      DOUBLE PRECISION Z2
      PARAMETER (Z2=.2689759964406D-6)
      DOUBLE PRECISION Z3
      PARAMETER (Z3=.29600117751880D-5)
      DOUBLE PRECISION Z4
      PARAMETER (Z4=-.804814124978471D-4)
      DOUBLE PRECISION Z5
      PARAMETER (Z5=.416609138709689D-3)
      DOUBLE PRECISION Z6
      PARAMETER (Z6=.5065798640286087D-2)
      DOUBLE PRECISION Z7
      PARAMETER (Z7=-.6419254361091582D-1)
      DOUBLE PRECISION Z8
      PARAMETER (Z8=-.498558728684003D-2)
      DOUBLE PRECISION Z9
      PARAMETER (Z9=2.127546015610523D0)
      DOUBLE PRECISION ONE
      PARAMETER (ONE=1.D0)
      DOUBLE PRECISION TWO
      PARAMETER (TWO=2.D0)
C
C  Argument variables
C
      DOUBLE PRECISION XA
C
C  Local variables
C
      DOUBLE PRECISION WA,WB,WC,WD
      DOUBLE PRECISION WE,WF
      INTEGER I,J
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
      IF (XA.LE.TWO) GOTO 30
C
C   For XA greater than 2, reduce successively by 1, accumulating
C   product in WB. Set link to J=1.
C
      WB = ONE
      WA = XA-ONE
      J = INT(WA)
      DO I = 1,J
        WB = WB*WA
        WA = WA-ONE
      ENDDO
      J = 1
      GOTO 20
C
   10 CONTINUE
      GAMF = WB/(WE-WF)
      GAMF = GAMF+GAMF
      RETURN
C
C   Sum Chebyshev series
C
   20 CONTINUE
      WC = WA+WA-ONE
      WC = WC+WC
      WD = Z1*WC+Z2
      WE = WC*WD+Z3
      WF = WC*WE-WD+Z4
      WD = WC*WF-WE+Z5
      WE = WC*WD-WF+Z6
      WF = WC*WE-WD+Z7
      WD = WC*WF-WE+Z8
      WE = WC*WD-WF+Z9
      IF (J) 50,50,10
C
   30 CONTINUE
      WB = ONE
      WA = XA
      IF (XA.GE.ONE) GOTO 40
C
C   For arguments less than 1, increase successively by 1, accumulating
C   product in WB. Set link to J=-1.
C
      J = INT(TWO-XA)
      DO I = 1,J
        WB = WB*WA
        WA = WA+ONE
      ENDDO
C
   40 CONTINUE
      J = -1
      WA = WA-ONE
      GOTO 20
C
   50 CONTINUE
      GAMF = TWO/(WB*(WE-WF))
C
      END
C
C                             *******************
C
      SUBROUTINE GENI9(IP)
C
C-----------------------------------------------------------------------
C
C  Determines the number of recoupling necessary to bring J2(I5,I3)
C  and J2(I6,I4) into the same triad. This will give a triad
C  identical with one in J3. On exit I9 contains the number of
C  recouplings plus two, I7 contains the level of the I5 triad below
C  the common triad and I8 contains the level of the I6 triad below
C  the common triads
C
C  See description of common block NJS04 for further details
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C
      IMPLICIT NONE
C
C  Parameter variables
C
      INTEGER MANGM
      PARAMETER (MANGM=60)
      INTEGER MTRIAD
      PARAMETER (MTRIAD=20)
C
C  Argument variables
C
      INTEGER IP
C
C  Local variables
C
      INTEGER I,I1,I2,J
C
C  Common variables
C
      INTEGER J1(MANGM),J2(MTRIAD,3)
      INTEGER J3(MTRIAD,3),M,N
      LOGICAL FREE(MANGM)
      COMMON / ANG00  / M,N,J1,J2,J3,FREE
C
C  Common variables
C
      INTEGER J4(MANGM),J5(MANGM)
      COMMON / NJS03  / J4,J5
C
C  Common variables
C
      INTEGER I17,I18,I19,I20
      INTEGER I3,I4,I5,I6
      INTEGER I7,I8,I9
      COMMON / NJS04  / I3,I4,I5,I6,I7,I8,I9,I17,I18,I19,I20
C
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C
C  Common block ANG00:
C    Elements used but never set: J2
C    Elements never used, never set: M N J1 J3 FREE
C  
C  Common block NJS03:
C    Elements used but never set: J4
C    Elements never used, never set: J5
C  
C  Common block NJS04:
C    Elements set but never used: I9 I17 I18 I19 I20
C  
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      I1 = J4(I7)
      I2 = J4(I8)
C
C  Determines which J of J2(I5,I3) and J2(I6,I4) lies lowest, store
C  lowest as J2(I18,I20) and highest as J2(I17,I19)
C
      IF (I1.LE.I2) THEN
C
        I17 = I5
        I18 = I6
        I19 = I3
        I20 = I4
        I3 = I2-I1
        I7 = 0
        I8 = I3
        I4 = I1
C
        IF (I3.GT.0) THEN
C
C  I6 denotes the lowest triad, scan triads to find new triad I6 at
C  same level as I5
C
          DO I = 1,I3
            DO J = 1,IP
              IF (J2(J,1).EQ.J2(I6,3)) GOTO 510
              IF (J2(J,2).EQ.J2(I6,3)) GOTO 510
            ENDDO
            J = IP
  510       CONTINUE
            I6 = J
          ENDDO
C
        ENDIF
C
      ELSE
C
        I17 = I6
        I18 = I5
        I19 = I4
        I20 = I3
        I3 = I1-I2
        I7 = I3
        I8 = 0
C
C  I5 denotes the lowest triads. Scan triads to find new triad I6 at
C  same level I5
C
        DO I = 1,I3
          DO J = 1,IP
            IF (J2(J,1).EQ.J2(I5,3)) GOTO 520
            IF (J2(J,2).EQ.J2(I5,3)) GOTO 520
          ENDDO
          J = IP
  520     CONTINUE
          I5 = J
        ENDDO
        I4 = I2
C
      ENDIF
C
C  I5 and I6 now denotes triads at same level. I4 contains the
C  common level
C
      DO I = 1,I4
C
        I1 = I
        IF (I5.EQ.I6) GOTO 550
C
C  I5 and I6 denote different triads. Scan to find triads at next
C  level which replace I5 and I6
C
        DO J = 1,IP
          IF (J2(J,1).EQ.J2(I5,3)) GOTO 530
          IF (J2(J,2).EQ.J2(I5,3)) GOTO 530
        ENDDO
        J = IP
  530   CONTINUE
        I5 = J
C
        DO J = 1,IP
          IF (J2(J,1).EQ.J2(I6,3)) GOTO 540
          IF (J2(J,2).EQ.J2(I6,3)) GOTO 540
        ENDDO
        J = IP
  540   CONTINUE
        I6 = J
C
      ENDDO
C
C  I5 and I6 now both denote the common triad
C
  550 CONTINUE
      I9 = I3+2*I1
      I8 = I8+I1
      I7 = I7+I1
C
      END
C
C                             *******************
C
      SUBROUTINE GENJ45(IP)
C
C-----------------------------------------------------------------------
C
C  Find the level of each J in the coupling trees of J2 and J3 and
C  store in the J4 and J5 arrays respectively. If an element of J1
C  does not occur in J2 the J4 entry is -1 and if an element does
C  not occur in J3 the J5 entry is -1
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C
      IMPLICIT NONE
C
C  Parameter variables
C
      INTEGER MANGM
      PARAMETER (MANGM=60)
      INTEGER MTRIAD
      PARAMETER (MTRIAD=20)
C
C  Argument variables
C
      INTEGER IP
C
C  Local variables
C
      INTEGER I,I2,I3,I4
C
C  Common variables
C
      INTEGER J1(MANGM),J2(MTRIAD,3)
      INTEGER J3(MTRIAD,3),M,N
      LOGICAL FREE(MANGM)
      COMMON / ANG00  / M,N,J1,J2,J3,FREE
C
C  Common variables
C
      INTEGER J4(MANGM),J5(MANGM)
      COMMON / NJS03  / J4,J5
C
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C
C  Common block ANG00:
C    Elements used but never set: M J2 J3
C    Elements never used, never set: N J1 FREE
C  
C  Common block NJS03:
C    Elements set but never used: all
C  
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      DO I = 1,M
C
C  Store level of each J in J2 array in J4
C
        DO I2 = 1,IP
          IF (J2(I2,1).EQ.I) GOTO 520
          IF (J2(I2,2).EQ.I) GOTO 520
        ENDDO
        DO I2 = 1,IP
          IF (J2(I2,3).EQ.I) GOTO 510
        ENDDO
        J4(I) = -1
        GOTO 550
C
  510   CONTINUE
        J4(I) = 0
        GOTO 550
C
  520   CONTINUE
        I3 = 1
  530   CONTINUE
        DO I4 = 1,IP
          IF (J2(I4,1).EQ.J2(I2,3)) GOTO 540
          IF (J2(I4,2).EQ.J2(I2,3)) GOTO 540
        ENDDO
        J4(I) = I3
        GOTO 550
C
  540   CONTINUE
        I3 = I3+1
        I2 = I4
        GOTO 530
C
C  Store level of each J in J3 array in J5
C
  550   CONTINUE
        DO I2 = 1,IP
          IF (J3(I2,1).EQ.I) GOTO 570
          IF (J3(I2,2).EQ.I) GOTO 570
        ENDDO
        DO I2 = 1,IP
          IF (J3(I2,3).EQ.I) GOTO 560
        ENDDO
        J5(I) = -1
        GOTO 600
C
  560   CONTINUE
        J5(I) = 0
        GOTO 600
C
  570   CONTINUE
        I3 = 1
  580   CONTINUE
        DO I4 = 1,IP
          IF (J3(I4,1).EQ.J3(I2,3)) GOTO 590
          IF (J3(I4,2).EQ.J3(I2,3)) GOTO 590
        ENDDO
        J5(I) = I3
        GOTO 600
C
  590   CONTINUE
        I3 = I3+1
        I2 = I4
        GOTO 580
C
  600   CONTINUE
C
      ENDDO
C
      END
C
C                             *******************
C
      SUBROUTINE GENSUM(J6C,J7C,J8C,JWC,J6,J7,J8,JW,ICOUNT,J2TEST,J3TEST!
     +,RECUP)
C
C-----------------------------------------------------------------------
C
C  Carries out the summation over coefficients defined by the arrays
C  J6, J7, J8 and JW to give RECUP.
C
C  The entry is either made from NJSYM or directly assuming that the
C  arrays J6, J7, J8 and JW have already been determined by a previous
C  entry to NJSYM and that the summation is required for another set
C  of J values defined by the array J1.
C
C  The definition of the argument list is given at beginning of NJSYM
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C
      IMPLICIT NONE
      DOUBLE PRECISION DBLE
C
C  Parameter variables
C
      DOUBLE PRECISION ZERO
      PARAMETER (ZERO=0.D0)
      DOUBLE PRECISION ONE
      PARAMETER (ONE=1.D0)
      INTEGER MANGM
      PARAMETER (MANGM=60)
      INTEGER MTRIAD
      PARAMETER (MTRIAD=20)
      INTEGER M3MNGM
      PARAMETER (M3MNGM=3*MANGM)
      INTEGER M6J
      PARAMETER (M6J=20)
C
C  Argument variables
C
      INTEGER ICOUNT,J2TEST(MTRIAD)
      INTEGER J3TEST(MTRIAD),J6(M3MNGM),J6C
      INTEGER J7(M3MNGM),J7C,J8(M3MNGM),J8C
      INTEGER JW(6,M6J),JWC
      DOUBLE PRECISION RECUP
C
C  Local variables
C
      DOUBLE PRECISION STOR,STOR1,WSTOR(M6J),X1
      INTEGER I,I1,I2,I20
      INTEGER I3,I4,I5,I6
      INTEGER I7,IASTOR,IORTH
      INTEGER IPAIR(2,2),IST(6),IX2,J
      INTEGER J6CP,J6P(M3MNGM),J7CP
      INTEGER J7P(M3MNGM),J8CP,J8P(M3MNGM),JJ2
      INTEGER JJ3,JSUM(2,M6J),JSUM1(MTRIAD)
      INTEGER JSUM2(MTRIAD),JSUM3(MTRIAD)
      INTEGER JSUM5(MTRIAD,M6J),JSUM6(MTRIAD)
      INTEGER JSUM7(MTRIAD),JSUM8(MTRIAD)
      INTEGER JWORD(6,M6J),JWRD
      INTEGER JWTEST(M6J),MAXJWE,MAXSUM,NCT
      INTEGER NCT1,NSUM,NSUM1
C
C  Common variables
C
      INTEGER J1(MANGM),J2(MTRIAD,3)
      INTEGER J3(MTRIAD,3),M,N
      LOGICAL FREE(MANGM)
      COMMON / ANG00  / M,N,J1,J2,J3,FREE
C
C  Common variables
C
      INTEGER IBUG1,IBUG2,IBUG3,IBUG4
      INTEGER IBUG5,IBUG6
      COMMON / DEBUG  / IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6
C
C  Common variables
C
      INTEGER IPUNCH,IREAD,IWRITE
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
C
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C  
C  Common block ANG00:
C    Elements used but never set: M J1
C    Elements never used, never set: N J2 J3 FREE
C  
C  Common block DEBUG:
C    Elements used but never set: IBUG3
C    Elements never used, never set: IBUG1 IBUG2 IBUG4 IBUG5 IBUG6
C  
C  Common block INFORM:
C    Elements used but never set: IWRITE
C    Elements never used, never set: IREAD IPUNCH
C  
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
C
C  Section  1
C
C  Evaluates all terms in J6, J7, J8 and JW which do not involve a
C  summation and form modified arrays J6P, J7P, J8P and JWORD which do.
C
C  The result of the evaluation is stored in RECUP and AISTOR.
C
C  First check orthogonality of original coupling scheme.
C
C-----------------------------------------------------------------------
      IF (ICOUNT.GT.0) THEN
        RECUP = ZERO
        IORTH = 0
        DO I = 1,ICOUNT
          JJ2 = J2TEST(I)
          JJ3 = J3TEST(I)
          IF (J1(JJ2).NE.J1(JJ3)) IORTH = 1
        ENDDO
        IF (IORTH.EQ.1) RETURN
      ENDIF
C
      IF (IBUG3.EQ.1) WRITE (IWRITE,3000) (J1(I),I=1,M)
C
      RECUP = ONE
C
C  Multiply RECUP by all Racah coefficients which do not involve a
C  summation
C
      MAXJWE = M
      JWRD = 0
      IF (JWC.GT.0) THEN
        DO I = 1,JWC
          DO J = 1,6
            IF (JW(J,I).GT.M) GOTO 510
          ENDDO
          DO J = 1,6
            I1 = JW(J,I)
            IST(J) = J1(I1)-1
          ENDDO
          CALL DRACAH(IST(1),IST(2),IST(3),IST(4),IST(5),IST(6),X1)
          RECUP = RECUP*X1
          GOTO 520
C
C  JWRD is the number of Racah coefficients which involve a
C  summation
C
C  JWORD(I,J),I=1,6,J=1,JWRD contains the number which give the
C  location of the J values for the Racah coefficients either in the
C  J1 list or in the JSUM1 list
C
C  MAXJWE contains the maximum J in the list of variables to be
C  summed over
C
  510     CONTINUE
          JWRD = JWRD+1
          DO J = 1,6
            JWORD(J,JWRD) = JW(J,I)
            IF (MAXJWE.LT.JW(J,I)) THEN
              MAXJWE = JW(J,I)
            ENDIF
          ENDDO
  520     CONTINUE
        ENDDO
      ENDIF
C
C  J6P(I),I=1,J6CP contains all J6 which involve a summation.
C  Multiply RECUP by all those which do not
C
      J6CP = 0
      IF (J6C.GT.0) THEN
        DO I = 1,J6C
          IF (J6(I).LE.M) THEN
            I1 = J6(I)
            RECUP = RECUP*SQRT(DBLE(J1(I1)))
          ELSE
            J6CP = J6CP+1
            J6P(J6CP) = J6(I)
          ENDIF
        ENDDO
      ENDIF
C
C  J7P(I),I=1,J7CP contains all J7 which involve a summation.
C  Multiply RECUP by all those which do not
C
      IASTOR = 0
      J7CP = 0
      IF (J7C.GT.0) THEN
        DO I = 1,J7C
          IF (J7(I).LE.M) THEN
            I1 = J7(I)
            IASTOR = IASTOR+J1(I1)-1
          ELSE
            J7CP = J7CP+1
            J7P(J7CP) = J7(I)
          ENDIF
        ENDDO
      ENDIF
C
C  J8CP(I),I=1,J8CP contains all J8 which involve a summation.
C  Multiply RECUP by all those which do not.
C
      J8CP = 0
      IF (J8C.GT.0) THEN
        DO I = 1,J8C
          IF (J8(I).LE.M) THEN
            I1 = J8(I)
            IASTOR = IASTOR-J1(I1)+1
          ELSE
            J8CP = J8CP+1
            J8P(J8CP) = J8(I)
          ENDIF
        ENDDO
      ENDIF
C
C  No Racah coefficients remaining and thus no summations to be
C  carried out if JWRD=0. Jump to end to include (-1) factors in
C  RECUP and then exit
C
      IF (JWRD.LE.0) GOTO 710
C-----------------------------------------------------------------------
C
C  Section  2
C
C  Search through the JWORD list to find all the summation variables
C  NSUM is the number of summation variables
C  JSUM1(I),I=1,NSUM contains a list of all summation variables in
C  the same notation as in JW list
C
C-----------------------------------------------------------------------
      NSUM = 0
      MAXSUM = MAXJWE-M
      DO I = 1,MAXSUM
        JSUM6(I) = 0
        JSUM7(I) = 0
      ENDDO
C
C  Find summation variables
C
      DO I = 1,JWRD
        DO J = 1,6
          IF (JWORD(J,I)-M.GT.0) THEN
C
            NSUM = NSUM+1
C
C  Has the summation variable occurred before?
C  If not include in JSUM1 list
C
            IF (NSUM-1.GT.0) THEN
              NSUM1 = NSUM-1
              DO I1 = 1,NSUM1
                IF (JWORD(J,I)-JSUM1(I1).EQ.0) GOTO 530
              ENDDO
            ENDIF
C
            JSUM1(NSUM) = JWORD(J,I)
            I1 = NSUM
            GOTO 540
C
  530       CONTINUE
            NSUM = NSUM1
C
C  JSUM6(I),I=1,NSUM is the number of times each summation variable
C  occurs in JWORD
C
  540       CONTINUE
            JSUM6(I1) = JSUM6(I1)+1
            I2 = JSUM6(I1)
C
C  JSUM4(I,J),JSUM5(I,J),I=1,NSUM,J=1,JSUM6(I)
C  is the position in the JWORD list where the JSUM1 element occurs
C
CPN      JSUM4(I1,I2)=J
            JSUM5(I1,I2) = I
C
C  (JWORD-M) gives location in JSUM1 list if a summation variable
C
            JWORD(J,I) = M+I1
C
          ENDIF
        ENDDO
      ENDDO
C
      IF (MTRIAD.LT.NSUM) THEN
        WRITE (IWRITE,3080)
        STOP
      ENDIF
C
C  Check that no extra summation variables occur in J6P. Set J6P
C  equal to the location in JSUM1 list of summation variable
C
      IF (J6CP.GT.0) THEN
        DO I = 1,J6CP
          DO J = 1,NSUM
            IF (J6P(I).EQ.JSUM1(J)) GOTO 550
          ENDDO
          WRITE (IWRITE,3020)
          STOP
  550     CONTINUE
          J6P(I) = J
        ENDDO
      ENDIF
C
C  Check that no extra summation variables occur in J7P, set J7P
C  equal to the location in JSUM1 list of summation variable
C
      IF (J7CP.GT.0) THEN
        DO I = 1,J7CP
          DO J = 1,NSUM
            IF (J7P(I).EQ.JSUM1(J)) GOTO 560
          ENDDO
          WRITE (IWRITE,3030)
          STOP
  560     CONTINUE
          J7P(I) = J
        ENDDO
      ENDIF
C
C  Check that no extra summation variables occur in J8P. Set J8P
C  equal to the location in JSUM1 list of summation variable
C
      IF (J8CP.GT.0) THEN
        DO I = 1,J8CP
          DO J = 1,NSUM
            IF (J8P(I).EQ.JSUM1(J)) GOTO 570
          ENDDO
          WRITE (IWRITE,3040)
          STOP
  570     CONTINUE
          J8P(I) = J
        ENDDO
      ENDIF
C-----------------------------------------------------------------------
C
C  Section  3
C
C  Orders the summation variables so that the range of each
C  summation has been previously defined
C
C-----------------------------------------------------------------------
      NCT = 0
      NCT1 = 0
  580 CONTINUE
C
      DO I = 1,JWRD
        DO J = 1,6
C
          I1 = JWORD(J,I)-M
C
          IF (I1.LE.0) GOTO 620
C
C  JSUM7(I),I=1,NSUM is the order of the summations over the J
C  variables. Initially this array is zero
C
          IF (JSUM7(I1).GT.0) GOTO 620
C
C  The rows of the IPAIR arrays give limits of summation imposed
C  by the triangular condition
C
          IF (J.EQ.1) THEN
            IPAIR(1,1) = JWORD(2,I)
            IPAIR(1,2) = JWORD(5,I)
            IPAIR(2,1) = JWORD(3,I)
            IPAIR(2,2) = JWORD(6,I)
            GOTO 590
          ENDIF
C
          IF (J.EQ.2) THEN
            IPAIR(1,1) = JWORD(1,I)
            IPAIR(1,2) = JWORD(5,I)
            IPAIR(2,1) = JWORD(4,I)
            IPAIR(2,2) = JWORD(6,I)
            GOTO 590
          ENDIF
C
          IF (J.EQ.3) THEN
            IPAIR(1,1) = JWORD(1,I)
            IPAIR(1,2) = JWORD(6,I)
            IPAIR(2,1) = JWORD(4,I)
            IPAIR(2,2) = JWORD(5,I)
            GOTO 590
          ENDIF
C
          IF (J.EQ.4) THEN
            IPAIR(1,1) = JWORD(2,I)
            IPAIR(1,2) = JWORD(6,I)
            IPAIR(2,1) = JWORD(3,I)
            IPAIR(2,2) = JWORD(5,I)
            GOTO 590
          ENDIF
C
          IF (J.EQ.5) THEN
            IPAIR(1,1) = JWORD(1,I)
            IPAIR(1,2) = JWORD(2,I)
            IPAIR(2,1) = JWORD(3,I)
            IPAIR(2,2) = JWORD(4,I)
            GOTO 590
          ENDIF
C
          IF (J.EQ.6) THEN
            IPAIR(1,1) = JWORD(1,I)
            IPAIR(1,2) = JWORD(3,I)
            IPAIR(2,1) = JWORD(2,I)
            IPAIR(2,2) = JWORD(4,I)
            GOTO 590
          ENDIF
C
C  Test whether range of summation has been defined. We choose the
C  first pair of J values that define the range and store in JSUM.
C
C  JSUM7 greater than zero means that limit is defined previously
C
  590     CONTINUE
C
          DO I2 = 1,2
            DO I3 = 1,2
              IF (IPAIR(I2,I3)-M.GT.0) THEN
                I4 = IPAIR(I2,I3)-M
                IF (JSUM7(I4).LE.0) GOTO 600
              ENDIF
            ENDDO
            GOTO 610
  600       CONTINUE
          ENDDO
C
          GOTO 620
C
C  NCT is count on order of summation
C
C  JSUM(I,J),I=1,2,J=1,NSUM contains the position of the J values
C  that define the range of each variable. The first row corresponds
C  to the first J and the second row to the second J defining range.
C  If value in range 1 to M then corresponds to an element in J1.
C  If value greater than M then corresponds to a summation variable
C  in JSUM1 list. Note that JSUM does not necessarily contain the
C  most restrictive ranges since only one of two possible pairs from
C  the Racah coefficient is taken
C
  610     CONTINUE
          NCT = NCT+1
          JSUM7(I1) = NCT
          DO I3 = 1,2
            JSUM(I3,I1) = IPAIR(I2,I3)
          ENDDO
C
  620     CONTINUE
C
        ENDDO
      ENDDO
C
C  Check whether the range of all summations set. Fail if not
C  possible to set all ranges
C
      IF (NCT-NSUM.GE.0) GOTO 640
      IF (NCT-NCT1.GT.0) GOTO 630
      WRITE (IWRITE,3050)
      STOP
C
  630 CONTINUE
      NCT1 = NCT
      GOTO 580
C
C  JSUM8(I),I=1,NSUM is the position in the JSUM7 list where the Ith
C  summation is found
C
  640 CONTINUE
      DO J = 1,NSUM
        DO I1 = 1,NSUM
          IF (JSUM7(I1).EQ.J) GOTO 650
        ENDDO
        I1 = NSUM
  650   CONTINUE
        JSUM8(J) = I1
      ENDDO
C-----------------------------------------------------------------------
C
C  Section  4
C
C  Carry out the summations.
C  I6 denotes the first J that requires to be set to the lowest
C  value in the range
C  I7 = 0 the first time the JS are set but is set equal to 1
C  on subsequent times
C
C-----------------------------------------------------------------------
      I6 = 1
      I7 = 0
  660 CONTINUE
      IF (I6-NSUM.GT.0) GOTO 670
C
C  JSUM2(I),I=1,NSUM contains current value of (2J+1) in the same
C  order as JSUM1 list. Set JSUM2 equal to lowest value in each
C  range
C
      DO J = I6,NSUM
        I1 = JSUM8(J)
C
        IF (JSUM(1,I1)-M.LE.0) THEN
C
C  First J defining range fixed
C
          I2 = JSUM(1,I1)
          I3 = J1(I2)
C
        ELSE
C
C  First J defining range variable
C
          I2 = JSUM(1,I1)-M
          I3 = JSUM2(I2)
C
        ENDIF
C
        IF (JSUM(2,I1)-M.LE.0) THEN
C
C  Second J defining range fixed
C
          I2 = JSUM(2,I1)
          I4 = J1(I2)
C
        ELSE
C
C  Second J defining range variable
C
          I2 = JSUM(2,I1)-M
          I4 = JSUM2(I2)
C
        ENDIF
C
C  Set lower limit of range in JSUM2
C
        JSUM2(I1) = ABS(I3-I4)+1
      ENDDO
C
C  JSUM3(I),I=1,NSUM is 1 if J has altered from its previous value
C  and is 0 if it is still the same
C
      DO I = I6,NSUM
        JSUM3(I) = 1
      ENDDO
C
      IF (I7.GT.0) GOTO 670
      I7 = 1
C
C  JWTEST(I),I=1,JWRD is 1 if required to evaluate Racah coefficient
C  and is 0 if value the same as before. JWTEST is set zero the first
C  time through and later set 1 if necessary
C
      DO I = 1,JWRD
        JWTEST(I) = 0
      ENDDO
C
C  STOR1 will contain the product of Racah coefficients times
C  (2J+1) factors
C  STOR will contain sums of the STOR1
C
      STOR1 = ONE
      STOR = ZERO
C
C  Check the triangular relation for all J values in JWORD list. If
C  a summation variable then value taken from JSUM2 list
C
  670 CONTINUE
      DO J = 1,JWRD
        DO I = 1,6
          IF (JWORD(I,J).LE.M) THEN
            I1 = JWORD(I,J)
            IST(I) = J1(I1)-1
          ELSE
            I1 = JWORD(I,J)-M
            IST(I) = JSUM2(I1)-1
          ENDIF
        ENDDO
C
        IF (    IST(1)+IST(2) -IST(5).LT.0) GOTO 680
        IF (ABS(IST(1)-IST(2))-IST(5).GT.0) GOTO 680
        IF (    IST(3)+IST(4) -IST(5).LT.0) GOTO 680
        IF (ABS(IST(3)-IST(4))-IST(5).GT.0) GOTO 680
        IF (    IST(1)+IST(3) -IST(6).LT.0) GOTO 680
        IF (ABS(IST(1)-IST(3))-IST(6).GT.0) GOTO 680
        IF (    IST(2)+IST(4) -IST(6).LT.0) GOTO 680
        IF (ABS(IST(2)-IST(4))-IST(6).GT.0) GOTO 680
C
      ENDDO
      GOTO 700
C
C  Fail one of the triangular relations. Increase the J values
C
  680 CONTINUE
      I2 = NSUM
  690 CONTINUE
      I1 = JSUM8(I2)
C
C  Increase a summation J value which is in JSUM2 and set JSUM3 to
C  show value changed
C
      JSUM2(I1) = JSUM2(I1)+2
      JSUM3(I1) = 1
C
C  Now store J value defining range of this J in I3 and I4.
C
      IF (JSUM(1,I1).LE.M) THEN
        I20 = JSUM(1,I1)
        I3 = J1(I20)
      ELSE
        I20 = JSUM(1,I1)-M
        I3 = JSUM2(I20)
      ENDIF
C
      IF (JSUM(2,I1).LE.M) THEN
        I20 = JSUM(2,I1)
        I4 = J1(I20)
      ELSE
        I20 = JSUM(2,I1)-M
        I4 = JSUM2(I20)
      ENDIF
C
      I5 = I3+I4-1
      I6 = I2+1
C
C  Now test J values against maximum in range. If satisfied return
C  to set remaining J values which depend on this J to their
C  lowest values. If not return to increase preceding J value
C
      IF (JSUM2(I1).LE.I5) GOTO 660
C
      I2 = I2-1
      IF (I2.GT.0) GOTO 690
C
C  No more J values to sum over. The summation is therefore complete
C  Multiply by common factor and exit
C
      RECUP = RECUP*STOR
C
      IF (IBUG3.EQ.1) THEN
        WRITE (IWRITE,3060) RECUP,STOR,STOR1
      ENDIF
C
      RETURN
C
C  See triangular relations are satisfied. Now proceed to evaluate
C  Racah coefficients
C  First determine which Racah coefficients need re-evaluating and
C  set JWTEST appropriately
C
  700 CONTINUE
      DO J = 1,NSUM
        IF (JSUM3(J).GT.0) THEN
          I2 = JSUM6(J)
          DO I1 = 1,I2
            I3 = JSUM5(J,I1)
            JWTEST(I3) = 1
          ENDDO
        ENDIF
      ENDDO
C
C  Now evaluate all JWRD Racah coefficients which have not already
C  been evaluated
C
      DO I = 1,JWRD
        IF (JWTEST(I).GT.0) THEN
          DO I1 = 1,6
            IF (JWORD(I1,I).LE.M) THEN
              I2 = JWORD(I1,I)
              IST(I1) = J1(I2)-1
            ELSE
              I2 = JWORD(I1,I)-M
              IST(I1) = JSUM2(I2)-1
            ENDIF
          ENDDO
          CALL DRACAH(IST(1),IST(2),IST(3),IST(4),IST(5),IST(6),X1)
          WSTOR(I) = X1
        ENDIF
      ENDDO
C
C  WSTOR(I),I=1,JWRD contains the evaluated Racah coefficients
C
      IF (IBUG3.EQ.1) THEN
        WRITE (IWRITE,3070) (WSTOR(J),J=1,JWRD)
      ENDIF
C
C  Set JSUM3 and JWTEST to zero to indicate that Racah coefficients
C  need not be evaluated unless J value changes
C
      DO J = 1,NSUM
        JSUM3(J) = 0
      ENDDO
C
      DO J = 1,JWRD
        JWTEST(J) = 0
      ENDDO
C
C  Form product of Racah coefficients, (2J+1) factors and (-1)
C  factors in STOR1
C
      DO I = 1,JWRD
        STOR1 = STOR1*WSTOR(I)
      ENDDO
C
C  IASTOR contains the power of (-1) which is common to all terms
C
      IX2 = IASTOR
C
      IF (J6CP.GT.0) THEN
        DO I = 1,J6CP
          I1 = J6P(I)
          STOR1 = STOR1*SQRT(DBLE(JSUM2(I1)))
        ENDDO
      ENDIF
C
      IF (J7CP.GT.0) THEN
        DO I = 1,J7CP
          I1 = J7P(I)
          IX2 = IX2+JSUM2(I1)-1
        ENDDO
      ENDIF
C
      IF (J8CP.GT.0) THEN
        DO I = 1,J8CP
          I1 = J8P(I)
          IX2 = IX2-JSUM2(I1)+1
        ENDDO
      ENDIF
C
      IX2 = IX2/2
C
C  Add term into STOR and reset STOR1 to 1 ready for next term
C
      IF (MOD(IX2,2).EQ.1) STOR1 = -STOR1
      STOR = STOR+STOR1
      STOR1 = ONE
      GOTO 680
C
C  No summations.
C  Check that there are no inconsistencies.
C  Then multiply by (-1) factor and exit
C
  710 CONTINUE
      IF (J6CP+J7CP+J8CP.GT.0) THEN
        WRITE (IWRITE,3090)
        STOP
      ENDIF
C
      IX2 = IASTOR/2
      IF (MOD(IX2,2).EQ.1) RECUP = -RECUP
      IF (IBUG3.EQ.1) WRITE (IWRITE,3010) RECUP
C-----------------------------------------------------------------------
C
C  FORMAT statements used in GENSUM
C
C-----------------------------------------------------------------------
 3000 FORMAT (' J1=',10I5)
 3010 FORMAT (' RECUP = ',1P,E16.8,'  no summation')
 3020 FORMAT (' FAIL in GENSUM : with J6P array')
 3030 FORMAT (' FAIL in GENSUM : with J7P array')
 3040 FORMAT (' FAIL in GENSUM : with J8P array')
 3050 FORMAT (' FAIL in GENSUM : setting summation ranges')
 3060 FORMAT (' RECUP = ',1P,E16.8,' STOR =',E16.8,' STOR1 =',E16.8)
 3070 FORMAT (' WSTOR =',5F10.6)
 3080 FORMAT (' FAIL in GENSUM : MTRIAD dimension')
 3090 FORMAT (' FAIL in GENSUM : inconsistency for no summation case')
      END
C
C                             *******************
C
      SUBROUTINE HPOT(J,XCF)
C
C-----------------------------------------------------------------------
C
C   Modify the potentials for orbital J as described by
C   Cowan and Mann
C
C   Cowan and Mann  J. Comp. Phys.  Vol. 16 Page 160 (1975)
C
C   No subroutines called.
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  Parameter variables
C
      DOUBLE PRECISION ZERO
      PARAMETER (ZERO=0.D0)
      DOUBLE PRECISION EPS10
      PARAMETER (EPS10=1.D-10)
      DOUBLE PRECISION FACTK
      PARAMETER (FACTK=.95D0)
      DOUBLE PRECISION FACTL
      PARAMETER (FACTL=1.D-2)
      DOUBLE PRECISION FACTX
      PARAMETER (FACTX=1.D-3)
C
C  Argument variables
C
      DOUBLE PRECISION XCF
      INTEGER J
C
C  Local variables
C
      DOUBLE PRECISION DLIMIT,DMX,HP,HQ
      DOUBLE PRECISION P,Q
      INTEGER I,IJ,NGRID
C
C  Common variables
C
      DOUBLE PRECISION ACCY,C,EPH,H
      DOUBLE PRECISION RNT,Z
      INTEGER N,NCPRIN,NW1
      COMMON / DEF01  / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN
C
C  Common variables
C
      INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF
      INTEGER NP(MXNW),NW
      COMMON / ORB04  / NW,NCF,NP,NAK,IQ
C
C  Common variables
C
      INTEGER MPOIN(MXNW),MPOS(MXNW)
      COMMON / PATY   / MPOIN,MPOS
C
C  Common variables
C
      DOUBLE PRECISION XTP(MXNP),XTQ(MXNP),YP(MXNP)
      DOUBLE PRECISION YQ(MXNP)
      COMMON / POTE   / YP,YQ,XTP,XTQ
C
C  Common variables
C
      DOUBLE PRECISION PF(MXNG),QF(MXNG)
      COMMON / WAVE   / PF,QF
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
      IF (XCF.LT.EPS10) RETURN
C
      NGRID = MPOIN(J)
      IJ = MPOS(J)
C
      DMX = FACTX
      DLIMIT = DMX
C
      DO I = 1,NGRID
        P = PF(IJ)
        IF (ABS(P)-DMX) 20,10,10
   10   CONTINUE
        DMX = ABS(P)
        DLIMIT = SIGN(DMX*FACTL,P)
        GOTO 40
C
   20   CONTINUE
        IF (ABS(P)-ABS(DLIMIT)) 30,40,40
   30   CONTINUE
        IF (P.NE.ZERO) DLIMIT = SIGN(DLIMIT,P)
        P = DLIMIT
   40   CONTINUE
        HQ = FACTK*XTQ(I)/P
        XTQ(I) = XTQ(I)-HQ*PF(IJ)
        YQ(I) = YQ(I)+C*HQ
        IJ = IJ+1
      ENDDO
C
      NGRID = MPOIN(J)
      IJ = MPOS(J)
C
      DMX = FACTX
      DLIMIT = DMX
      IF (NAK(J).LT.0) DLIMIT = -DLIMIT
C
      DO I = 1,NGRID
        Q = QF(IJ)
        IF (ABS(Q)-DMX) 60,50,50
   50   CONTINUE
        DMX = ABS(Q)
        DLIMIT = SIGN(DMX*FACTL,Q)
        GOTO 80
C
   60   CONTINUE
        IF (ABS(Q)-ABS(DLIMIT)) 70,80,80
   70   CONTINUE
        IF (Q.NE.ZERO) DLIMIT = SIGN(DLIMIT,Q)
        Q = DLIMIT
   80   CONTINUE
        HP = FACTK*XTP(I)/Q
        XTP(I) = XTP(I)-HP*QF(IJ)
        YP(I) = YP(I)-C*HP
        IJ = IJ+1
      ENDDO
C
      END
C
C                             *******************
C
      SUBROUTINE IN(JORB,JP,MF,WA,WB)
C
C-----------------------------------------------------------------------
C
C  This subroutine computes the solution of the inhomogeneous
C  pair of Dirac equations in the exponential tail region.
C  The equations are treated as a boundary value problem,
C  with the value of P(R) given at one boundary, and P(R)
C  being required to vanish for large R, the position of
C  this second boundary being determined in the course of
C  the calculation.
C
C                 DATA
C
C  JORB  orbital label
C  JP    determines the point at which the outward integration ends.
C  MF    determines the end of the tail region.
C  WA    the value of  1 + H*K/2
C  WB    the value of  1 - H*K/2
C
C                 RESULT
C
C   P(I)  I= J+1,...,N    table of  P(R)
C   Q(I)  I= J  ,...,N    table of  Q(R)
C
C  The same finite difference equations are used as in
C  the outward integration.  When written in boundary-value
C  form the solution satisfies a system of linear equations
C  of the form  M*W = V,  where  W  is a vector consisting of
C  the elements  Q(J), P(J+1), Q(J+1), ...   The matrix  M
C  is of band type, with  5  elements in each row.  M is
C  expressed as a product of two triangular matrices  L AND U,
C  the non-zero elements of L being stored in the arrays
C  TA, TB and TC, and those of  U in TD, TE and TH.  The
C  required vector  W  is then obtained by solving two
C  triangular systems,  L*Z=V  and  U*W = Z.
C
C  The subroutine is usually called  3  times with the same
C  matrix  M, but different vectors  V.   The elements of the
C  triangular matrices  L  and  U  are therefore preserved
C  between calls.   If the parameter MF is zero, the elements
C  of  L  and  U  are computed, and the position of the
C  extreme boundary is determined by the condition that the
C  assumption  P(I+1)=Q(I+1)=0 leads to a value of  P(I)
C  smaller in magnitude than the accuracy parameter  ACCY.
C  the position of this boundary is then stored in  MF.   If
C  the end of the table is reached before this condition can be
C  satisfied, the subroutine returns with MF set to  -1  as a
C  failure indication.
C
C  If  MF  is non-zero on entry to the subroutine, the
C  elements of  L  and  U  are not re-computed, and the boundary
C  is taken to be at the point  MF.
C
C  No subroutines called.
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  Parameter variables
C
      DOUBLE PRECISION ZERO
      PARAMETER (ZERO=0.D0)
C
C  Argument variables
C
      DOUBLE PRECISION WA,WB
      INTEGER JORB,JP,MF
C
C  Local variables
C
      DOUBLE PRECISION TA(MXNP),TB(MXNP),TC(MXNP)
      DOUBLE PRECISION TD(MXNP),TE(MXNP),TEST1,TEST2
      DOUBLE PRECISION TF(MXNP)
      INTEGER I,J,NGRID
C
C  Common variables
C
      DOUBLE PRECISION P(MXNP),PC(MXNP),Q(MXNP)
      DOUBLE PRECISION QC(MXNP)
      COMMON / INT2   / P,Q,PC,QC
C
C  Common variables
C
      DOUBLE PRECISION XF(MXNP),XG(MXNP),XR(MXNP)
      DOUBLE PRECISION XS(MXNP),XU(MXNP),XV(MXNP)
      COMMON / INT3   / XU,XV,XR,XS,XF,XG
C
C  Common variables
C
      INTEGER MPOIN(MXNW),MPOS(MXNW)
      COMMON / PATY   / MPOIN,MPOS
C
C  Common variables
C
      DOUBLE PRECISION CUTOFF
      COMMON / PATZ   / CUTOFF
C
      SAVE TA,TB,TC,TD,TE,TF
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
      I = 1
      J = JP
C
      IF (MF.EQ.0) THEN
        NGRID = MPOIN(JORB)
        TD(1) = WA
        TC(1) = -XF(J)/TD(1)
        TE(1) = -WA+TC(1)*XG(J+1)
        TF(1) = WB*TC(1)-XF(J+1)
        XR(1) = -XV(J)+XG(J)*P(J)
        XS(1) = -XU(J)-WB*P(J)-TC(1)*XR(1)
        TEST1 = ABS(XS(1)/TE(1))
C
   10   CONTINUE
        I = I+1
        J = J+1
C
C  compute rows of  L  and  U  matrices
C
        TA(I) = -XG(J)/TE(I-1)
        TD(I) = WA-TA(I)*TF(I-1)
        TB(I) = WB/TE(I-1)
        TC(I) = (-XF(J)-TB(I)*TF(I-1))/TD(I)
        TE(I) = -WA+TC(I)*XG(J+1)
        TF(I) = -XF(J+1)+WB*TC(I)
C
C  solution of  L*Z=V
C
        XR(I) = -XV(J)-TA(I)*XS(I-1)
        XS(I) = -XU(J)-TB(I)*XS(I-1)-TC(I)*XR(I)
C
C  test for extreme boundary possible
C
        TEST2 = ABS(XS(I)/TE(I))
        IF (TEST1+TEST2.LE.CUTOFF) GOTO 30
        TEST1 = TEST2
C
C  failure if tables not long enough
C
        IF (J.GE.NGRID-1) THEN
          MF = -1
          RETURN
        ENDIF
C
        GOTO 10
C
      ELSE
        XR(1) = -XV(J)+XG(J)*P(J)
        XS(1) = -XU(J)-WB*P(J)-TC(1)*XR(1)
C
   20   CONTINUE
        I = I+1
        J = J+1
C
C  solution of  L*Z=V
C
        XR(I) = -XV(J)-TA(I)*XS(I-1)
        XS(I) = -XU(J)-TB(I)*XS(I-1)-TC(I)*XR(I)
        IF (J.LT.MF) GOTO 20
      ENDIF
C
C  *****  INWARD SOLUTION ******
C  store boundary position in MF
C
   30 CONTINUE
      MF = J
C
C  begin solution of  U*W=Z
C
      I = I-1
      Q(J) = ZERO
      P(J) = XS(I)/TE(I)
      Q(J-1) = (XR(I)+XG(J)*P(J))/TD(I)
C
   40 CONTINUE
      J = J-1
      I = I-1
C
C  compute elements of vector  W.
C
      P(J) = (XS(I)-TF(I)*Q(J))/TE(I)
      Q(J-1) = (XR(I)+WB*Q(J)+XG(J)*P(J))/TD(I)
      IF (J.GT.JP+1) GOTO 40
C
      END
C
C                             *******************
C
      SUBROUTINE IN2CH3 (i,name,iwrite)
C
C-----------------------------------------------------------------------
C
C   This routine converts an integer into a 3-charcter variable.
C   e.g. if i is 29 then name is 029.
C   i lies between 0 and 999 inclusive.
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      CHARACTER CHAR
      INTEGER ICHAR
C
C  Argument variables
C
      CHARACTER*3 NAME
      INTEGER I,IWRITE
C
C  Local variables
C
      CHARACTER NAME1
      CHARACTER*2 NAME2
      INTEGER I1,I2,I3,IA
      INTEGER IB,N1,N2,N3
      INTEGER NUM(0:9)
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
      IF (i.lt.0 .or. i.gt.999) THEN
        WRITE (iwrite,3000) i
        stop
      ENDIF
C
      num(0) = ichar('0')
      num(1) = ichar('1')
      num(2) = ichar('2')
      num(3) = ichar('3')
      num(4) = ichar('4')
      num(5) = ichar('5')
      num(6) = ichar('6')
      num(7) = ichar('7')
      num(8) = ichar('8')
      num(9) = ichar('9')
C
      ia = i/10
      i3 = i-ia*10
      ib = ia/10
      i2 = ia-ib*10
      i1 = ib
C
      n1 = num(i1)
      n2 = num(i2)
      n3 = num(i3)
C
      name1 = char(n1)
      name2 = name1//char(n2)
      name = name2//char(n3)
C
 3000 FORMAT (/' STOPPING in routine IN2CH3.'/' The number ',I6,        !
     +' is out of range.')
      END
C
C                             *******************
C
      SUBROUTINE INIT(IR1,IR2,IR3)
C
C-----------------------------------------------------------------------
C
C   This subroutine :
C
C    (1) writes out the basic data
C
C    (2) obtains initial estimates for the wavefunctions by
C        using one of the following methods
C        (a) reading from a dump - rescaling if Z changes
C            and interpolating if the grid changes (SCORB)
C            dump can be MCDF or ORBITALS
C        (b) using a Thomas-Fermi potential
C        (c) using analytic Coulomb wavefunctions
C
C    (3) sets up the nuclear potential by a call to NUCPOT
C
C    (4) calls MCPIN to read the MCP coefficients from a file
C
C    (5) sets up mixing coefficients and generalised occupation numbers
C
C    (6) determines if Lagrange multipliers are required
C
C-----------------------------------------------------------------------
C
C  reference structure:
C
C   INIT   COULG
C          MCPIN
C          NUCPOT
C          PROPG
C          PRWF
c          rritz
C          SCORB
C          STWAVE PRWF
C                 QUAD
C          STWOPT EIGENV
C                 LAGR
C                 MATRIX
C                 PRWF
C                 QUAD
C                 XPOT
C                 YPOT
C          TFPOT
C          TFWAVE
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  Parameter variables
C
      DOUBLE PRECISION EPS10
      PARAMETER (EPS10=1.D-10)
      DOUBLE PRECISION RMAX
      PARAMETER (RMAX=300.0D0)
C
C  Argument variables
C
      INTEGER IR1,IR2,IR3
C
C  Local variables
C
      CHARACTER*80 IHEDIN
      CHARACTER*2 NHY
      CHARACTER*20 RECIN
      DOUBLE PRECISION CON,CY,EY,FAC1
      DOUBLE PRECISION FAC2,FK,HY,PZY
      DOUBLE PRECISION QZY,RY,SUM,WA
      DOUBLE PRECISION ZY
      INTEGER I,J,JA,JB
      INTEGER JP,L,MA,MB
      INTEGER MF,NAKY,NBIG,NCFY
      INTEGER NCY,NLAST,NMAX,NPY
      INTEGER NWM,NWTOT,NWY,NY
      LOGICAL LSTWAV
C
C  Common variables
C
      DOUBLE PRECISION ATW,FACTAN,FACTCM,FACTEV
      DOUBLE PRECISION FACTRY
      COMMON / ATOM   / ATW,FACTRY,FACTCM,FACTEV,FACTAN
C
C  Common variables
C
      DOUBLE PRECISION HALF,ONE,TEN,TENTH
      DOUBLE PRECISION THREE,TWO,ZERO
      COMMON / CONS   / ZERO,HALF,TENTH,ONE,TWO,THREE,TEN
C
C  Common variables
C
      DOUBLE PRECISION ACCY,C,EPH,H
      DOUBLE PRECISION RNT,Z
      INTEGER N,NCPRIN,NW1
      COMMON / DEF01  / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN
C
C  Common variables
C
      DOUBLE PRECISION CHECK
      INTEGER NITIT
      COMMON / DEF04  / CHECK,NITIT
C
C  Common variables
C
      DOUBLE PRECISION WT(MXNC)
      INTEGER ITY
      COMMON / DEF05  / WT,ITY
C
C  Common variables
C
      INTEGER ICCMIN(MXNC),NCMIN
      COMMON / DEF07  / NCMIN,ICCMIN
C
C  Common variables
C
      DOUBLE PRECISION BREENG(MXNC),COUENG(MXNC)
      COMMON / ENRG1  / COUENG,BREENG
C
C  Common variables
C
      INTEGER JFIX(MXNW)
      COMMON / FIXD   / JFIX
C
C  Common variables
C
      DOUBLE PRECISION RGRID(MXNP)
      COMMON / GRID   / RGRID
C
C  Common variables
C
      DOUBLE PRECISION EAV,UCF(MXNW)
      COMMON / HMAT   / EAV,UCF
C
C  Common variables
C
      INTEGER IPUNCH,IREAD,IWRITE
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
C
C  Common variables
C
      DOUBLE PRECISION P(MXNP),PC(MXNP),Q(MXNP)
      DOUBLE PRECISION QC(MXNP)
      COMMON / INT2   / P,Q,PC,QC
C
C  Common variables
C
      DOUBLE PRECISION CXCF(MXNE)
      INTEGER JXCF(MXNE),NSCF,NSCFY
      COMMON / MCPC   / CXCF,JXCF,NSCF,NSCFY
C
C  Common variables
C
      integer icut(mxnw)
      common /nrbcut/icut
C
C  Common variables
C
      DOUBLE PRECISION PARM(4),Z1
      INTEGER NPARM,NUCTYP
      COMMON / NPAR   / PARM,Z1,NUCTYP,NPARM
C
C  Common variables
C
      DOUBLE PRECISION ECV(MXNO)
      INTEGER IECC(MXNO),NEC
      COMMON / OFFD   / ECV,IECC,NEC
C
C  Common variables
C
      INTEGER ITC(50)
      COMMON / OPT01  / ITC
C
C  Common variables
C
      CHARACTER*2 NH(MXNW)
      COMMON / ORB00  / NH
C
C  Common variables
C
      DOUBLE PRECISION E(MXNW)
      COMMON / ORB01  / E
C
C  Common variables
C
      DOUBLE PRECISION GAMA(MXNW),XAM(MXNW)
      COMMON / ORB02  / GAMA,XAM
C
C  Common variables
C
      INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF
      INTEGER NP(MXNW),NW
      COMMON / ORB04  / NW,NCF,NP,NAK,IQ
C
C  Common variables
C
      INTEGER NKJ(MXNW),NKL(MXNW)
      COMMON / ORB05  / NKL,NKJ
C
C  Common variables
C
      INTEGER MPOIN(MXNW),MPOS(MXNW)
      COMMON / PATY   / MPOIN,MPOS
C
C  Common variables
C
      DOUBLE PRECISION CUTOFF
      COMMON / PATZ   / CUTOFF
C
C  Common variables
C
      CHARACTER*80 IHED
      CHARACTER*20 RECORD
      COMMON / TITL   / IHED,RECORD
C
C  Common variables
C
      INTEGER ILO(MXNW),IWO(MXNW),NWO
      COMMON / WRO    / NWO,IWO,ILO
C
C  Common variables
C
      logical lspin
      common /nrb000/lspin
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
      PRINT 3030,IHED(1:40),IHED(41:80),RECORD
      WRITE (IWRITE,3030) IHED(1:40),IHED(41:80),RECORD
      WRITE (IPUNCH,3030) IHED(1:40),IHED(41:80),RECORD
C
      IF (ABS(ATW).LT.EPS10) THEN
        WRITE (IWRITE,3070) FACTCM,FACTEV
      ELSE
        WRITE (IWRITE,3080) ATW,FACTCM,FACTEV
      ENDIF
      WRITE (IWRITE,3150) Z,C,RNT,H,ACCY,CUTOFF
C-----------------------------------------------------------------------
C
C  Set up the array containing the radial grid
C
      NMAX = MXNP
C
      WA = RNT
      DO I = 1,NMAX
        RGRID(I) = WA
        WA = WA*EPH
        IF (WA.GT.RMAX) THEN
          NMAX = I
          GOTO 10
        ENDIF
      ENDDO
C
C  N is set to be NMAX
C  N is an odd number
C
   10 CONTINUE
C
      IF (MOD(NMAX,2).EQ.1) THEN
        N = NMAX
      ELSE
        N = NMAX-1
      ENDIF
C
      WRITE (IWRITE,3160) RMAX,N
C-----------------------------------------------------------------------
C
      NLAST = 0
C
      NSCFY = 0
c
      lspin=.false.                            !initialize L-spinor flag
C
      IF (NITIT.EQ.0) ITY = 0
C
      IF (ITY.EQ.0) WRITE (IWRITE,3140)
      IF (ITY.EQ.1) WRITE (IWRITE,3180)
      IF (ITY.EQ.2) WRITE (IWRITE,3190)
      IF (NCMIN.EQ.1) WRITE (IWRITE,3200)
      IF (NCMIN.GT.1) WRITE (IWRITE,3210)
      IF (ITC(4).EQ.1) WRITE (IWRITE,3240)
C-----------------------------------------------------------------------
      WRITE (IWRITE,3220)
      DO J = 1,NW
        icut(j)=0
        IF (JFIX(J).EQ.0) THEN
          WRITE (IWRITE,3230) J,NP(J),NH(J),NP(J),NAK(J),NKJ(J),NKL(J)
        ELSE
          WRITE (IWRITE,3170) J,NP(J),NH(J),NP(J),NAK(J),NKJ(J),NKL(J)
        ENDIF
      ENDDO
      WRITE (IWRITE,3250)
C-----------------------------------------------------------------------
C
C   Set up initial estimates for the wavefunctions
C
      IF (NUCTYP.GT.0) THEN
        DO J = 1,NW
          MPOIN(J) = N
          XAM(J) = ZERO
          E(J) = -ONE
          FK = NAK(J)
          GAMA(J) = ABS(FK)
        ENDDO
      ELSE
        CON = Z/C
        CON = CON*CON
        DO J = 1,NW
          MPOIN(J) = N
          XAM(J) = ZERO
          E(J) = -ONE
          FK = NAK(J)
          GAMA(J) = SQRT(FK*FK-CON)
        ENDDO
      ENDIF
C
      NWTOT = 0
C-----------------------------------------------------------------------
C
C   If IR2 is positive then an MCDF dump is available
C   this is then read
C
C-----------------------------------------------------------------------
      IF (IR2.GT.0) THEN
C
        REWIND IR2
C
C  Read the dump title
C
        READ (IR2) IHEDIN,RECIN
        WRITE (IWRITE,3000) IHEDIN(1:40),IHEDIN(41:80),RECIN
C
        READ (IR2) NCY,NWY,NCFY,NY
        READ (IR2) ZY,RY,HY,CY
        ZY = ABS(ZY)
        IF (NY.GT.MXNP) THEN
          WRITE (IWRITE,3270) NY,MXNP
          STOP
        ENDIF
C
C  ++++ loop over orbitals on dump ++++
C
        DO I = 1,NWY
C
          READ (IR2) NHY,NPY,NAKY,EY
          READ (IR2) PZY,QZY
          READ (IR2) (P(L),L=1,NY), (Q(L),L=1,NY)
C
C  The orbital is used provided ILO has been set to 0.
C
          DO J = 1,NW
            IF (ILO(J).EQ.0) THEN
              IF (NPY.EQ.NP(J) .AND. NAKY.EQ.NAK(J)) THEN
                E(J) = EY
                CALL SCORB(NLAST,J,ZY,RY,HY,NY,PZY,QZY)
                WRITE (IWRITE,3280) NP(J),NH(J),E(J),MPOIN(J)
                ILO(J) = -1
                NWTOT = NWTOT+1
                GOTO 20
              ENDIF
            ENDIF
          ENDDO
C
   20     CONTINUE
        ENDDO
C
      ENDIF
C-----------------------------------------------------------------------
C
C  If IR3 is positive then read from an orbitals dump
C
C-----------------------------------------------------------------------
      IF (IR3.GT.0) THEN
C
   30   CONTINUE
        READ (IR3,END=40) NHY,NPY,NAKY,NY,ZY,HY,RY,EY,PZY,QZY
C
        IF (NY.GT.MXNP) THEN
          WRITE (IWRITE,3270) NY,MXNP
          STOP
        ENDIF
C
        READ (IR3) (P(L),L=1,NY), (Q(L),L=1,NY)
C
C ++++ read the orbitals for which ILO is set to 1 ++++
C
        DO J = 1,NW
          IF (ILO(J).EQ.1 .OR. ILO(J).EQ.-2) THEN
            IF (NPY.EQ.NP(J) .AND. NAKY.EQ.NAK(J)) THEN
              E(J) = EY
              CALL SCORB(NLAST,J,ZY,RY,HY,NY,PZY,QZY)
              WRITE (IWRITE,3260) NP(J),NH(J),E(J),MPOIN(J)
              IF (ILO(J).NE.-2) THEN
                ILO(J) = -2
                NWTOT = NWTOT+1
              ENDIF
              GOTO 30
            ENDIF
          ENDIF
        ENDDO
C
        GOTO 30
C
   40   CONTINUE
        DO J = 1,NW
          IF (ILO(J).EQ.-2) ILO(J) = -1
        ENDDO
C
      ENDIF
C-----------------------------------------------------------------------
C
C  Set up the nuclear potential. This is stored in array ZZ.
C
      CALL NUCPOT
C-----------------------------------------------------------------------
C
C  The remainder of the orbitals are either Thomas-Fermi or Coulomb
C  When option 1 is set the estimates are Coulomb.
C
      LSTWAV = .FALSE.
C
      IF (NWTOT.LT.NW) THEN
C
        IF (ITC(1).EQ.0) CALL TFPOT
C
        DO J = 1,NW
          IF (ILO(J).GE.0) THEN
            IF (ILO(J).EQ.3 .OR. ITC(1).EQ.1) THEN
              CALL COULG(NLAST,J)
              WRITE (IWRITE,3020) NP(J),NH(J),E(J),MPOIN(J)
            ELSEIF (ILO(J).EQ.4 .OR. ILO(J).EQ.5) THEN
              IF (ILO(J).EQ.4) THEN
                CALL STWAVE(NLAST,J,0)
                WRITE (IWRITE,3050) NP(J),NH(J),E(J),MPOIN(J)
              ELSE
                CALL STWAVE(NLAST,J,1)
                WRITE (IWRITE,3060) NP(J),NH(J),E(J),MPOIN(J)
              ENDIF
              LSTWAV = .TRUE.
            ELSE
              CALL TFWAVE(NLAST,J,MF)
              IF (MF.EQ.0) THEN
                WRITE (IWRITE,3010) NP(J),NH(J),E(J),MPOIN(J)
              ELSE
                CALL COULG(NLAST,J)
                WRITE (IWRITE,3020) NP(J),NH(J),E(J),MPOIN(J)
              ENDIF
            ENDIF
          ENDIF
        ENDDO
c
c   If L-spinors, form new basis from zero-order.
c
        if(lspin)then
c
          call rritz(nlast)
c
          if(itc(22).ne.0)then
            write(*,3300)
            write(iwrite,3300)
            itc(22)=0
          endif
c
        endif
C
      ENDIF
C-----------------------------------------------------------------------
C
C   Set the value of N to be the largest for the orbitals.
C
      NBIG = 0
      DO J = 1,NW
        IF (MPOIN(J).GT.NBIG) NBIG = MPOIN(J)
      ENDDO
      N = NBIG
C
      NLAST = MPOS(NW)+MPOIN(NW)-1
C
      WRITE (IWRITE,3290) NLAST,MXNG,N,MXNP,RGRID(1),RGRID(N)
C
      CALL PROPG(1)
C-----------------------------------------------------------------------
C
C   Read the MCP coefficients from MCP file.
C
      CALL MCPIN(IR1)
C-----------------------------------------------------------------------
C
C   Set up the mixing coefficients and generalised occupation numbers.
C
      if(lspin)then                   !L-spinors for DARC ZSTAT
        coueng(1)=one
        do j=2,ncf
          coueng(j)=zero
        enddo
        do i=1,nw
          ucf(i)=iq(i,1)
        enddo
      elseIF (ITY.EQ.2) THEN
        SUM = ZERO
        DO J = 1,NCF
          SUM = SUM+WT(J)
        ENDDO
        FAC1 = ONE/SUM
        DO J = 1,NCF
          COUENG(J) = SQRT(FAC1*WT(J))
        ENDDO
        DO I = 1,NW
          SUM = ZERO
          DO J = 1,NCF
            SUM = SUM+WT(J)*IQ(I,J)
          ENDDO
          UCF(I) = SUM*FAC1
        ENDDO
      ELSE
        FAC1 = ONE/NCF
        FAC2 = SQRT(FAC1)
        DO J = 1,NCF
          COUENG(J) = FAC2
        ENDDO
        DO I = 1,NW
          SUM = ZERO
          DO J = 1,NCF
            SUM = SUM+IQ(I,J)
          ENDDO
          UCF(I) = FAC1*SUM
        ENDDO
      ENDIF
C-----------------------------------------------------------------------
C
C   Determine if Lagrange multipliers are required
C
      NEC = 0
C
      IF (NITIT.GT.0 .OR. LSTWAV) THEN
        IF (ITC(2).EQ.1) THEN
          WRITE (IWRITE,3110)
        ELSE
          IF (NW.GT.1) THEN
            NWM = NW-1
            DO JA = 1,NWM
              JP = JA+1
              DO JB = JP,NW
                IF (NAK(JA).NE.NAK(JB)) GOTO 60
                IF (NP(JA).EQ.NP(JB)) GOTO 60
                IF (ABS(UCF(JA)-DBLE(NKJ(JA))-ONE).GT.EPS10) GOTO 50
                IF (ABS(UCF(JB)-DBLE(NKJ(JB))-ONE).GT.EPS10) GOTO 50
                GOTO 60
C
   50           CONTINUE
                NEC = NEC+1
                IF (NEC.GT.MXNO) THEN
                  WRITE (IWRITE,3130)
                  STOP
                ENDIF
C
                IECC(NEC) = JA+NW1*JB
                ECV(NEC) = ZERO
   60           CONTINUE
              ENDDO
            ENDDO
          ENDIF
C
        ENDIF
      ENDIF
C
      IF (NEC.EQ.0) THEN
        WRITE (IWRITE,3120)
      ELSE
        WRITE (IWRITE,3090)
        DO I = 1,NEC
          MA = IECC(I)/NW1
          MB = IECC(I)-NW1*MA
          WRITE (IWRITE,3100) NP(MB),NH(MB),NP(MA),NH(MA)
        ENDDO
      ENDIF
C-----------------------------------------------------------------------
C
C  Improve wavefunction approximation with Slater-type orbitals input
C
      IF (LSTWAV) CALL STWOPT
C
      IF (ITC(9).EQ.1) CALL PRWF (0)
C
      WRITE (IWRITE,3040)
      WRITE (IPUNCH,3040)
C-----------------------------------------------------------------------
 3000 FORMAT (/' Dump title  : ',A40/'               ',A40/' Run at : ',!
     +A20/1X,71('*'))
 3010 FORMAT (' *** Thomas-Fermi estimate *** ',I2,A2,' E = ',1P,E12.5,2!
     +X,I4,' points')
 3020 FORMAT (' ***      Coulomb estimate *** ',I2,A2,' E = ',1P,E12.5,2!
     +X,I4,' points')
 3030 FORMAT (/1X,71('*')/' routine INIT : start of MCDF calculation'/1X!
     +,71('*')/' Title  : ',A40/'          ',A40/' Run at : ',A20/1X,71(!
     +'*'))
 3040 FORMAT (/1X,71('*'))
 3050 FORMAT (' ***    Slater-type coeffs *** ',I2,A2,' E = ',1P,E12.5,2!
     +X,I4,' points')
 3060 FORMAT (' ***  Clementi-type coeffs *** ',I2,A2,' E = ',1P,E12.5,2!
     +X,I4,' points')
 3070 FORMAT (/' atomic units are used except where indicated'/         !
     +' the following conversion factors are set in routine DATAIN'/    !
     +' using the atomic weight set to infinity'/'     1 a.u. = ',1P,E17!
     +.10,' cm-1'/'     1 a.u. = ',E17.10,' eV')
 3080 FORMAT (/' atomic units are used except where indicated'/         !
     +' the following conversion factors are set in routine DATAIN'/    !
     +' using atomic weight = ',F10.5/'     1 a.u. = ',1P,E17.10,' cm-1'!
     +/'     1 a.u. = ',E17.10,' eV')
 3090 FORMAT (/' include Lagrange multipliers between'/)
 3100 FORMAT (16X,I2,A2,2X,I2,A2)
 3110 FORMAT (/' Lagrange multipliers are not to be included')
 3120 FORMAT (/' Lagrange multipliers are not required')
 3130 FORMAT (/' ERROR in INIT : dimension for NEC ... STOPPING')
 3140 FORMAT (/' configuration interaction (CI) calculation')
 3150 FORMAT (/' Z      (atomic number)                   = ',F6.2/     !
     +' C      (speed of light)                  = ',1P,E17.10/         !
     +' RNT    (first grid point)                = ',E10.3/             !
     +' H      (grid step-size)                  = ',E10.3/             !
     +' ACCY   (accuracy)                        = ',E10.3/             !
     +' CUTOFF (wave-function cut-off parameter) = ',E10.3)
 3160 FORMAT (' N      (maximum grid point at ',F8.1,')  =',I5)
 3170 FORMAT (1X,I2,1X,I2,A2,4I4,'  fixed orbital')
 3180 FORMAT (/' average level (AL) calculation')
 3190 FORMAT (/' extended average level (EAL) calculation')
 3200 FORMAT (/' optimal level (OL) calculation')
 3210 FORMAT (/' extended optimal level (EOL) calculation')
 3220 FORMAT (/1X,' orbital  N',3X,'K',2X,'2J',3X,'L'/)
 3230 FORMAT (1X,I2,1X,I2,A2,4I4)
 3240 FORMAT (/' using Mann and Cowan modification to potentials')
 3250 FORMAT (1X)
 3260 FORMAT (' *** read from ORBS file   *** ',I2,A2,' E = ',1P,E12.5,2!
     +X,I4,' points')
 3270 FORMAT (/' ERROR in INIT : dimension ... STOPPING'/               !
     +' You must increase MXNP to at least ',I6,                        !
     +' from the present value of ',I6)
 3280 FORMAT (' *** read from MCDF file   *** ',I2,A2,' E = ',1P,E12.5,2!
     +X,I4,' points')
 3290 FORMAT (/' number of w.f. points = ',I7,' (max=',I7,')'/          !
     +' number of grid points = ',I7,' (max=',I7,')'/                   !
     +'     first grid point  = ',1P,E12.5/'      last grid point  = ',E!
     +12.5)
 3300 format(/'L-spinor setting overrides ITC(22)=1'/)
      END
C
C                             *******************
C
      SUBROUTINE INTRPG(ARG,VAL,X,N,Y)
C
C-----------------------------------------------------------------------
C
C  Uses Lagrange interpolation formula to obtain value of VAL(X).
C  ARG(I),VAL(I) ,I=1,N contain the data values.
C
C  No subroutines called.
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
C
C  Parameter variables
C
      DOUBLE PRECISION ZERO
      PARAMETER (ZERO=0.D0)
      DOUBLE PRECISION ONE
      PARAMETER (ONE=1.D0)
C
C  Argument variables
C
      INTEGER N
      DOUBLE PRECISION ARG(N),VAL(N),X,Y
C
C  Local variables
C
      DOUBLE PRECISION PL
      INTEGER J,L
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
      Y = ZERO
      DO L = 1,N
        PL = ONE
        DO J = 1,N
          IF (L-J) 10,20,10
   10     CONTINUE
          PL = (X-ARG(J))*PL/(ARG(L)-ARG(J))
   20     CONTINUE
        ENDDO
        Y = Y+PL*VAL(L)
      ENDDO
C
      END
C
C                             *******************
C
      FUNCTION IROW1(NELC,KSI)
C
C-----------------------------------------------------------------------
C
C  Locate the row position of configuration J(**N) in table NTAB.
C
C  No subroutines called.
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INTEGER IROW1
C
C  Argument variables
C
      INTEGER KSI,NELC
C
C  Local variables
C
      INTEGER KQ1,KQ2,KQL
C
C  Common variables
C
      INTEGER IPUNCH,IREAD,IWRITE
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
      IF (NELC.LE.0 .OR. NELC.GT.KSI) THEN
        WRITE (IWRITE,3000) NELC,KSI
        IF (IPUNCH.GT.0) WRITE (IPUNCH,3000) NELC,KSI
        STOP
      ENDIF
C
      KQ1 = NELC-1
      KQ2 = KSI-KQ1
      KQL = MIN(KQ1,KQ2)+1
C
      IF (KQL.EQ.1) THEN
        IROW1 = 1
      ELSE
        IROW1 = (KSI*(KSI-2))/8+KQL
      ENDIF
C
 3000 FORMAT (' STOPPING in routine IROW1'/                             !
     +' Termination because of data ERROR'/1X,I3,                       !
     +' electrons in shell with 2j+1 = ',I3)
      END
C
C                             *******************
C
      FUNCTION ITRIG(I1,I2,I3)
C
C-----------------------------------------------------------------------
C
C  The triangular delta.
C
C  INPUT  -   values of 2*J+1;
C  OUTPUT -   1, if J'S form a triangle,
C             0, otherwise.
C
C  No subroutines called.
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INTEGER ITRIG
C
C  Argument variables
C
      INTEGER I1,I2,I3
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IF (I1.GE. (ABS(I2-I3)+1) .AND. (I1.LE. (I2+I3-1))) THEN
        ITRIG = 1
      ELSE
        ITRIG = 0
      ENDIF
C
      END
C
C                             *******************
C
      SUBROUTINE JCLIST(NST,NFI)
C
C-----------------------------------------------------------------------
C
C  This subroutine sets up an array of coupled J values arising from
C  all relativistic subshells originating from one open nonrelativistic
C  subshell, whether they are open or not. The array is used in JJLS.
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  Argument variables
C
      INTEGER NFI,NST
C
C  Local variables
C
      INTEGER I1,I2,ICF,ICUP
      INTEGER IOPEN,J,JC
C
C  Common variables
C
      INTEGER JPOS(4),MLX(4),MQX(4),NOPEN
      COMMON / NRD01  / MLX,MQX,JPOS,NOPEN
C
C  Common variables
C
      INTEGER JSCUP(8,MXNC)
      COMMON / NRD05  / JSCUP
C
C  Common variables
C
      INTEGER ICHOP(MXNW,MXNC),IEXC
      INTEGER JCUP(10,MXNC),JQS(3,MXNW,MXNC)
      COMMON / ORB06  / JQS,JCUP,ICHOP,IEXC
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
      DO ICF = NST,NFI
        ICUP = -1
        J = 0
        JC = 1
        DO IOPEN = 1,NOPEN
          I2 = JPOS(IOPEN)
          IF (MLX(IOPEN).EQ.0) GOTO 20
          I1 = I2-1
          IF (ICHOP(I1,ICF).NE.0) GOTO 20
          ICUP = ICUP+1
          IF (ICUP.GT.0) GOTO 10
          JC = JQS(3,I1,ICF)
          GOTO 20
C
   10     CONTINUE
          JC = JCUP(ICUP,ICF)
   20     CONTINUE
          J = J+1
          JSCUP(J,ICF) = JC
          IF (ICHOP(I2,ICF).NE.0) GOTO 40
          ICUP = ICUP+1
          IF (ICUP.GT.0) GOTO 30
          JC = JQS(3,I2,ICF)
          GOTO 40
C
   30     CONTINUE
          JC = JCUP(ICUP,ICF)
   40     CONTINUE
          J = J+1
          JSCUP(J,ICF) = JC
        ENDDO
      ENDDO
C
      END
C
C                             *******************
C
      SUBROUTINE JJLS(NST,NCFN,IFAIL,CHECK)
C
C-----------------------------------------------------------------------
C
C  This subroutine calculates coefficients for transformation from
C  JJ to LS coupling. The coefficient divides into three parts:
C  (1) transformation from successive coupling of J values to
C      coupling of J values for subshells with the same N,L and
C      recoupling to give the total J value. This involves a
C      Racah coefficient for each subshell and a summation over
C      possible J values for the coupled subshells.
C  (2) transformation of single subshells from JJ to LS coupling
C      these transformation coefficients are given as BLOCK DATA
C  (3) transformation of coupling of subshells from JJ to LS
C      coupling. This involves a 3NJ symbol, where N=2*NOPEN+1
C  A check is made on the orthonormality of the transformation
C  coefficients, flagged by IFAIL.
C
C  Subroutines called : SSTC,DRACAH,GENSUM
C
C-----------------------------------------------------------------------
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      LOGICAL FREE
      LOGICAL NTRIG
C
      PARAMETER (MANGM = 60)
      PARAMETER (MTRIAD=20)
      PARAMETER (M3MNGM = 3*MANGM)
      PARAMETER (M6J = 20)
      COMMON / NJS00  / J6C,J7C,J8C,JWC
      COMMON / NJS01  / J6(M3MNGM),J7(M3MNGM),J8(M3MNGM),
     +JW(6,M6J)
      COMMON / NJS02  / ICOUNT,J2TEST(MTRIAD),J3TEST(MTRIAD)
C
      INCLUDE 'grasp0.inc'
C
      COMMON / ANG00  / MMOM,NMOM,J1(MANGM),J2(MTRIAD,3),J3(MTRIAD,3),  !
     +                  FREE(MANGM)
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
      COMMON / NRD00  / TC(MXNC,MXNC)
      COMMON / NRD01  / MLX(4),MQX(4),JPOS(4),NOPEN
      COMMON / NRD05  / JSCUP(8,MXNC)
      COMMON / NRD06  / LSV(5,4,MXNC)
      COMMON / ORB04  / NW,NCF,NP(MXNW),NAK(MXNW),IQ(MXNW,MXNC)
      COMMON / ORB06  / JQS(3,MXNW,MXNC),JCUP(10,MXNC),ICHOP(MXNW,MXNC),!
     +                  IEXC
C
      PARAMETER (ACCY=1.D-8)
      PARAMETER (ZERO=0.D0)
      PARAMETER (ONE=1.D0)
C
      DIMENSION NCASE(4),JCASE(4,10),WCASE(4,10)
C
      NTRIG(I,J,K) = I.GE.J+K.OR.J.GE.K+I.OR.K.GE.I+J
C-----------------------------------------------------------------------
      CHECK = -ONE
C
C  Loop thru all possible relativistic CSF
C
      DO ICF = NST,NCF
C
C  First open subshell
C
        IF (NTRIG(LSV(2,1,NCFN),LSV(3,1,NCFN),JSCUP(2,ICF))) GOTO 110
        CALL SSTC(1,NCFN,ICF,JSCUP(2,ICF),COEFF)
C
C  Branch here for one open subshell
C
        IF (NOPEN.EQ.1) GOTO 100
        J1(3) = JSCUP(2,ICF)
C
C  Set up arrays with possible J values for nonrelativistic subshells
C  Store values of SSTC * 6-J symbol for each case
C
        DO I = 2,NOPEN
          II = I+I
          NJ1 = JSCUP(II-2,ICF)
          NJP = JSCUP(II-1,ICF)
          NJ2 = JSCUP(II,ICF)
          K = 0
          IF (MLX(I).NE.0) GOTO 10
          LJ1 = 1
          LJ2 = 2
          GOTO 20
C
   10     CONTINUE
          JP = JPOS(I)
          LJ1 = JQS(3,JP-1,ICF)
          LJ2 = JQS(3,JP,ICF)
   20     CONTINUE
          NJMIN = ABS(LJ2-LJ1)+1
          NJI = LJ2+LJ1+1
   30     CONTINUE
          NJI = NJI-2
          IF (NJI.LT.NJMIN) GOTO 40
          IF (NTRIG(NJ1,NJI,NJ2)) GOTO 30
          IF (NTRIG(LSV(2,I,NCFN),LSV(3,I,NCFN),NJI)) GOTO 30
          K = K+1
          JCASE(I,K) = NJI
          CALL SSTC(I,NCFN,ICF,NJI,WA)
          CALL DRACAH(NJ1-1,LJ1-1,NJ2-1,LJ2-1,NJP-1,NJI-1,WB)
          WCASE(I,K) = WA*WB*SQRT(DBLE(NJP*NJI))
          GOTO 30
C
   40     CONTINUE
          IF (K.EQ.0) GOTO 110
          NCASE(I) = K
        ENDDO
C
C  Sum over all possible cases to form transformation coefficient
C
        SUM = ZERO
        I2 = 0
   50   CONTINUE
        I2 = I2+1
        IF (I2.GT.NCASE(2)) GOTO 90
        TERM = WCASE(2,I2)
        J1(6) = JCASE(2,I2)
        J1(9) = JSCUP(4,ICF)
C
C  Branch here for 2 open subshells
C
        IF (NOPEN.EQ.2) GOTO 80
        TERM1 = TERM
        I3 = 0
   60   CONTINUE
        I3 = I3+1
        IF (I3.GT.NCASE(3)) GOTO 50
        TERM = TERM1*WCASE(3,I3)
        J1(12) = JCASE(3,I3)
        J1(15) = JSCUP(6,ICF)
C
C  Branch here for 3 open shells
C
        IF (NOPEN.EQ.3) GOTO 80
        TERM2 = TERM
        I4 = 0
   70   CONTINUE
        I4 = I4+1
        IF (I4.GT.NCASE(4)) GOTO 60
        TERM = TERM2*WCASE(4,I4)
        J1(18) = JCASE(4,I4)
        J1(21) = JSCUP(8,ICF)
   80   CONTINUE
        CALL GENSUM (J6C,J7C,J8C,JWC,J6,J7,J8,JW,ICOUNT,J2TEST,
     +               J3TEST,WA)
        SUM = SUM+TERM*WA
        GOTO (100,50,60,70),NOPEN
C
   90   CONTINUE
        COEFF = COEFF*SUM
C
C  Store coefficient
C
  100   CONTINUE
        IF (ABS(COEFF).LT.ACCY) GOTO 110
        CHECK = CHECK+COEFF*COEFF
        TC(ICF,NCFN) = COEFF
        GOTO 120
C
  110   CONTINUE
        TC(ICF,NCFN) = ZERO
  120   CONTINUE
      ENDDO
C
C  Check orthonormality of transformations
C
      IFAIL = 0
      J = NCFN
  130 CONTINUE
      IF (ABS(CHECK).GT.ACCY) GOTO 140
      J = J-1
      IF (J.LT.NST) GOTO 150
      CHECK = ZERO
      DO ICF = NST,NCF
        CHECK = CHECK+TC(ICF,NCFN)*TC(ICF,J)
      ENDDO
      GOTO 130
C
  140 CONTINUE
      IFAIL = J
  150 CONTINUE
C
C   Error messages
C   ==============
C
      IF (IFAIL.GT.0) THEN
        WRITE (IWRITE,3000) J,CHECK
        WRITE (IPUNCH,3000) J,CHECK
        DO J = NST,NCFN
          WRITE (IWRITE,3010) J
          WRITE (IWRITE,3020) (TC(ICF,J),ICF=NST,NCF)
          WRITE (IPUNCH,3010) J
          WRITE (IPUNCH,3020) (TC(ICF,J),ICF=NST,NCF)
        ENDDO
      ENDIF
C
 3000 FORMAT (/' *** ERROR in JJLS ***'/' J,CHECK : ',I4,1P,E12.4)
 3010 FORMAT (/' J = ',I4)
 3020 FORMAT (' TC : ',1P,7E10.2)
      END
C
C                             *******************
C
      SUBROUTINE LAGR(J)
C
C-----------------------------------------------------------------------
C
C   Determine new estimates for the Lagrange multipliers
C   involving orbital J.
C
C   Subroutines called : YPOT , XPOT , QUAD , RINTI
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  External functions
C
      EXTERNAL RINTI
      DOUBLE PRECISION RINTI
C
C  Parameter variables
C
      DOUBLE PRECISION EPS3
      PARAMETER (EPS3=1.D-3)
      INTEGER N11
      PARAMETER (N11=MXNP+10)
C
C  Argument variables
C
      INTEGER J
C
C  Local variables
C
      DOUBLE PRECISION RESULT,WA,WW,WWX
      DOUBLE PRECISION WWY
      INTEGER I,IJ,IJJ,JA
      INTEGER JB,JJ,LB,NGRID
C
C  Common variables
C
      DOUBLE PRECISION HALF,ONE,TEN,TENTH
      DOUBLE PRECISION THREE,TWO,ZERO
      COMMON / CONS   / ZERO,HALF,TENTH,ONE,TWO,THREE,TEN
C
C  Common variables
C
      DOUBLE PRECISION ACCY,C,EPH,H
      DOUBLE PRECISION RNT,Z
      INTEGER N,NCPRIN,NW1
      COMMON / DEF01  / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN
C
C  Common variables
C
      INTEGER JFIX(MXNW)
      COMMON / FIXD   / JFIX
C
C  Common variables
C
      DOUBLE PRECISION EAV,UCF(MXNW)
      COMMON / HMAT   / EAV,UCF
C
C  Common variables
C
      DOUBLE PRECISION P(MXNP),PC(MXNP),Q(MXNP)
      DOUBLE PRECISION QC(MXNP)
      COMMON / INT2   / P,Q,PC,QC
C
C  Common variables
C
      DOUBLE PRECISION ZZ(MXNP)
      COMMON / NPOT   / ZZ
C
C  Common variables
C
      DOUBLE PRECISION ECV(MXNO)
      INTEGER IECC(MXNO),NEC
      COMMON / OFFD   / ECV,IECC,NEC
C
C  Common variables
C
      INTEGER ITC(50)
      COMMON / OPT01  / ITC
C
C  Common variables
C
      INTEGER MPOIN(MXNW),MPOS(MXNW)
      COMMON / PATY   / MPOIN,MPOS
C
C  Common variables
C
      DOUBLE PRECISION XTP(MXNP),XTQ(MXNP),YP(MXNP)
      DOUBLE PRECISION YQ(MXNP)
      COMMON / POTE   / YP,YQ,XTP,XTQ
C
C  Common variables
C
      DOUBLE PRECISION TA(N11),TB(N11)
      COMMON / TATB   / TA,TB
C
C  Common variables
C
      DOUBLE PRECISION PF(MXNG),QF(MXNG)
      COMMON / WAVE   / PF,QF
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
      IF (NEC.EQ.0) RETURN
C
C  Tabulate direct and exchange potentials for orbital J
C
      CALL YPOT(J,WW,ONE)
      CALL XPOT(J,ONE,WWX,WWY)
C
      NGRID = MPOIN(J)
      DO I = 1,NGRID
        Q(I) = YP(I)
        PC(I) = XTP(I)
        QC(I) = XTQ(I)
      ENDDO
C
      DO LB = 1,NEC
C
C  Search list for contributing Lagrange multiplier
C
        JA = IECC(LB)/NW1
        JB = IECC(LB)-NW1*JA
C
        IF (J.EQ.JA) THEN
          JJ = JB
C
        ELSE
          IF (J.EQ.JB) THEN
            JJ = JA
C
          ELSE
            GOTO 10
C
          ENDIF
C
        ENDIF
C
        CALL YPOT(JJ,WW,ONE)
        CALL XPOT(JJ,ONE,WWX,WWY)
C
        IF (ABS(UCF(J)-UCF(JJ)).LT.EPS3 .AND. JFIX(JJ).EQ.0) THEN
C
C   Orbitals J and JJ have the same occupation numbers.
C   Skip if option 3 is set.
C
          IF (ITC(3).EQ.1) THEN
            ECV(LB) = ZERO
C
          ELSE
C
            NGRID = MIN(MPOIN(J),MPOIN(JJ))
            IJ = MPOS(J)
            IJJ = MPOS(JJ)
            DO I = 1,NGRID
              TA(I) = (PF(IJ)*PF(IJJ)+QF(IJ)*QF(IJJ))*(Q(I)+YP(I)-TWO*ZZ!
     +(I))+(PF(IJJ)*QC(I)-QF(IJJ)*PC(I))*C+(PF(IJ)*XTQ(I)-QF(IJ)*XTP(I))!
     +*C
              IJ = IJ+1
              IJJ = IJJ+1
            ENDDO
C
            CALL QUAD(NGRID,RESULT)
C
            WA = RINTI(J,JJ)
            ECV(LB) = ECV(LB)+(RESULT-WA-WA)*UCF(J)*UCF(JJ)/(UCF(JJ)+UCF!
     +(J))
          ENDIF
C
        ELSE
C
C   Orbitals J and JJ have different occupation numbers.
C
          NGRID = MIN(MPOIN(J),MPOIN(JJ))
          IJ = MPOS(J)
          IJJ = MPOS(JJ)
          DO I = 1,NGRID
            TA(I) = (PF(IJ)*PF(IJJ)+QF(IJ)*QF(IJJ))*(Q(I)-YP(I))+(PF(IJJ!
     +)*QC(I)-QF(IJJ)*PC(I))*C-(PF(IJ)*XTQ(I)-QF(IJ)*XTP(I))*C
            IJ = IJ+1
            IJJ = IJJ+1
          ENDDO
C
          CALL QUAD(NGRID,RESULT)
C
          IF (JFIX(JJ).EQ.0) THEN
            ECV(LB) = ECV(LB)+RESULT*UCF(J)*UCF(JJ)/(UCF(JJ)-UCF(J))
C
          ELSE
            ECV(LB) = ECV(LB)+RESULT*UCF(J)
          ENDIF
C
        ENDIF
C
   10   CONTINUE
      ENDDO
C
      END
C
C                             *******************
C
      SUBROUTINE LOAD(IDT)
C
C-----------------------------------------------------------------------
C
C  This routine reads the wavefunctions and other information dumped
C  by the MCDF program. The orbitals and their occupation numbers are
C  checked for consistency.
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  Parameter variables
C
      DOUBLE PRECISION ZERO
      PARAMETER (ZERO=0.D0)
      INTEGER N11
      PARAMETER (N11=MXNP+10)
C
C  Argument variables
C
      INTEGER IDT
C
C  Local variables
C
      CHARACTER*80 IHEDIN
      CHARACTER*2 NHCHK(MXNW)
      CHARACTER*20 RECIN
      INTEGER I,J,M,NAKX
      INTEGER NCFCHK,NEC,NPCHK(MXNW),NSTART
      INTEGER NSTOP,NWCHK
      LOGICAL OK
C
C  Common variables
C
      DOUBLE PRECISION COUVEC(MXNC,MXNC)
      COMMON / BRET1  / COUVEC
C
C  Common variables
C
      DOUBLE PRECISION ACCY,C,EPH,H
      DOUBLE PRECISION RNT,Z
      INTEGER N,NCPRIN,NW1
      COMMON / DEF01  / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN
C
C  Common variables
C
      INTEGER ICCMIN(MXNC),NCMIN
      COMMON / DEF07  / NCMIN,ICCMIN
C
C  Common variables
C
      DOUBLE PRECISION BREENG(MXNC),COUENG(MXNC)
      COMMON / ENRG1  / COUENG,BREENG
C
C  Common variables
C
      DOUBLE PRECISION RGRID(MXNP)
      COMMON / GRID   / RGRID
C
C  Common variables
C
      DOUBLE PRECISION EAV,UCF(MXNW)
      COMMON / HMAT   / EAV,UCF
C
C  Common variables
C
      INTEGER IPUNCH,IREAD,IWRITE
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
C
C  Common variables
C
      INTEGER MAXDIM(20),NAXDIM(20)
      COMMON / MAXDIM / MAXDIM,NAXDIM
C
C  Common variables
C
      DOUBLE PRECISION PARM(4),Z1
      INTEGER NPARM,NUCTYP
      COMMON / NPAR   / PARM,Z1,NUCTYP,NPARM
C
C  Common variables
C
      DOUBLE PRECISION ZZ(MXNP)
      COMMON / NPOT   / ZZ
C
C  Common variables
C
      CHARACTER*2 NH(MXNW)
      COMMON / ORB00  / NH
C
C  Common variables
C
      DOUBLE PRECISION E(MXNW)
      COMMON / ORB01  / E
C
C  Common variables
C
      INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF
      INTEGER NP(MXNW),NW
      COMMON / ORB04  / NW,NCF,NP,NAK,IQ
C
C  Common variables
C
      INTEGER MPOIN(MXNW),MPOS(MXNW)
      COMMON / PATY   / MPOIN,MPOS
C
C  Common variables
C
      DOUBLE PRECISION CUTOFF
      COMMON / PATZ   / CUTOFF
C
C  Common variables
C
      DOUBLE PRECISION TA(N11),TB(N11)
      COMMON / TATB   / TA,TB
C
C  Common variables
C
      DOUBLE PRECISION PF(MXNG),QF(MXNG)
      COMMON / WAVE   / PF,QF
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
      WRITE (IWRITE,3180)
C
C  Read basic information.
C
      REWIND IDT
      READ (IDT) IHEDIN,RECIN
      READ (IDT) NCMIN,NWCHK,NCFCHK,N
      READ (IDT) Z,RNT,H,C
C
      WRITE (IWRITE,3020) IHEDIN(1:40),IHEDIN(41:80),RECIN
C
C  Test dump for completeness (i.e. Z>0)
C
      IF (Z.LE.ZERO) THEN
        WRITE (IWRITE,3010)
        WRITE (IPUNCH,3010)
        STOP
      ENDIF
C
      IF (N.GT.MXNP) THEN
        WRITE (IWRITE,3030) N,MXNP
        WRITE (IPUNCH,3030) N,MXNP
        STOP
      ENDIF
C
      IF (N.GT.MAXDIM(7)) MAXDIM(7) = N
C
      IF (NWCHK.GT.MXNW) THEN
        WRITE (IWRITE,3140) NWCHK,MXNW
        WRITE (IPUNCH,3140) NWCHK,MXNW
        STOP
      ENDIF
C
      IF (NWCHK.GT.MAXDIM(1)) MAXDIM(1) = NWCHK
C
      IF (NCFCHK.GT.MXNC) THEN
        WRITE (IWRITE,3150) NCFCHK,MXNC
        WRITE (IPUNCH,3150) NCFCHK,MXNC
        STOP
      ENDIF
C
      IF (NCFCHK.GT.MAXDIM(2)) MAXDIM(2) = NCFCHK
C
C  set up the logarithmic grid
C
      EPH = EXP(H)
      RGRID(1) = RNT
      DO I = 2,N
        RGRID(I) = RGRID(I-1)*EPH
      ENDDO
C
      DO I = 1,NWCHK
        MPOIN(I) = N
      ENDDO
C
C  read orbital information
C
      NSTART = 1
      DO I = 1,NWCHK
C
        READ (IDT) NHCHK(I),NPCHK(I),NAKX,E(I)
        READ (IDT)
        READ (IDT) (TA(J),J=1,N), (TB(J),J=1,N)
C
C  set the arrays MPOIN and MPOS
C
        DO J = N,1,-1
          IF (ABS(TA(J)).GT.CUTOFF) GOTO 10
        ENDDO
C
   10   CONTINUE
        MPOIN(I) = J
        MPOS(I) = NSTART
C
        NSTOP = MPOIN(I)+NSTART-1
        IF (NSTOP.GT.MXNG) THEN
          WRITE (IWRITE,3040) NSTOP,MXNG
          WRITE (IPUNCH,3040) NSTOP,MXNG
          STOP
        ENDIF
C
        M = 1
        DO J = NSTART,NSTOP
          PF(J) = TA(M)
          QF(J) = TB(M)
          M = M+1
        ENDDO
C
        NSTART = NSTOP+1
      ENDDO
C
      IF (NSTOP.GT.MAXDIM(17)) MAXDIM(17) = NSTOP
C
C  read generalised occupation and mixing numbers.
C
      READ (IDT)
      READ (IDT) (UCF(I),I=1,NWCHK)
      IF (NCMIN.GT.0) THEN
        READ (IDT)
        READ (IDT) (ICCMIN(I),I=1,NCMIN)
      ENDIF
C
C  read occupation numbers and eigenvectors
C
      READ (IDT)
      READ (IDT) EAV, ((COUVEC(I,J),J=1,NCFCHK),I=1,NCFCHK),(COUENG(I),I!
     +=1,NCFCHK)
C
C  skip over Lagrange multipliers
C
      READ (IDT) NEC
      IF (NEC.GT.0) THEN
        READ (IDT)
      ENDIF
C
C  read in nuclear information
C
      READ (IDT) NUCTYP
      READ (IDT) (ZZ(I),I=1,N)
      READ (IDT) Z1
      READ (IDT) NPARM
      IF (NPARM.GT.0) THEN
        READ (IDT) (PARM(I),I=1,NPARM)
      ENDIF
C
      READ (IDT)
      READ (IDT)
      READ (IDT)
      READ (IDT)
      READ (IDT)
C
C  check for consistency
C
      IF (NW.GT.NWCHK) GOTO 20
C
      DO I = 1,NW
        IF (NPCHK(I).NE.NP(I) .OR. NHCHK(I).NE.NH(I)) GOTO 20
      ENDDO
C
      IF (NWCHK.NE.NW) GOTO 30
      IF (NCFCHK.NE.NCF) GOTO 30
C
      OK = .TRUE.
      GOTO 40
C
C  error message
C
   20 CONTINUE
      WRITE (IWRITE,3000)
      OK = .FALSE.
      GOTO 40
C
   30 CONTINUE
      WRITE (IWRITE,3170)
      OK = .TRUE.
C-----------------------------------------------------------------------
   40 CONTINUE
      WRITE (IWRITE,3050) Z,C,RNT,H,CUTOFF,NW,NCF
C
      IF (NCMIN.EQ.0) THEN
        WRITE (IWRITE,3060)
      ELSE
        IF (NCMIN.GT.0) THEN
          WRITE (IWRITE,3070) NCMIN, (ICCMIN(I),I=1,NCMIN)
        ENDIF
      ENDIF
C
      WRITE (IWRITE,3080)
      DO I = 1,NWCHK
        WRITE (IWRITE,3090) I,NPCHK(I),NHCHK(I),MPOIN(I)
      ENDDO
C
      IF (NUCTYP.EQ.0) THEN
        WRITE (IWRITE,3100)
      ELSE
        IF (NUCTYP.EQ.1) THEN
          WRITE (IWRITE,3110) PARM(1)
        ELSE
          IF (NUCTYP.EQ.2) THEN
            WRITE (IWRITE,3120) PARM(1),PARM(2)
          ELSE
            IF (NUCTYP.EQ.3) THEN
              WRITE (IWRITE,3130) (PARM(I),I=1,4)
            ENDIF
          ENDIF
        ENDIF
      ENDIF
C
      WRITE (IWRITE,3160) NSTOP
C
      IF (OK) THEN
        WRITE (IWRITE,3190)
        RETURN
      ELSE
        STOP
      ENDIF
C-----------------------------------------------------------------------
 3000 FORMAT (/' ERROR in LOAD : input data is not consistent with dump'!
     +/' The orbitals are different ... STOPPING'/                      !
     +' CHECK the following information with input data')
 3010 FORMAT (/' ERROR in LOAD : dump read is not complete ... STOPPING'!
     +)
 3020 FORMAT (/' Dump title  : ',A40/'               ',A40/             !
     +' Run at      : ',A20)
 3030 FORMAT (/' ERROR in LOAD : dimension for grid points ... STOPPING'!
     +/' N =',I4,' but dimension is ',I4)
 3040 FORMAT (/                                                         !
     +' ERROR in LOAD : dimension for PF,QF arrays ... STOPPING'/       !
     +' NSTOP =',I6,' but dimension is ',I6)
 3050 FORMAT (/' Z      (atomic number)                   = ',F6.2/     !
     +' C      (speed of light)                  = ',1P,E17.10/         !
     +' RNT    (first grid point)                = ',E10.3/             !
     +' H      (grid step-size)                  = ',E10.3/             !
     +' CUTOFF (wave-function cut-off parameter) = ',E10.3/             !
     +' NW     (number of orbitals)              = ',I6/                !
     +' NCF    (number of CSFs)                  = ',I6)
 3060 FORMAT (/' average level calculation')
 3070 FORMAT (/' optimal level calculation on ',I4,' levels namely :'/(1!
     +X,10I4))
 3080 FORMAT (/'   orbital   NPOINT'/)
 3090 FORMAT (1X,I2,1X,I2,A2,7X,I4)
 3100 FORMAT (/' point nucleus calculation')
 3110 FORMAT (/' uniform nuclear charge calculation with atomic weight '!
     +,1P,E12.5)
 3120 FORMAT (/' Fermi two parameter nuclear charge distribution'/      !
     +' with half radius ',1P,E12.5,' and skin thickness ',E12.5)
 3130 FORMAT (/' user supplied nuclear potential via parameters '/1X,1P,!
     +4E14.5)
 3140 FORMAT (/' ERROR in LOAD : dimension for orbitals ... STOPPING'/  !
     +' NWCHK =',I4,' but dimension is ',I4)
 3150 FORMAT (/' ERROR in LOAD : dimension for CSFs ... STOPPING'/      !
     +' NCFCHK =',I4,' but dimension is ',I4)
 3160 FORMAT (/' the size of the PF,QF arrays is ',I6)
 3170 FORMAT (/                                                         !
     +' WARNING from LOAD : input data is not consistent with dump'/    !
     +' The number of orbitals or CSFs differ.'/                        !
     +' The program will continue assuming this is a CI case.'/         !
     +' CHECK the following information with input data')
 3180 FORMAT (/' >>>> routine LOAD called : MCDF/BENA dump being read')
 3190 FORMAT (/' >>>> returning from routine LOAD')
      END
C
C                             *******************
C
      SUBROUTINE LSTERM
C
C-----------------------------------------------------------------------
C
C  This subroutine sets up LS terms for each unfilled subshell,
C  storing V,S and L values in the array LSVT. Limitations on
C  configurations are (1) Q < 3 and (2) L < 3, Q > 3, where
C  Q is the reduced occupation, i.e. 4L+2-Q if Q > 2L+1, and
C  L is the subshell orbital angular momentum
C
C  No subroutines called
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
C
C  Local variables
C
      INTEGER I,IOPEN,L,M
      INTEGER NFULL,NL,NLL,NQ
      INTEGER NTRM
C
C  Common variables
C
      INTEGER IDN(5),IDNL(16,5),IDNS(16,5)
      INTEGER IDNV(16,5)
      COMMON / CSFD   / IDNV,IDNS,IDNL,IDN
C
C  Common variables
C
      INTEGER IPUNCH,IREAD,IWRITE
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
C
C  Common variables
C
      INTEGER JPOS(4),MLX(4),MQX(4),NOPEN
      COMMON / NRD01  / MLX,MQX,JPOS,NOPEN
C
C  Common variables
C
      INTEGER LSVT(5,16,4),NTERM(4)
      COMMON / NRD02  / NTERM,LSVT
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
      DO IOPEN = 1,NOPEN
        NQ = MQX(IOPEN)
        NL = MLX(IOPEN)
        NLL = NL+NL+1
        NFULL = NLL+NLL
        NQ = MIN(NQ,NFULL-NQ)
        IF (NQ-2) 10,20,30
C
C  one electron
C
   10   CONTINUE
        LSVT(1,1,IOPEN) = 1
        LSVT(2,1,IOPEN) = 2
        LSVT(3,1,IOPEN) = NLL
        NTERM(IOPEN) = 1
        GOTO 60
C
C  two electrons
C
   20   CONTINUE
        L = NFULL+1
        DO I = 1,NL
          L = L-4
          LSVT(1,I,IOPEN) = 2
          LSVT(2,I,IOPEN) = 3
          LSVT(3,I,IOPEN) = L
        ENDDO
        L = NFULL+3
        M = NL+1
        DO I = M,NLL
          L = L-4
          LSVT(1,I,IOPEN) = 2
          LSVT(2,I,IOPEN) = 1
          LSVT(3,I,IOPEN) = L
        ENDDO
        LSVT(1,NLL,IOPEN) = 0
        NTERM(IOPEN) = NLL
        GOTO 60
C
C  more than two electrons
C
   30   CONTINUE
        IF (NL-2) 40,50,70
   40   CONTINUE
        LSVT(1,1,IOPEN) = 3
        LSVT(2,1,IOPEN) = 4
        LSVT(3,1,IOPEN) = 1
        L = 7
        DO I = 2,3
          L = L-2
          LSVT(1,I,IOPEN) = L-2
          LSVT(2,I,IOPEN) = 2
          LSVT(3,I,IOPEN) = L
        ENDDO
        NTERM(IOPEN) = 3
        GOTO 60
C
   50   CONTINUE
        NTRM = IDN(NQ)
        DO I = 1,NTRM
          LSVT(1,I,IOPEN) = IDNV(I,NQ)
          LSVT(2,I,IOPEN) = IDNS(I,NQ)
          LSVT(3,I,IOPEN) = IDNL(I,NQ)
        ENDDO
        NTERM(IOPEN) = NTRM
   60   CONTINUE
      ENDDO
      RETURN
C
C  failure for more than two electrons for subshell with L > 2
C
   70 CONTINUE
      WRITE (IWRITE,3000)
      WRITE (IPUNCH,3000)
      STOP
C
 3000 FORMAT (/1X,                                                      !
     +'ERROR in LSTERM : more than 2 electrons for subshells with l>2 ',!
     +'not allowed')
      END
C
C                             *******************
C
      SUBROUTINE LTAB(IS,NQS,KS,IROWS)
C
C-----------------------------------------------------------------------
C
C  Locates rows of possible parents of active shell states for
C  accessing NTAB.
C
C  It is assumed that empty shells have been eliminated from
C  consideration by subroutine RKCO.
C
C  No subroutines called.
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
C
C  Argument variables
C
      INTEGER IROWS(4),IS(4),KS(4),NQS(4)
C
C  Local variables
C
      INTEGER I,KQ(4),KQ1,KQ2
C
C  Common variables
C
      INTEGER IPUNCH,IREAD,IWRITE
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
      IF (IS(1).EQ.IS(2)) NQS(1) = NQS(2) - 1
      IF (IS(3).EQ.IS(4)) NQS(3) = NQS(4) - 1
C
      DO I = 1,4
C
C  Fault exit - input data inconsistent
C
        IF (NQS(I).LE.0 .OR. NQS(I).GT.KS(I)) THEN
          WRITE (IWRITE,3000) NQS(I),IS(I),KS(I)
          IF (IPUNCH.GT.0) WRITE (IPUNCH,3000) NQS(I),IS(I),KS(I)
          STOP
        ENDIF
C
        KQ1 = NQS(I)-1
        KQ2 = KS(I)-KQ1
        KQ(I) = MIN(KQ1,KQ2)+1
C
C  Normal status - pointer properly defined.
C
        IF (KQ(I).NE.1) THEN
          IROWS(I) = (KS(I)*(KS(I)-2))/8+KQ(I)
        ELSE
          IROWS(I) = 1
        ENDIF
C
      ENDDO
C
 3000 FORMAT (/' Termination in LTAB because of data ERROR'/1X,I4,      !
     +'electrons in shell ',I3,' with 2j+1 =',I3)
      END
C
C                             *******************
C
      SUBROUTINE MAN4(IWRITE,KCHOP,IPAR,JMIN,JMAX,MFAIL,JSTORE)
C
C-----------------------------------------------------------------------
C
C   IWRITE = stream for output to printer
C
C   KCHOP
C   IPAR = parity
C   JMIN = min 2J
C   JMAX = max 2J
C
C   For a particular configuration this routine evaluates
C   all the possible ways of coupling the open shells
C   defined by MLX ( L values ) and MQX ( occupation numbers )
C   to give the resultant total J value JF.
C   IPAR is the parity of the configuration.
C
C   The results are then used to fill the COMMON blocks
C   ORB06 and ORB07.
C
C   Routines called : COUP
C
C  Tree of subprogram calls:
C
C      MAN4
C          COUP
C
C  Common block MAXDIM:
C    Elements never used, never set: NAXDIM
C  Common block NRD01:
C    Elements used but never set: JPOS
C    Elements never used, never set: NOPEN
C  Common block ORB04:
C    Elements used but never set: NW
C    Elements never used, never set: NP NAK
C  Common block ORB05:
C    Elements used but never set: NKJ
C    Elements never used, never set: NKL
C  Common block ORB06:
C    Elements set but never used: JQS JCUP
C    Elements never used, never set: IEXC
C  Common block ORB07:
C    Elements set but never used: all
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  Parameter variables
C
      INTEGER JSTMAX
      PARAMETER (JSTMAX=40)
      INTEGER ICASEX
      PARAMETER (ICASEX=100)
C
C  Argument variables
C
      INTEGER IPAR,IWRITE,JMAX,JMIN
      INTEGER JSTORE(0:JSTMAX),KCHOP(MXNW)
      LOGICAL MFAIL
C
C  Local variables
C
      INTEGER ICUP,JF,JFMAX,JFMIN
      INTEGER JK,JL,JM,JST
      INTEGER K,KC,KCASE
      INTEGER KCUP(ICASEX),KMAX,KMIN
      INTEGER KQ(2,ICASEX),KQS(3,2,ICASEX)
      INTEGER L,LA,LC,LCASE
      INTEGER LCUP(ICASEX),LL,LMAX
      INTEGER LMIN,LP,LQ(2,ICASEX)
      INTEGER LQS(3,2,ICASEX),MC,MCASE
      INTEGER MCUP(ICASEX),MMAX,MMIN
      INTEGER MODE,MQ(2,ICASEX)
      INTEGER MQS(3,2,ICASEX),NC,NCASE
      INTEGER NCUP(ICASEX),NQ(2,ICASEX)
      INTEGER NQS(3,2,ICASEX)
C
C  Common variables
C
      INTEGER MAXDIM(20),NAXDIM(20)
      COMMON / MAXDIM / MAXDIM,NAXDIM
C
C  Common variables
C
      INTEGER JPOS(4),MLX(4),MQX(4),NOPEN
      COMMON / NRD01  / MLX,MQX,JPOS,NOPEN
C
C  Common variables
C
      INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF
      INTEGER NP(MXNW),NW
      COMMON / ORB04  / NW,NCF,NP,NAK,IQ
C
C  Common variables
C
      INTEGER NKJ(MXNW),NKL(MXNW)
      COMMON / ORB05  / NKL,NKJ
C
C  Common variables
C
      INTEGER ICHOP(MXNW,MXNC),IEXC
      INTEGER JCUP(10,MXNC),JQS(3,MXNW,MXNC)
      COMMON / ORB06  / JQS,JCUP,ICHOP,IEXC
C
C  Common variables
C
      INTEGER ISPAR(MXNC),ITJPO(MXNC)
      COMMON / ORB07  / ITJPO,ISPAR
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
      DO JST = 0,JSTMAX
        JSTORE(JST) = 0
      ENDDO
C
      CALL COUP(IWRITE,MLX(1),MQX(1),0,0,KQS,KQ,KCUP,KCASE,0,ICASEX)
C
      IF (KCASE.GT.0) THEN
        DO KC = 1,KCASE
          KMIN = ABS(KCUP(KC)-KQS(3,2,KC))
          KMAX = KCUP(KC)+KQS(3,2,KC)-2
          DO JK = KMIN,KMAX,2
            CALL COUP(IWRITE,MLX(2),MQX(2),JK,0,LQS,LQ,LCUP,LCASE,0,ICAS!
     +EX)
C
            IF (LCASE.GT.0) THEN
              DO LC = 1,LCASE
                LMIN = ABS(LCUP(LC)-LQS(3,2,LC))
                LMAX = LCUP(LC)+LQS(3,2,LC)-2
                DO JL = LMIN,LMAX,2
                  CALL COUP(IWRITE,MLX(3),MQX(3),JL,0,MQS,MQ,MCUP,MCASE,!
     +0,ICASEX)
C
                  IF (MCASE.GT.0) THEN
                    DO MC = 1,MCASE
                      MMIN = ABS(MCUP(MC)-MQS(3,2,MC))
                      MMAX = MCUP(MC)+MQS(3,2,MC)-2
                      DO JM = MMIN,MMAX,2
C
                        DO JF = JMIN,JMAX,1
C
                          IF (JF.LT.0) THEN
                            MODE = 0
                          ELSE
                            MODE = 1
                          ENDIF
C
                          CALL COUP(IWRITE,MLX(4),MQX(4),JM,JF,NQS,NQ,NC!
     +UP,NCASE,MODE,ICASEX)
C
                          IF (NCASE.GT.0) THEN
                            DO NC = 1,NCASE
C*****
                              IF (JF.LT.0) THEN
                                JFMIN = ABS(NCUP(NC)-NQS(3,2,NC))
                                JFMAX = NCUP(NC)+NQS(3,2,NC)-2
                              ELSE
                                JFMIN = JF
                                JFMAX = JF
                              ENDIF
C
   10                         CONTINUE
                              NCF = NCF+1
                              IF (NCF.GT.MXNC) THEN
                                MFAIL = .TRUE.
                                GOTO 130
                              ENDIF
C
                              DO L = 1,NW
                                JQS(1,L,NCF) = 0
                                JQS(2,L,NCF) = 0
                                JQS(3,L,NCF) = 1
                                ICHOP(L,NCF) = -1
                                IF (KCHOP(L).EQ.-1) THEN
                                  IQ(L,NCF) = 0
                                ELSE
                                  IQ(L,NCF) = NKJ(L)+1
                                ENDIF
                              ENDDO
C
C
                              LP = JPOS(1)
                              IF (LP.GT.NW) GOTO 20
                              DO K = 1,3
                                JQS(K,LP,NCF) = KQS(K,2,KC)
                                IQ(LP,NCF) = KQ(2,KC)
                                IF (MLX(1).GT.0) THEN
                                  JQS(K,LP-1,NCF) = KQS(K,1,KC)
                                  IQ(LP-1,NCF) = KQ(1,KC)
                                ENDIF
                              ENDDO
C
                              LP = JPOS(2)
                              IF (LP.GT.NW) GOTO 20
                              DO K = 1,3
                                JQS(K,LP,NCF) = LQS(K,2,LC)
                                IQ(LP,NCF) = LQ(2,LC)
                                IF (MLX(2).GT.0) THEN
                                  JQS(K,LP-1,NCF) = LQS(K,1,LC)
                                  IQ(LP-1,NCF) = LQ(1,LC)
                                ENDIF
                              ENDDO
C
                              LP = JPOS(3)
                              IF (LP.GT.NW) GOTO 20
                              DO K = 1,3
                                JQS(K,LP,NCF) = MQS(K,2,MC)
                                IQ(LP,NCF) = MQ(2,MC)
                                IF (MLX(3).GT.0) THEN
                                  JQS(K,LP-1,NCF) = MQS(K,1,MC)
                                  IQ(LP-1,NCF) = MQ(1,MC)
                                ENDIF
                              ENDDO
C
                              LP = JPOS(4)
                              IF (LP.GT.NW) GOTO 20
                              DO K = 1,3
                                JQS(K,LP,NCF) = NQS(K,2,NC)
                                IQ(LP,NCF) = NQ(2,NC)
                                IF (MLX(4).GT.0) THEN
                                  JQS(K,LP-1,NCF) = NQS(K,1,NC)
                                  IQ(LP-1,NCF) = NQ(1,NC)
                                ENDIF
                              ENDDO
C
C
   20                         CONTINUE
                              LA = 0
                              DO L = 1,4
                                LP = JPOS(L)
                                IF (LP.GT.NW) GOTO 30
                                LA = LA+2
                                IF (IQ(LP,NCF).EQ.NKJ(LP)+1) THEN
                                  ICHOP(LA,NCF) = 1
                                ELSEIF (IQ(LP,NCF).EQ.0) THEN
                                  ICHOP(LA,NCF) = -1
                                ELSE
                                  ICHOP(LA,NCF) = 0
                                ENDIF
                                IF (MLX(L).GT.0) THEN
                                  IF (IQ(LP-1,NCF).EQ.NKJ(LP-1)+1) THEN
                                    ICHOP(LA-1,NCF) = 1
                                  ELSEIF (IQ(LP-1,NCF).EQ.0) THEN
                                    ICHOP(LA-1,NCF) = -1
                                  ELSE
                                    ICHOP(LA-1,NCF) = 0
                                  ENDIF
                                ELSE
                                  ICHOP(LA-1,NCF) = -1
                                ENDIF
                              ENDDO
C
   30                         CONTINUE
                              ICUP = 1
                              DO L = 1,8
                                LL = L
                                IF (ICHOP(L,NCF).EQ.0) GOTO 40
                              ENDDO
                              GOTO 120
C
   40                         CONTINUE
                              GOTO (50,60,70,80,90,100,110,120),LL
C
   50                         CONTINUE
                              IF (ICHOP(2,NCF).NE.0) GOTO 60
                              JCUP(ICUP,NCF) = JK+1
                              ICUP = ICUP+1
   60                         CONTINUE
                              IF (ICHOP(3,NCF).NE.0) GOTO 70
                              JCUP(ICUP,NCF) = LCUP(LC)
                              ICUP = ICUP+1
   70                         CONTINUE
                              IF (ICHOP(4,NCF).NE.0) GOTO 80
                              JCUP(ICUP,NCF) = JL+1
                              ICUP = ICUP+1
   80                         CONTINUE
                              IF (ICHOP(5,NCF).NE.0) GOTO 90
                              JCUP(ICUP,NCF) = MCUP(MC)
                              ICUP = ICUP+1
   90                         CONTINUE
                              IF (ICHOP(6,NCF).NE.0) GOTO 100
                              JCUP(ICUP,NCF) = JM+1
                              ICUP = ICUP+1
  100                         CONTINUE
                              IF (ICHOP(7,NCF).NE.0) GOTO 110
                              JCUP(ICUP,NCF) = NCUP(NC)
                              ICUP = ICUP+1
  110                         CONTINUE
                              IF (ICHOP(8,NCF).NE.0) GOTO 120
                              JCUP(ICUP,NCF) = JFMIN+1
  120                         CONTINUE
C
                              DO L = 1,NW
                                ICHOP(L,NCF) = 0
                                IF (IQ(L,NCF).EQ.NKJ(L)+1) ICHOP(L,NCF) !
     += 1
                                IF (IQ(L,NCF).EQ.0) ICHOP(L,NCF) = -1
                              ENDDO
C
                              ITJPO(NCF) = JFMIN+1
                              ISPAR(NCF) = IPAR
C
  130                         CONTINUE
                              IF (JFMIN .LE. JSTMAX) THEN
                                JSTORE(JFMIN) = JSTORE(JFMIN)+1
                              ENDIF
                              JFMIN = JFMIN+2
                              IF (JFMIN.LE.JFMAX) GOTO 10
C******
                            ENDDO
                          ENDIF
C
                        ENDDO
                      ENDDO
                    ENDDO
                  ENDIF
C
                ENDDO
              ENDDO
            ENDIF
C
          ENDDO
        ENDDO
      ENDIF
C
      IF (NCF.GT.MAXDIM(2)) MAXDIM(2) = NCF
C
      END
C
C                             *******************
C
      SUBROUTINE MANOUT(NCFST)
C
C-----------------------------------------------------------------------
C
C  This routine prints out CSF data in a form which
C  can be read by subroutine DATR i.e. relativistic
C  CSF format. A description of this format is given
C  in the CPC-80 write-up of GRASP V0
C
C  NCFST is the first-1 CSF in the list to be considered
C  thus in GRASP NCFST=O
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  Argument variables
C
      INTEGER NCFST
C
C  Local variables
C
      CHARACTER*4 IBL,IOUT(19),JLAB(20),NUM(20)
      INTEGER I,IERR,IQ1,IX
      INTEGER J,JJ,JX,K
      INTEGER NCF1,NCF2,NCFS,NFULL
      INTEGER NOCC,NOPEN,NX
C
C  Common variables
C
      INTEGER IPUNCH,IREAD,IWRITE
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
C
C  Common variables
C
      INTEGER JTC(20)
      COMMON / OPT02  / JTC
C
C  Common variables
C
      CHARACTER*2 NH(MXNW)
      COMMON / ORB00  / NH
C
C  Common variables
C
      INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF
      INTEGER NP(MXNW),NW
      COMMON / ORB04  / NW,NCF,NP,NAK,IQ
C
C  Common variables
C
      INTEGER NKJ(MXNW),NKL(MXNW)
      COMMON / ORB05  / NKL,NKJ
C
C  Common variables
C
      INTEGER ICHOP(MXNW,MXNC),IEXC
      INTEGER JCUP(10,MXNC),JQS(3,MXNW,MXNC)
      COMMON / ORB06  / JQS,JCUP,ICHOP,IEXC
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      DATA NUM/'0   ','1   ','2   ','3   ','4   ','5   ','6   ','7   ','!
     +8   ','9   ','10  ','11  ','12  ','13  ','14  ','15  ','16  ','17 !
     + ','18  ','19  '/
      DATA JLAB/'0   ','1/2 ','1   ','3/2 ','2   ','5/2 ','3   ','7/2 ',!
     +'4   ','9/2 ','5   ','11/2','6   ','13/2','7   ','15/2','8   ','17!
     +/2','9   ','19/2'/
      DATA IBL/'    '/
C-----------------------------------------------------------------------
      NCF1 = NCFST+1
      NCF2 = NCFST+2
      NCFS = NCF-NCFST
C
      IF (NCFS.EQ.0) THEN
        WRITE (IWRITE,3040)
        RETURN
      ENDIF
C
      WRITE (IWRITE,3020)
      WRITE (IWRITE,3050) NCFS,NW
C
      DO I = 1,NW
C
        IQ1 = IQ(I,NCF1)
C
        IF (NCFS.GT.1) THEN
          DO J = NCF2,NCF
            IF (IQ(I,J).NE.IQ1) THEN
              WRITE (IWRITE,3030) NP(I),NH(I), (IQ(I,K),K=NCF1,NCF)
              GOTO 10
            ENDIF
          ENDDO
        ENDIF
C
        IF (IQ1.EQ.NKJ(I)+1) THEN
          WRITE (IWRITE,3030) NP(I),NH(I)
        ELSE
          WRITE (IWRITE,3030) NP(I),NH(I),IQ1
        ENDIF
C
   10   CONTINUE
      ENDDO
C
      IX = 0
C
      DO J = 1,9
        IF (JTC(J).EQ.0) GOTO 20
        IX = IX+1
        IOUT(IX) = NUM(J+1)
   20   CONTINUE
      ENDDO
C
      IF (IX.GT.0) THEN
        WRITE (IWRITE,3060) (IOUT(I),I=1,IX)
      ELSE
        WRITE (IWRITE,3060)
      ENDIF
C
      IERR = 0
C
      DO J = NCF1,NCF
        JJ = J-NCFST
        IX = 0
        NOPEN = 0
C
        DO I = 1,NW
          IF (ICHOP(I,J).EQ.0) THEN
            NOPEN = NOPEN+1
            NFULL = NKJ(I)+1
            NOCC = IQ(I,J)
            NOCC = MIN(NOCC,NFULL-NOCC)
C
            IF (NOCC.EQ.1) GOTO 30
C
            IF (NOCC.GT.2 .AND. NFULL.GT.8) THEN
              WRITE (IWRITE,3010)
              IERR = IERR+1
              GOTO 40
            ENDIF
C
            JX = JQS(3,I,J)
            IX = IX+1
            IOUT(IX) = JLAB(JX)
            IF (NFULL.NE.8) GOTO 30
            IF (NOCC.NE.4) GOTO 30
            IF (JX.NE.5 .AND. JX.NE.9) GOTO 30
            JX = JQS(1,I,J)
            IX = IX+1
            IOUT(IX) = NUM(JX+1)
C
          ENDIF
C
   30     CONTINUE
        ENDDO
C
        IF (NOPEN.GT.1) THEN
          NX = NOPEN-1
          IX = IX+1
          IOUT(IX) = IBL
          DO I = 1,NX
            JX = JCUP(I,J)
            IX = IX+1
            IOUT(IX) = JLAB(JX)
          ENDDO
        ENDIF
C
        IF (IX.GT.0) THEN
          WRITE (IWRITE,3000) JJ, (IOUT(I),I=1,IX)
        ENDIF
C
   40   CONTINUE
      ENDDO
C
      IF (IERR.GT.0) THEN
        STOP
      ELSE
        RETURN
      ENDIF
C
 3000 FORMAT (1X,I4,1X,19A4)
 3010 FORMAT (' MANOUT : data cannot be read by program....STOPPING')
 3020 FORMAT (/' Equivalent Relativistic Input Data'/)
 3030 FORMAT (1X,I2,A2,1X,24I3,2X,'C'/(6X,24I3,2X,'C'))
 3040 FORMAT (/' no configurations generated'/)
 3050 FORMAT (1X,2I4)
 3060 FORMAT (' ANG ',19A4)
      END
C
C                             *******************
C
      SUBROUTINE MATOUT(IWRITE,HAMIL,NR,NC,NRX,NCX,MODE)
C
C-----------------------------------------------------------------------
C
C   Routine for printing matrices.
C
C   MODE=1  symmetric
C   MODE=2  unsymmetric
C   MODE=3  matrix of eigenvectors
C   MODE=4  unsymmetric with no heading
C   MODE=5  symmetric with no heading
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
C
C  Argument variables
C
      INTEGER IWRITE,MODE,NC,NCX
      INTEGER NR,NRX
      DOUBLE PRECISION HAMIL(NRX,NCX)
C
C  Local variables
C
      INTEGER J1,J2,J3,JM
      INTEGER JP,L,L1,L2
      INTEGER M
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
      IF (MODE.EQ.1 .OR. MODE.EQ.5) GOTO 10
      IF (MODE.GT.1 .AND. MODE.LT.5) GOTO 80
      RETURN
C-----------------------------------------------------------------------
C
C   Symmetric matrix.
C
C-----------------------------------------------------------------------
   10 CONTINUE
      IF (MODE.EQ.1) WRITE (IWRITE,3070)
      JP = 5
      J1 = 1
      J2 = JP
C
   20 CONTINUE
      IF (J2.GT.NR) J2 = NR
      DO L1 = 1,J1
        WRITE (IWRITE,3010) (HAMIL(L1,L2),L2=J1,J2)
      ENDDO
C
      JM = J2-J1
      J3 = J1+1
C
      IF (JM.EQ.0) RETURN
      IF (JM.EQ.1) GOTO 30
      IF (JM.EQ.2) GOTO 40
      IF (JM.EQ.3) GOTO 50
      IF (JM.EQ.4) GOTO 60
C
   30 CONTINUE
      WRITE (IWRITE,3030) ((HAMIL(L1,L2),L2=L1,J2),L1=J3,J2)
      GOTO 70
C
   40 CONTINUE
      WRITE (IWRITE,3040) ((HAMIL(L1,L2),L2=L1,J2),L1=J3,J2)
      GOTO 70
C
   50 CONTINUE
      WRITE (IWRITE,3050) ((HAMIL(L1,L2),L2=L1,J2),L1=J3,J2)
      GOTO 70
C
   60 CONTINUE
      WRITE (IWRITE,3060) ((HAMIL(L1,L2),L2=L1,J2),L1=J3,J2)
C
   70 CONTINUE
      IF (J2.EQ.NR) RETURN
      J1 = J1+JP
      J2 = J2+JP
      GOTO 20
C-----------------------------------------------------------------------
C
C   Unsymmetric matrix.
C
C-----------------------------------------------------------------------
   80 CONTINUE
      IF (MODE.EQ.2) WRITE (IWRITE,3070)
      IF (MODE.EQ.3) WRITE (IWRITE,3080)
      JP = 5
      J1 = 1
      J2 = JP
   90 CONTINUE
      IF (J2.GT.NC) J2 = NC
      IF (MODE.EQ.3) THEN
        WRITE (IWRITE,3000) (L,L=J1,J2)
        WRITE (IWRITE,3020)
      ENDIF
C
      DO M = 1,NR
        WRITE (IWRITE,3010) (HAMIL(M,L),L=J1,J2)
      ENDDO
      WRITE (IWRITE,3020)
      IF (J2.EQ.NC) RETURN
      J1 = J1+JP
      J2 = J2+JP
      GOTO 90
C
 3000 FORMAT (1X,5(I8,7X))
 3010 FORMAT (1X,1P,5E15.7)
 3020 FORMAT (1X)
 3030 FORMAT (16X,1P,E15.7/)
 3040 FORMAT (16X,1P,2E15.7/31X,E15.7/)
 3050 FORMAT (16X,1P,3E15.7/31X,2E15.7/46X,E15.7/)
 3060 FORMAT (16X,1P,4E15.7/31X,3E15.7/46X,2E15.7/61X,E15.7/)
 3070 FORMAT (/' matrix elements'/)
 3080 FORMAT (/' eigenvectors'/)
      END
C
C                             *******************
C
      SUBROUTINE MATRIX
C
C-----------------------------------------------------------------------
C
C  This subroutine forms the zero-order Coulomb Hamiltonian matrix and 
C  diagonalises it. New estimates of the configuration mixing
C  coefficients are obtained.
C
C  Subroutine called: DSYEV
C
C  Diagonalisation is now by Jp - nrb 17/09/08
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  External functions
C
      EXTERNAL CLRX,RINTI,SLATER
      DOUBLE PRECISION CLRX,RINTI,SLATER
C
C  Parameter variables
C
      DOUBLE PRECISION EPS10
      PARAMETER (EPS10=1.D-10)
      INTEGER N10
      PARAMETER (N10=MXNX*MXNC)
      INTEGER N18
      PARAMETER (N18=MXNC*(MXNC+1)/2)
      INTEGER LWORK
      PARAMETER (LWORK=MXNC*3-1)
C
C  Local variables
C
      DOUBLE PRECISION AM,AMAX,COEF,EAU
      DOUBLE PRECISION FACTOR,WA,WB
      DOUBLE PRECISION WORK(LWORK)
      INTEGER I,IA,ICOEF,IFA
      INTEGER IFB,II,IJ,IL
      INTEGER ILCX,ILDA,ILDB,ILDN
      INTEGER IMARK,INFO,IP,IQA
      INTEGER IQB,IRS,ITR,ITRP
      INTEGER J,JA,JB,JJ
      INTEGER JM,JTR,K,KA
      INTEGER KB,KC,KD,KK
      INTEGER KMX,L,LM,LMN
      INTEGER LMX,NCFM,NWM
C
C  Common variables
C
      DOUBLE PRECISION COUVEC(MXNC,MXNC)
      COMMON / BRET1  / COUVEC
C
C  Common variables
C
      DOUBLE PRECISION HALF,ONE,TEN,TENTH
      DOUBLE PRECISION THREE,TWO,ZERO
      COMMON / CONS   / ZERO,HALF,TENTH,ONE,TWO,THREE,TEN
C
C  Common variables
C
      DOUBLE PRECISION ACCY,C,EPH,H
      DOUBLE PRECISION RNT,Z
      INTEGER N,NCPRIN,NW1
      COMMON / DEF01  / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN
C
C  Common variables
C
      INTEGER ICCMIN(MXNC),NCMIN
      COMMON / DEF07  / NCMIN,ICCMIN
C
C  Common variables
C
      DOUBLE PRECISION BREENG(MXNC),COUENG(MXNC)
      COMMON / ENRG1  / COUENG,BREENG
C
C  Common variables
C
      DOUBLE PRECISION EAV,UCF(MXNW)
      COMMON / HMAT   / EAV,UCF
C
C  Common variables
C
      INTEGER IPUNCH,IREAD,IWRITE
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
C
C  Common variables
C
      DOUBLE PRECISION XSLDR(MXNM)
      INTEGER ISLDR(MXNM),NMCP
      COMMON / MCPA   / XSLDR,ISLDR,NMCP
C
C  Common variables
C
      INTEGER NNLDR(N18),NSLDF(N18)
      COMMON / MCPB   / NNLDR,NSLDF
C
C  Common variables
C
      INTEGER ITC(50)
      COMMON / OPT01  / ITC
C
C  Common variables
C
      integer jtc(20)
      common / opt02  / jtc
C
C  Common variables
C
      INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF
      INTEGER NP(MXNW),NW
      COMMON / ORB04  / NW,NCF,NP,NAK,IQ
C
C  Common variables
C
      INTEGER NKJ(MXNW),NKL(MXNW)
      COMMON / ORB05  / NKL,NKJ
C
C  Common variables
C
      INTEGER ISPAR(MXNC),ITJPO(MXNC)
      COMMON / ORB07  / ITJPO,ISPAR
C
C  Common variables
C
      INTEGER LEV(MXNC)
      COMMON / PAT1   / LEV
C
C  Common variables
C
      DOUBLE PRECISION CCR(N10),CHK(N10)
      COMMON / SEMI   / CHK,CCR
C
C  Common variables
C
      double precision tmpvec(mxnc,mxnc)
      double precision tmpeng(mxnc),ee,t
      integer itmp(mxnc),jtmp(mxnc),ncf0,nsym
      common /nrbtmp/ tmpvec,tmpeng,ee,t
     x               ,itmp,jtmp,ncf0,nsym
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C
C-----------------------------------------------------------------------
C
C  Zeroise the array containing the Hamiltonian.
C
C-----------------------------------------------------------------------
      DO ITR = 1,NCF
        DO JTR = 1,NCF
          COUVEC(ITR,JTR) = ZERO
        ENDDO
      ENDDO
c
      if(jtc(13).eq.0)return
c
      WRITE (IWRITE,3000)
C
C-----------------------------------------------------------------------
C
C  I integrals
C
C-----------------------------------------------------------------------
      DO JA = 1,NW
        WA = RINTI(JA,JA)
        DO ITR = 1,NCF
          WB = IQ(JA,ITR)
          COUVEC(ITR,ITR) = COUVEC(ITR,ITR)+WA*WB
        ENDDO
      ENDDO
C-----------------------------------------------------------------------
C
C  F integrals
C
C-----------------------------------------------------------------------
      DO JA = 1,NW
        KA = NAK(JA)
        IFA = NKJ(JA)+1
        DO JB = JA,NW
          IFB = NKJ(JB)+1
C
C  Determine bounds in sum over K
C
          KMX = IFA
          IF (IFA.GT.IFB) KMX = IFB
          DO L = 1,KMX,2
            K = L-1
C
C  Determine the angular coefficient.
C
            ICOEF = 0
            IMARK = 0
            DO ITR = 1,NCF
              WB = ZERO
              IQA = IQ(JA,ITR)
              IQB = IQ(JB,ITR)
              IF (IQA.EQ.0 .OR. IQB.EQ.0) GOTO 10
C
C  If either orbital is in closed shell.
C
              IF (IQA.EQ.IFA .OR. IQB.EQ.IFB) THEN
                IF (JA.EQ.JB) THEN
                  IF (K.EQ.0) THEN
                    WB = HALF*IQA*(IQA-1)
                    IMARK = 1
                  ELSE
                    IF (ICOEF.EQ.0) THEN
                      COEF = CLRX(KA,K,KA)**2
                      ICOEF = 1
                    ENDIF
                    WB = -HALF*IQA*IQA*COEF
                    IMARK = 1
                  ENDIF
                ELSE
                  IF (K.EQ.0) THEN
                    WB = IQA*IQB
                    IMARK = 1
                  ENDIF
                ENDIF
C
C  If both are in open shells.
C
              ELSE
C
                IF (NMCP.GT.0) THEN
                  IRS = (ITR-1)*(NCF+NCF-ITR)/2+ITR
                  ILDN = NNLDR(IRS)
                  IF (ILDN.GT.0) THEN
                    ILDA = NSLDF(IRS)
                    ILDB = ILDA+ILDN-1
                    ILCX = (((K*NW1+JA)*NW1+JB)*NW1+JA)*NW1+JB
                    DO IL = ILDA,ILDB
                      IF (ILCX.EQ.ISLDR(IL)) THEN
                        WB = XSLDR(IL)
                        IMARK = 1
                        GOTO 10
                      ENDIF
                    ENDDO
                  ENDIF
                ENDIF
C
              ENDIF
C
   10         CONTINUE
              BREENG(ITR) = WB
            ENDDO
C
C  Add to diagonal elements.
C
            IF (IMARK.EQ.1) THEN
C
C  Evaluate Slater integral.
C
              WA = SLATER(JA,JB,JA,JB,K)
C
              DO ITR = 1,NCF
                COUVEC(ITR,ITR) = COUVEC(ITR,ITR)+BREENG(ITR)*WA
              ENDDO
C
            ENDIF
C
          ENDDO
        ENDDO
      ENDDO
C-----------------------------------------------------------------------
C
C  G integrals
C
C-----------------------------------------------------------------------
      IF (NW.EQ.1) GOTO 30
C
      NWM = NW-1
      DO JA = 1,NWM
        JM = JA+1
        KA = NAK(JA)
        IFA = NKJ(JA)+1
        DO JB = JM,NW
          KB = NAK(JB)
          IFB = NKJ(JB)+1
C
C  Determine bounds in sum over K
C
          LMN = ABS(IFA-IFB)/2+1
          LMX = (IFA+IFB)/2
          IF (KA*KB.LT.0) LMN = LMN + 1
          DO LM = LMN,LMX,2
            K = LM-1
C
C  Determine the angular coefficient.
C
            ICOEF = 0
            IMARK = 0
            DO ITR = 1,NCF
              WB = ZERO
              IQA = IQ(JA,ITR)
              IQB = IQ(JB,ITR)
              IF (IQA.EQ.0 .OR. IQB.EQ.0) GOTO 20
C
C  If either orbital is in closed shell.
C
              IF (IQA.EQ.IFA .OR. IQB.EQ.IFB) THEN
C
                IF (ICOEF.EQ.0) THEN
                  COEF = CLRX(KA,K,KB)**2
                  ICOEF = 1
                ENDIF
C
                WB = -IQA*IQB*COEF
                IMARK = 1
C
C  If both orbitals are in open shells.
C
              ELSE
C
                IF (NMCP.GT.0) THEN
                  IRS = (ITR-1)*(NCF+NCF-ITR)/2+ITR
                  ILDN = NNLDR(IRS)
                  IF (ILDN.GT.0) THEN
                    ILDA = NSLDF(IRS)
                    ILDB = ILDA+ILDN-1
                    ILCX = (((K*NW1+JA)*NW1+JB)*NW1+JB)*NW1+JA
                    DO IL = ILDA,ILDB
                      IF (ILCX.EQ.ISLDR(IL)) THEN
                        WB = XSLDR(IL)
                        IMARK = 1
                        GOTO 20
                      ENDIF
                    ENDDO
                  ENDIF
                ENDIF
C
              ENDIF
C
   20         CONTINUE
              BREENG(ITR) = WB
            ENDDO
C
C  Add contribution to diagonal element.
C
            IF (IMARK.EQ.1) THEN
C
C  Evaluate Slater integral
C
              WA = SLATER(JA,JB,JB,JA,K)
C
              DO ITR = 1,NCF
                COUVEC(ITR,ITR) = COUVEC(ITR,ITR)+BREENG(ITR)*WA
              ENDDO
C
            ENDIF
C
          ENDDO
        ENDDO
      ENDDO
C-----------------------------------------------------------------------
C
C  R integrals
C
C-----------------------------------------------------------------------
   30 CONTINUE
      IF (NMCP.GT.0) THEN
        IF (NCF.GT.1) THEN
C
C  Cycle over the off-diagonal elements
C
          NCFM = NCF-1
          DO ITR = 1,NCFM
            ITRP = ITR+1
C
            DO JTR = ITRP,NCF
              IRS = (ITR-1)*(NCF+NCF-ITR)/2+JTR
              ILDN = NNLDR(IRS)
C
              IF (ILDN.GT.0) THEN
                JA = NSLDF(IRS)
                JB = JA+ILDN-1
C
C  Extract corresponding entries from table
C
                DO JJ = JA,JB
                  WB = XSLDR(JJ)
C
C  Decode
C
                  ILCX = ISLDR(JJ)
                  KA = MOD(ILCX,NW1)
                  ILCX = ILCX/NW1
                  KB = MOD(ILCX,NW1)
                  ILCX = ILCX/NW1
                  KC = MOD(ILCX,NW1)
C
                  IF (KC.LE.0) THEN
                    WA = RINTI(KA,KB)
                  ELSE
                    ILCX = ILCX/NW1
                    KD = MOD(ILCX,NW1)
                    KK = ILCX/NW1
                    WA = SLATER(KD,KC,KB,KA,KK)
                  ENDIF
C
                  COUVEC(ITR,JTR) = COUVEC(ITR,JTR)+WA*WB
C
                ENDDO
C
              ENDIF
C
            ENDDO
          ENDDO
C
        ENDIF
C
      ENDIF
C-----------------------------------------------------------------------
C
C  ----- Hamiltonian evaluated -----
C
C  Print Hamiltonian matrix if option 5 is set
C
      IF (ITC(5).EQ.1) THEN
        WRITE (IWRITE,3020)
        CALL MATOUT(IWRITE,COUVEC,NCF,NCF,MXNC,MXNC,1)
      ENDIF
C-----------------------------------------------------------------------
C
C  Evaluate the average energy
C
      EAV = ZERO
C
      DO ITR = 1,NCF
        EAV = EAV+COUVEC(ITR,ITR)
      ENDDO
C
      EAV = EAV/NCF
C
      WRITE (IWRITE,3040) EAV
C
C  Subtract the average energy from the diagonal
C
      DO ITR = 1,NCF
        COUVEC(ITR,ITR) = COUVEC(ITR,ITR)-EAV
      ENDDO
C
C-----------------------------------------------------------------------
C
C  Diagonalise the Hamiltonian by Jp sub-block (nrb)
C
C-----------------------------------------------------------------------
c
      WRITE (IWRITE,3130)
c
c  Initialize
c
      nsym=0
      do itr=1,ncf
        itmp(itr)=0
      enddo
c
c  First, find a symmetry
c
  40  ncf0=0
      do itr=1,ncf
        if(itmp(itr).eq.0)then                       !we have a new one
          nsym=nsym+1
          do jtr=1,ncf                               !find all
            if(itjpo(itr).eq.itjpo(jtr).and.
     x         ispar(itr).eq.ispar(jtr))then
              ncf0=ncf0+1
              jtmp(ncf0)=jtr
              itmp(jtr)=nsym
            endif
          enddo
          go to 50                                   !go diagonalize
        endif
      enddo
c
      go to 60                                       !we are done
c        
  50  do j=1,ncf0                                    !transfer Jp block
        jtr=jtmp(j)
        do i=1,j
          itr=jtmp(i)
          tmpvec(i,j)=couvec(itr,jtr)
        enddo
      enddo
C
C  Use a LAPACK routine
C
      ij=itjpo(jtmp(1))-1
      ip=ispar(jtmp(1))
c
      write(iwrite,*)'Diagonalizing symmetry:',nsym,' 2J=',ij,' P=',ip
c
      CALL DSYEV ('V','U',ncf0,tmpvec,MXNC,tmpeng,WORK,LWORK,INFO)
c
      IF (INFO.NE.0) THEN
        WRITE (IWRITE,3010)
        STOP
      ENDIF
c
c  Transfer back
c
      do j=1,ncf0
        jtr=jtmp(j)
        breeng(jtr)=tmpeng(j)
        do i=1,ncf0
          itr=jtmp(i)
          couvec(itr,jtr)=tmpvec(i,j)
        enddo
      enddo
c
c  Go look for another symmetry
c
      go to 40
C-----------------------------------------------------------------------
C
C  Diagonalisation of the Hamiltonian complete
C
C-----------------------------------------------------------------------
c
c  Sort into ascending energy order
c
  60  do i=1,ncf
        k=i
        ee=breeng(k)
        do j=i+1,ncf
          if(breeng(j).lt.ee)then
            k=j
            ee=breeng(j)
          endif
        enddo
        if(k.ne.i)then
          breeng(k)=breeng(i)
          breeng(i)=ee
          do j=1,ncf
            t=couvec(j,i)
            couvec(j,i)=couvec(j,k)
            couvec(j,k)=t
          enddo
        endif
      enddo
C
C  Add back the average energy
C
      DO ITR = 1,NCF
        BREENG(ITR) = BREENG(ITR)+EAV
      ENDDO
C-----------------------------------------------------------------------
C
C  Eigenvector elements less than 1e-10 are set to zero.
C  Set up the array LEV where LEV(J) identifies the dominant CSF for
C  level J.
C  The largest mixing coefficient for each CSF is made positive
C
      DO J = 1,NCF
        IA = 0
        AMAX = ZERO
        DO I = 1,NCF
          WA = ABS(COUVEC(I,J))
          IF (WA.LT.EPS10) COUVEC(I,J) = ZERO
          IF (WA.GT.AMAX) THEN
            AMAX = WA
            IA = I
          ENDIF
        ENDDO
        LEV(J) = IA
        IF (COUVEC(IA,J).LT.ZERO) THEN
          DO I = 1,NCF
            COUVEC(I,J) = -COUVEC(I,J)
          ENDDO
        ENDIF
      ENDDO
C-----------------------------------------------------------------------
C
C  Print eigenvalues and eigenvectors if option 6 is set
C
      IF (ITC(6).EQ.1) THEN
C
        WRITE (IWRITE,3080)
C
        DO J = 1,NCPRIN
C
          EAU = BREENG(J)
          I = LEV(J)
          IJ = ITJPO(I)-1
          IP = ISPAR(I)
          AM = COUVEC(I,J)
C
          IF (MOD(IJ,2).EQ.0) THEN
            IJ = IJ/2
            IF (IP.EQ.1) THEN
              WRITE (IWRITE,3120) J,IJ,I,AM,EAU
            ELSE
              WRITE (IWRITE,3110) J,IJ,I,AM,EAU
            ENDIF
          ELSE
            IF (IP.EQ.1) THEN
              WRITE (IWRITE,3100) J,IJ,I,AM,EAU
            ELSE
              WRITE (IWRITE,3090) J,IJ,I,AM,EAU
            ENDIF
          ENDIF
C
        ENDDO
C
        CALL MATOUT(IWRITE,COUVEC,NCF,NCPRIN,MXNC,MXNC,3)
C
      ENDIF
C-----------------------------------------------------------------------
C
C  Average level
C
      IF (NCMIN.EQ.0) RETURN
C-----------------------------------------------------------------------
      IF (NCMIN.EQ.1) THEN
C
C  Optimal level
C
        II = ICCMIN(1)
        WRITE (IWRITE,3060) II,BREENG(II)
        DO I = 1,NCF
          COUENG(I) = COUVEC(I,II)
          CCR(I) = COUENG(I)
        ENDDO
C
      ELSE
C
C  Extended optimal level
C
        JJ = 1
        WRITE (IWRITE,3070)
        DO J = 1,NCMIN
          II = ICCMIN(J)
          WRITE (IWRITE,3050) II,BREENG(II)
          WRITE (IWRITE,3030) (COUVEC(I,II),I=1,NCF)
          DO I = 1,NCF
            CCR(JJ) = COUVEC(I,II)
            JJ = JJ+1
          ENDDO
        ENDDO
C
        FACTOR = ONE/NCMIN
        DO I = 1,NCF
          COUENG(I) = ZERO
          II = I
          DO JJ = 1,NCMIN
            COUENG(I) = COUENG(I)+CCR(II)*CCR(II)
            II = II+NCF
          ENDDO
          COUENG(I) = SQRT(FACTOR*COUENG(I))
        ENDDO
C
      ENDIF
C-----------------------------------------------------------------------
C
C  Evaluate generalised occupation numbers
C
      DO J = 1,NW
        UCF(J) = ZERO
        DO I = 1,NCF
          UCF(J) = UCF(J)+COUENG(I)*COUENG(I)*IQ(J,I)
        ENDDO
      ENDDO
C-----------------------------------------------------------------------
 3000 FORMAT (/
     +' >>>> routine MATRIX called: diagonalise the Coulomb matrix')
 3010 FORMAT (/' ERROR using the DSYEV routine'/' STOPPING')
 3020 FORMAT (/' estimated Hamiltonian matrix')
 3030 FORMAT (1X,1P,4E15.7)
 3040 FORMAT (/' average energy (a.u.) ',1P,E18.10/)
 3050 FORMAT (/' level ',I4,'  energy =',1P,E18.10/)
 3060 FORMAT (/' optimise on level ',I4,'  energy =',1P,E18.10)
 3070 FORMAT (/' optimise on the following levels'/)
 3080 FORMAT (/' eigenenergies'//'                    dominant'/        !
     +' level  J   parity  CSF   mix         a.u.'/)
 3090 FORMAT (1X,I4,2X,I4,'/2  odd    ',I4,2X,F5.3,3X,1P,E20.12)
 3100 FORMAT (1X,I4,2X,I4,'/2  even   ',I4,2X,F5.3,3X,1P,E20.12)
 3110 FORMAT (1X,I4,2X,I4,'    odd    ',I4,2X,F5.3,3X,1P,E20.12)
 3120 FORMAT (1X,I4,2X,I4,'    even   ',I4,2X,F5.3,3X,1P,E20.12)
 3130 FORMAT (/' diagonalisation using the DSYEV routine'/)
      END
C
C                             *******************
C
      SUBROUTINE MCDF(IR1,IR2,IP2,IR3,IP3)
C
C-----------------------------------------------------------------------
C
C   This subroutine begins the SCF problem with a call
C   to INIT and controls the MCDF iterations.
C
C   MCDF
C       DAMP
C       DUMP
C       INIT
C       MATRIX
C       NEWBAS
C       ORBPR
C       PROP
C       PRWF
C       SCF
C       YPOTX
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  Parameter variables
C
      INTEGER N10
      PARAMETER (N10=MXNX*MXNC)
C
C  Argument variables
C
      INTEGER IP2,IP3,IR1,IR2
      INTEGER IR3
C
C  Local variables
C
      DOUBLE PRECISION ACUSE
      INTEGER I,IC,J,M
      INTEGER MX,NCFTT,NIT
      LOGICAL HIACC
C
C  Common variables
C
      DOUBLE PRECISION HALF,ONE,TEN,TENTH
      DOUBLE PRECISION THREE,TWO,ZERO
      COMMON / CONS   / ZERO,HALF,TENTH,ONE,TWO,THREE,TEN
C
C  Common variables
C
      DOUBLE PRECISION ACCY,C,EPH,H
      DOUBLE PRECISION RNT,Z
      INTEGER N,NCPRIN,NW1
      COMMON / DEF01  / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN
C
C  Common variables
C
      DOUBLE PRECISION CHECK
      INTEGER NITIT
      COMMON / DEF04  / CHECK,NITIT
C
C  Common variables
C
      INTEGER ICCMIN(MXNC),NCMIN
      COMMON / DEF07  / NCMIN,ICCMIN
C
C  Common variables
C
      DOUBLE PRECISION BREENG(MXNC),COUENG(MXNC)
      COMMON / ENRG1  / COUENG,BREENG
C
C  Common variables
C
      DOUBLE PRECISION EAV,UCF(MXNW)
      COMMON / HMAT   / EAV,UCF
C
C  Common variables
C
      INTEGER IPUNCH,IREAD,IWRITE
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
C
C  Common variables
C
      INTEGER ITC(50)
      COMMON / OPT01  / ITC
C
C  Common variables
C
      INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF
      INTEGER NP(MXNW),NW
      COMMON / ORB04  / NW,NCF,NP,NAK,IQ
C
C  Common variables
C
      DOUBLE PRECISION CCR(N10),CHK(N10)
      COMMON / SEMI   / CHK,CCR
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
      NCFTT = NCF*NCMIN
C
      IF (NCMIN.GT.MXNX) THEN
        WRITE (IWRITE,3000) NCMIN,MXNX
        STOP
      ENDIF
C
      NIT = 1
C-----------------------------------------------------------------------
C
C  Initialise the SCF problem
C
      CALL INIT(IR1,IR2,IR3)
C-----------------------------------------------------------------------
C
C  Initial diagonalisation
C
      IF (NCMIN.GT.0 .OR. NITIT.EQ.0) THEN
        CALL MATRIX
        IF (NITIT.EQ.0) GOTO 30
        DO I = 1,NCFTT
          CHK(I) = CCR(I)
        ENDDO
      ENDIF
C
      WRITE (IWRITE,3040)
      WRITE (IWRITE,3030) (UCF(I),I=1,NW)
      WRITE (IWRITE,3050)
      WRITE (IWRITE,3030) (COUENG(I),I=1,NCF)
C-----------------------------------------------------------------------
C
C  Initial low accuracy runs
C
      HIACC = .FALSE.
      M = 3
C
      DO I = 1,M
        J = M+1-I
        ACUSE = ACCY*TEN**J
        IF (ACUSE.LT.1.D-6 .AND. ITC(43).EQ.0) HIACC=.TRUE.
        CALL DUMP(0,IP2)
        WRITE (IWRITE,3020)
        CALL SCF(ACUSE,MX,HIACC)
        WRITE (IWRITE,3020)
        IF (NCMIN.GT.0) THEN
          CALL MATRIX
          CALL DAMP(CHECK,IC)
        ENDIF
      ENDDO
C-----------------------------------------------------------------------
C
C  Iterate at final accuracy
C
   10 CONTINUE
      CALL DUMP(0,IP2)
C
      IF (ITC(43).EQ.1) THEN
        HIACC = .FALSE.
      ELSE
        HIACC = .TRUE.
      ENDIF
C-----------------------------------------------------------------------
      WRITE (IWRITE,3020)
      CALL SCF(ACCY,MX,HIACC)
      WRITE (IWRITE,3020)
C
      IF (NCMIN.EQ.0 .AND. MX.EQ.1) GOTO 20
C
      CALL MATRIX
C
      IF (NCMIN.EQ.0) GOTO 30
C
      CALL DAMP(CHECK,IC)
C
      IF (IC.EQ.0 .AND. MX.EQ.0) GOTO 30
C-----------------------------------------------------------------------
   20 CONTINUE
      NIT = NIT+1
      IF (NIT.GT.NITIT) THEN
        WRITE (IWRITE,3010)
        CALL DUMP(0,IP2)
        STOP
      ENDIF
      GOTO 10
C-----------------------------------------------------------------------
   30 CONTINUE
      CALL DUMP(1,IP2)
      WRITE (IWRITE,3020)
      CALL PROPG(0)
      CALL DUMP(2,IP2)
      CALL ORBPR(IR3,IP3)
C
C  If option 30 is set call NEWBAS to transform from JJ to
C  LS coupled basis
C
      IF (ITC(30).EQ.1) CALL NEWBAS
C
C  Call YPOTX to calculate and print the static potential
C
      CALL YPOTX
C
C  If option 8 is set print out the wavefunctions
C
      IF (ITC(8).EQ.1) THEN
        WRITE (IWRITE,3020)
        CALL PRWF(0)
      ENDIF
C
      WRITE (IWRITE,3060)
C-----------------------------------------------------------------------
 3000 FORMAT (/' dimension ERROR in routine MCDF ... STOPPING'/         !
     +' increase MXNX to at least ',I6,' from the present value of ',I6)
 3010 FORMAT (/' maximum iterations in MCDF exceeded')
 3020 FORMAT (/1X,71('-'))
 3030 FORMAT (1X,1P,5E14.6)
 3040 FORMAT (/' generalised orbital occupation numbers'/)
 3050 FORMAT (/' CSF mixing coefficients'/)
 3060 FORMAT (/1X,71('*'))
      END
C
C                             *******************
C
      SUBROUTINE MCP(IO1,IO2,IO3)
C
C-----------------------------------------------------------------------
C
C   The main routine of the package for evaluating angular coefficients.
C
C       MCP
C           MCT
C           RKCOG
C           SPEAKG
C           TMSOUT
C           TNSRJJ
C
C   Common block ANG04:
C     Elements set but never used: NWA
C   Common block DEBUG:
C     Elements used but never set: IBUG1 IBUG2 IBUG3 IBUG4 IBUG6
C   Common block INFORM:
C     Elements used but never set: IWRITE IPUNCH
C     Elements never used, never set: IREAD
C   Common block OPT02:
C     Elements used but never set: all
C   Common block ORB00:
C     Elements used but never set: all
C   Common block ORB04:
C     Elements used but never set: all
C   Common block ORB05:
C     Elements used but never set: all
C   Common block ORB06:
C     Elements used but never set: all
C   Common block ORB07:
C     Elements used but never set: all
C   Common block TITL:
C     Elements used but never set: all
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  Parameter variables
C
      DOUBLE PRECISION EPS10
      PARAMETER (EPS10=1.D-10)
      DOUBLE PRECISION ZERO
      PARAMETER (ZERO=0.D0)
      INTEGER IZ
      PARAMETER (IZ=0)
C
C  Argument variables
C
      INTEGER IO1,IO2,IO3
C
C  Local variables
C
      DOUBLE PRECISION COEF,VSHELL(MXNW)
      INTEGER I,IA1,IA2,ITOT1
      INTEGER ITOT2,ITOT3,ITOT4,ITOT5
      INTEGER ITOT6,ITOT7,ITOT8,ITOT9
      INTEGER ITOTAL,ITYPE,J,JTOTAL
      INTEGER K,KTOTAL,NOUT2
C
C  Common variables
C
      INTEGER IBREIT,ICOUL,IEXCH
      COMMON / ANG01  / ICOUL,IBREIT,IEXCH
C
C  Common variables
C
      INTEGER NOUT1
      COMMON / ANG02  / NOUT1
C
C  Common variables
C
      INTEGER ITOT(9),JTOT(9),KTOT(9)
      COMMON / ANG03  / ITOT,JTOT,KTOT
C
C  Common variables
C
      INTEGER IME,JA,JB,NWA
      COMMON / ANG04  / IME,JA,JB,NWA
C
C  Common variables
C
      INTEGER ICORE(MXNW)
      COMMON / ANG05  / ICORE
C
C  Common variables
C
      INTEGER IBUG1,IBUG2,IBUG3,IBUG4
      INTEGER IBUG5,IBUG6
      COMMON / DEBUG  / IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6
C
C  Common variables
C
      INTEGER IPUNCH,IREAD,IWRITE
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
C
C  Common variables
C
      INTEGER IOPAR,KA
      COMMON / MCTA   / KA,IOPAR
C
C  Common variables
C
      INTEGER JTC(20)
      COMMON / OPT02  / JTC
C
C  Common variables
C
      CHARACTER*2 NH(MXNW)
      COMMON / ORB00  / NH
C
C  Common variables
C
      INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF
      INTEGER NP(MXNW),NW
      COMMON / ORB04  / NW,NCF,NP,NAK,IQ
C
C  Common variables
C
      INTEGER NKJ(MXNW),NKL(MXNW)
      COMMON / ORB05  / NKL,NKJ
C
C  Common variables
C
      INTEGER ICHOP(MXNW,MXNC),IEXC
      INTEGER JCUP(10,MXNC),JQS(3,MXNW,MXNC)
      COMMON / ORB06  / JQS,JCUP,ICHOP,IEXC
C
C  Common variables
C
      INTEGER ISPAR(MXNC),ITJPO(MXNC)
      COMMON / ORB07  / ITJPO,ISPAR
C
C  Common variables
C
      CHARACTER*80 IHED
      CHARACTER*20 RECORD
      COMMON / TITL   / IHED,RECORD
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
      PRINT 3020,IHED(1:40),IHED(41:80),RECORD,NW,NCF
      WRITE (IWRITE,3020) IHED(1:40),IHED(41:80),RECORD,NW,NCF
      WRITE (IPUNCH,3020) IHED(1:40),IHED(41:80),RECORD,NW,NCF
C
      WRITE (IWRITE,3030)
      WRITE (IPUNCH,3030)
      WRITE (IWRITE,3040) IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6
      WRITE (IPUNCH,3040) IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6
C
C   Prints out table of allowed levels in jj coupling.
C
      IF (IBUG5.EQ.1) CALL TMSOUT
      IBUG5 = 0
C-----------------------------------------------------------------------
      IF (JTC(14).EQ.1) THEN
C
        IF (IO2.GT.0) THEN
          NOUT2 = 22
          WRITE (NOUT2) IHED,RECORD
          WRITE (NOUT2) NCF,NW
          WRITE (NOUT2) (NH(I),NP(I),NAK(I),NKL(I),NKJ(I),I=1,NW)
          WRITE (NOUT2) ((IQ(I,J),J=1,NCF),I=1,NW)
          WRITE (NOUT2) (ITJPO(J),J=1,NCF)
          WRITE (NOUT2) (ISPAR(J),J=1,NCF)
          WRITE (NOUT2) (((JQS(K,I,J),J=1,NCF),I=1,NW),K=1,3)
          WRITE (NOUT2) ((JCUP(I,J),J=1,NCF),I=1,8)
          WRITE (NOUT2) ((ICHOP(I,J),J=1,NCF),I=1,NW)
          WRITE (NOUT2) KA,IOPAR
        ELSE
          NOUT2 = 0
        ENDIF
C
        WRITE (IWRITE,3050) KA,IOPAR
        WRITE (IPUNCH,3050) KA,IOPAR
C
        CALL MCT(KA,IOPAR,NOUT2)
C
      ENDIF
C-----------------------------------------------------------------------
      IF (JTC(12).EQ.0 .AND. JTC(15).EQ.0) RETURN
C
      NWA = NW+1
C
      IEXCH = IEXC
C
      IF (JTC(12).EQ.1) THEN
        WRITE (IWRITE,3110)
        WRITE (IPUNCH,3110)
        ICOUL = 1
      ELSE
        ICOUL = 0
      ENDIF
C
      IF (JTC(15).EQ.1) THEN
        WRITE (IWRITE,3120)
        WRITE (IPUNCH,3120)
        IBREIT = 1
      ELSE
        IBREIT = 0
      ENDIF
C-----------------------------------------------------------------------
      IF (IO1.GT.0 .OR. IO3.GT.0) THEN
        NOUT1 = 21
        WRITE (NOUT1) IHED,RECORD
        WRITE (NOUT1) NCF,NW
        WRITE (NOUT1) (NH(I),NP(I),NAK(I),NKL(I),NKJ(I),I=1,NW)
        WRITE (NOUT1) ((IQ(I,J),J=1,NCF),I=1,NW)
        WRITE (NOUT1) (ITJPO(J),J=1,NCF)
        WRITE (NOUT1) (ISPAR(J),J=1,NCF)
        WRITE (NOUT1) (((JQS(K,I,J),J=1,NCF),I=1,NW),K=1,3)
        WRITE (NOUT1) ((JCUP(I,J),J=1,NCF),I=1,8)
        WRITE (NOUT1) ((ICHOP(I,J),J=1,NCF),I=1,NW)
      ELSE
        NOUT1 = 0
      ENDIF
C-----------------------------------------------------------------------
      IF (IEXCH.EQ.1) THEN
        WRITE (IWRITE,3070)
        WRITE (IPUNCH,3070)
      ELSE
        IF (IEXCH.EQ.-1) THEN
          WRITE (IWRITE,3080)
          WRITE (IPUNCH,3080)
        ENDIF
      ENDIF
C-----------------------------------------------------------------------
C
C  The array ICORE marks orbitals which are full in all
C  shells i.e. these are closed shells.
C  This is used to identify angular coefficients for diagonal
C  matrix elements involving only closed shells.
C  These occur for all diagonal matrix elements and are only
C  written once.
C
C      ICORE(I)=1 - shell I is closed
C      ICORE(I)=0 - shell I is open
C
C-----------------------------------------------------------------------
      DO I = 1,NW
        ICORE(I) = 0
        DO J = 1,NCF
          IF (ICHOP(I,J).EQ.0) GOTO 10
          IF (ICHOP(I,J).EQ.-1) GOTO 10
        ENDDO
        ICORE(I) = 1
   10   CONTINUE
      ENDDO
C-----------------------------------------------------------------------
      KA = 0
      IOPAR = 1
C-----------------------------------------------------------------------
C
C   JA and JB refer to the initial and final states in the list of
C   NCF configurations, respectively
C
C-----------------------------------------------------------------------
      IF (IBUG1.EQ.1) WRITE (IWRITE,3000)
C-----------------------------------------------------------------------
      DO I = 1,9
        ITOT(I) = 0
        JTOT(I) = 0
        KTOT(I) = 0
      ENDDO
C-----------------------------------------------------------------------
      DO JA = 1,NCF
        DO JB = JA,NCF
C
          IME = 0
          IF (NOUT1.GT.0) WRITE (NOUT1) JA,JB
C
C   Call MCP package
C
          CALL RKCOG(JA,JB)
C-----------------------------------------------------------------------
          IF (ICOUL.EQ.1) THEN
            IF (JA.EQ.JB) THEN
C
C   One-electron integrals for diagonal case
C
              DO I = 1,NW
                IF (ICORE(I).EQ.1) THEN
                  IF (JA.GT.1) GOTO 20
                  ITYPE = -7
                ELSE
                  ITYPE = 7
                ENDIF
                IF (IQ(I,JA).GT.0) THEN
                  COEF = IQ(I,JA)
                  CALL SPEAKG(1,ITYPE,IZ,IZ,I,I,IZ,COEF)
                ENDIF
   20           CONTINUE
              ENDDO
C
            ELSE
C
C   One-electron integrals for off-diagonal case
C
              CALL TNSRJJ(KA,IOPAR,JA,JB,IA1,IA2,VSHELL)
C
              IF (IA1.GT.0) THEN
                IF (IA1.EQ.IA2) THEN
                  DO IA1 = 1,NW
                    COEF = VSHELL(IA1)
                    IF (ABS(COEF).GE.EPS10) CALL SPEAKG(0,7,IZ,IZ,IA1,IA!
     +1,IZ,COEF)
                  ENDDO
                ELSE
                  COEF = VSHELL(1)
                  IF (ABS(COEF).GE.EPS10) CALL SPEAKG(0,7,IZ,IZ,IA1,IA2,!
     +IZ,COEF)
                ENDIF
              ENDIF
C
            ENDIF
C
          ENDIF
C
          IF (IME.GT.0 .AND. IBUG1.EQ.1) WRITE (IWRITE,3060) IME,JA,JB
          IF (NOUT1.GT.0) WRITE (NOUT1) IZ,IZ,ZERO
C
        ENDDO
      ENDDO
C-----------------------------------------------------------------------
      IF (ICOUL.EQ.1) THEN
        ITOT7 = ITOT(7)+JTOT(7)
        ITOT8 = ITOT(8)+JTOT(8)
        ITOT9 = ITOT(9)+JTOT(9)
        ITOTAL = ITOT(7)+ITOT(8)+ITOT(9)
        JTOTAL = JTOT(7)+JTOT(8)+JTOT(9)
        ITOTAL = ITOTAL+JTOTAL
        KTOTAL = KTOT(7)+KTOT(8)+KTOT(9)
        WRITE (IWRITE,3100) ITOT7,JTOT(7),KTOT(7),ITOT8,JTOT(8),KTOT(8),!
     +ITOT9,JTOT(9),KTOT(9),ITOTAL,JTOTAL,KTOTAL
        WRITE (IPUNCH,3100) ITOT7,JTOT(7),KTOT(7),ITOT8,JTOT(8),KTOT(8),!
     +ITOT9,JTOT(9),KTOT(9),ITOTAL,JTOTAL,KTOTAL
      ENDIF
C-----------------------------------------------------------------------
      IF (IBREIT.EQ.1) THEN
        ITOT1 = ITOT(1)+JTOT(1)
        ITOT2 = ITOT(2)+JTOT(2)
        ITOT3 = ITOT(3)+JTOT(3)
        ITOT4 = ITOT(4)+JTOT(4)
        ITOT5 = ITOT(5)+JTOT(5)
        ITOT6 = ITOT(6)+JTOT(6)
        ITOTAL = ITOT(1)+ITOT(2)+ITOT(3)+ITOT(4)+ITOT(5)+ITOT(6)
        JTOTAL = JTOT(1)+JTOT(2)+JTOT(3)+JTOT(4)+JTOT(5)+JTOT(6)
        ITOTAL = ITOTAL+JTOTAL
        WRITE (IWRITE,3090) ITOT1,JTOT(1),ITOT2,JTOT(2),ITOT3,JTOT(3),IT!
     +OT4,JTOT(4),ITOT5,JTOT(5),ITOT6,JTOT(6),ITOTAL,JTOTAL
        WRITE (IPUNCH,3090) ITOT1,JTOT(1),ITOT2,JTOT(2),ITOT3,JTOT(3),IT!
     +OT4,JTOT(4),ITOT5,JTOT(5),ITOT6,JTOT(6),ITOTAL,JTOTAL
      ENDIF
C
      WRITE (IWRITE,3010)
      WRITE (IPUNCH,3010)
C-----------------------------------------------------------------------
 3000 FORMAT (/4X,'R',3X,'S',4X,'A',4X,'B',4X,'C',4X,'D',4X,'K',4X,     !
     +'coefficient',8X,'ISTORE ITYPE'/)
 3010 FORMAT (/1X,71('*'))
 3020 FORMAT (/1X,71('*')/                                              !
     +' routine MCP: calculate MCP/MCBP/MCT angular coefficients'/1X,71(!
     +'*')/' Title  : ',A40/'          ',A40/' Run at : ',A20/          !
     +' NW  (number of orbitals) = ',I6/' NCF (number of CSFs)     = ',I!
     +6/1X,71('*'))
 3030 FORMAT (/                                                         !
     +' Core coefficients are common to all diagonal matrix elements. ',!
     +'They are '/                                                      !
     +' only written for the first CSF. These coefficients are indicat',!
     +'ed by '/                                                         !
     +' having ITYPE set negative where ITYPE is 1 to 6 for the Breit '/!
     +' interaction and 7 to 9 for the Coulomb. For the Coulomb intera',!
     +'ction '/                                                         !
     +' the core/core and core/peel coefficients are indicated by sett',!
     +'ing '/                                                           !
     +' ISTORE negative. These coefficients can be calculated internal',!
     +'ly by '/                                                         !
     +' the MCDF section and they are skipped there. However in BENA t',!
     +'hey are '/                                                       !
     +' used. The core coefficients (above) are a subset of these core',!
     +'/core and '/' core/peel coefficients.')
 3040 FORMAT (/' Debug options are : ',6I2)
 3050 FORMAT (/' Calculate MCT (one-electron) coefficients'/            !
     +' Rank of tensor is ',I2,' and parity is ',I2)
 3060 FORMAT (1X,I4,' coefficients between ',I2,' and ',I2)
 3070 FORMAT (' exchange Coulomb coefficients neglected')
 3080 FORMAT (' direct Coulomb coefficients neglected')
 3090 FORMAT (/1X,I6,' Breit type 1 coefficients    (',I6,' in core)'/1X!
     +,I6,' Breit type 2 coefficients    (',I6,' in core)'/1X,I6,       !
     +' Breit type 3 coefficients    (',I6,' in core)'/1X,I6,           !
     +' Breit type 4 coefficients    (',I6,' in core)'/1X,I6,           !
     +' Breit type 5 coefficients    (',I6,' in core)'/1X,I6,           !
     +' Breit type 6 coefficients    (',I6,' in core)'//1X,I6,          !
     +' total Breit coefficients     (',I6,' in core)')
 3100 FORMAT (/1X,I6,' one-electron coefficients    (',I6,' in core)'/7X!
     +,'                              (',I6,                            !
     +' in core/core or core/peel)'/1X,I6,                              !
     +' direct Slater coefficients   (',I6,' in core)'/7X,              !
     +'                              (',I6,' in core/core or core/peel)'!
     +/1X,I6,' exchange Slater coefficients (',I6,' in core)'/7X,       !
     +'                              (',I6,' in core/core or core/peel)'!
     +//1X,I6,' total Coulomb coefficients   (',I6,' in core)'/7X,      !
     +'                              (',I6,' in core/core or core/peel)'!
     +)
 3110 FORMAT (/' Calculate Coulomb coefficients')
 3120 FORMAT (/' Calculate Breit coefficients')
      END
C
C                             *******************
C
      SUBROUTINE MCPIN(IR1)
C
C-----------------------------------------------------------------------
C
C   This subroutine reads any MCP coefficients which are required
C   A print out is made if option 7 is set
C
C   No subroutines called.
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  Parameter variables
C
      INTEGER N18
      PARAMETER (N18=MXNC*(MXNC+1)/2)
C
C  Argument variables
C
      INTEGER IR1
C
C  Local variables
C
      DOUBLE PRECISION X
      INTEGER IA,IB,IC,ICX
      INTEGER ID,IK,IR,IRS
      INTEGER IRX,IS,ISTO,ISTORE
      INTEGER ISX,ITYPE,NCFS,NMREAD
      INTEGER NUMI,NUMR,NWS
C
C  Common variables
C
      DOUBLE PRECISION ACCY,C,EPH,H
      DOUBLE PRECISION RNT,Z
      INTEGER N,NCPRIN,NW1
      COMMON / DEF01  / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN
C
C  Common variables
C
      INTEGER IPUNCH,IREAD,IWRITE
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
C
C  Common variables
C
      DOUBLE PRECISION XSLDR(MXNM)
      INTEGER ISLDR(MXNM),NMCP
      COMMON / MCPA   / XSLDR,ISLDR,NMCP
C
C  Common variables
C
      INTEGER NNLDR(N18),NSLDF(N18)
      COMMON / MCPB   / NNLDR,NSLDF
C
C  Common variables
C
      INTEGER ITC(50)
      COMMON / OPT01  / ITC
C
C  Common variables
C
      CHARACTER*2 NH(MXNW)
      COMMON / ORB00  / NH
C
C  Common variables
C
      INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF
      INTEGER NP(MXNW),NW
      COMMON / ORB04  / NW,NCF,NP,NAK,IQ
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
C
C   If there is no MCP dump (IR1=0) then exit from routine
C
      NMCP = 0
C
      IF (IR1.EQ.0) RETURN
C
      WRITE (IWRITE,3010)
C-----------------------------------------------------------------------
C
C   Read the heading data which gives information on the type
C   of MCP calculation i.e. CSF data
C     ** check the number of orbitals and CSFs are the same **
C
      REWIND IR1
      READ (IR1)
      READ (IR1) NCFS,NWS
      IF (NW.NE.NWS .OR. NCF.NE.NCFS) GOTO 40
      READ (IR1)
      READ (IR1)
      READ (IR1)
      READ (IR1)
      READ (IR1)
      READ (IR1)
      READ (IR1)
C
      IF (ITC(7).EQ.1) WRITE (IWRITE,3020)
C-----------------------------------------------------------------------
C
C   Loop over pairs of configurations
C
      NMREAD = 0
      NUMI = 0
      NUMR = 0
      ICX = 1
C
      DO IRX = 1,NCF
        DO ISX = IRX,NCF
C
          READ (IR1) IR,IS
          IRS = (IR-1)*(NCF+NCF-IR)/2+IS
          NNLDR(IRS) = 0
C
   10     CONTINUE
          READ (IR1) ISTORE,ITYPE,X
          IF (ISTORE.EQ.0) GOTO 20
          NMREAD = NMREAD+1
          IF (ISTORE.LT.0) GOTO 10
          IF (ITYPE.LT.7) GOTO 10
C
          IF (ITYPE.EQ.7) THEN
            NUMI = NUMI+1
          ELSE
            NUMR = NUMR+1
          ENDIF
C-----------------------------------------------------------------------
C
C   Write out coefficients if option 7 is set.
C
          IF (ITC(7).EQ.1) THEN
            IF (ITYPE.EQ.8 .OR. ITYPE.EQ.9) THEN
              ISTO = ISTORE
              ID = MOD(ISTO,NW1)
              ISTO = ISTO/NW1
              IC = MOD(ISTO,NW1)
              ISTO = ISTO/NW1
              IB = MOD(ISTO,NW1)
              ISTO = ISTO/NW1
              IA = MOD(ISTO,NW1)
              IK = ISTO/NW1
              WRITE (IWRITE,3030) IR,IS,NP(IA),NH(IA),NP(IB),NH(IB),NP(I!
     +C),NH(IC),NP(ID),NH(ID),IK,X
            ELSE
              ISTO = ISTORE
              ID = MOD(ISTO,NW1)
              IC = ISTO/NW1
              WRITE (IWRITE,3050) IR,IS,NP(IC),NH(IC),NP(ID),NH(ID),X
            ENDIF
          ENDIF
C
          NMCP = NMCP+1
C
          IF (NMCP.LE.MXNM) THEN
            NNLDR(IRS) = NNLDR(IRS)+1
            ISLDR(NMCP) = ISTORE
            XSLDR(NMCP) = X
            GOTO 10
          ELSE
            GOTO 30
          ENDIF
C-----------------------------------------------------------------------
   20     CONTINUE
          NSLDF(IRS) = ICX
          ICX = ICX+NNLDR(IRS)
C
        ENDDO
      ENDDO
C-----------------------------------------------------------------------
      REWIND IR1
      WRITE (IWRITE,3040) NMREAD,NMCP,NUMR,NUMI
      PRINT 3040,NMREAD,NMCP,NUMR,NUMI
      RETURN
C-----------------------------------------------------------------------
C
C   error messages
C
   30 CONTINUE
      WRITE (IWRITE,3000)
      WRITE (IPUNCH,3000)
      PRINT 3000
      STOP
C
   40 CONTINUE
      WRITE (IWRITE,3060) NCFS,NWS,NCF,NW
      WRITE (IPUNCH,3060) NCFS,NWS,NCF,NW
      PRINT 3060,NCFS,NWS,NCF,NW
      STOP
C-----------------------------------------------------------------------
 3000 FORMAT (/                                                         !
     +' ERROR in MCPIN : dimension for MCP coefficients ... STOPPING')
 3010 FORMAT (/' >>>> routine MCPIN called : read angular coefficients')
 3020 FORMAT (/' MCP (Coulomb) angular coefficients'//4X,'R',3X,'S',31X,!
     +'K'/)
 3030 FORMAT (1X,2I4,4(3X,I2,A2),I4,3X,1P,E14.7)
 3040 FORMAT (/1X,I7,' angular coefficients read'/1X,I7,                !
     +' MCP (Coulomb) angular coefficients to be used in MCDF'/1X,I7,   !
     +' Slater coefficients'/1X,I5,' one-electron coefficients')
 3050 FORMAT (1X,2I4,14X,2(3X,I2,A2),7X,1P,E14.7)
 3060 FORMAT (/' ERROR in MCPIN : incorrect MCP dump ... STOPPING'/     !
     +' NCF,NW on dump are : ',2I5/' NCF,NW in run  are : ',2I5)
      END
C
C                             *******************
C
      SUBROUTINE MCT(KA,IOPAR,NOUT2)
C
C-----------------------------------------------------------------------
C
C   Main routine for evaluating MCT coefficients
C   using the one-electron tensor operator routine
C   TNSRJJ.
C
C   KA    - order of tensor
C   IOPAR - parity of tensor
C   NOUT2 - the stream number for output to disk/tape
C
C   Subroutines called: RAT1, TNSRJJ
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  Parameter variables
C
      DOUBLE PRECISION EPS10
      PARAMETER (EPS10=1.D-10)
      INTEGER IZ
      PARAMETER (IZ=0)
C
C  Argument variables
C
      INTEGER IOPAR,KA,NOUT2
C
C  Local variables
C
      DOUBLE PRECISION COEF,VSHELL(MXNW)
      INTEGER IA1,IA2,IMT,IRAT(4)
      INTEGER JA,JB,MODE,XA
      INTEGER XB,XC,XD
C
C  Common variables
C
      DOUBLE PRECISION HALF,ONE,TEN,TENTH
      DOUBLE PRECISION THREE,TWO,ZERO
      COMMON / CONS   / ZERO,HALF,TENTH,ONE,TWO,THREE,TEN
C
C  Common variables
C
      INTEGER IBUG1,IBUG2,IBUG3,IBUG4
      INTEGER IBUG5,IBUG6
      COMMON / DEBUG  / IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6
C
C  Common variables
C
      INTEGER IPUNCH,IREAD,IWRITE
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
C
C  Common variables
C
      CHARACTER*2 NH(MXNW)
      COMMON / ORB00  / NH
C
C  Common variables
C
      INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF
      INTEGER NP(MXNW),NW
      COMMON / ORB04  / NW,NCF,NP,NAK,IQ
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
C
C   JA and JB refer to the initial and final states in the list of
C   NCF configurations, respectively.
C
      IF (IBUG1.EQ.1) WRITE (IWRITE,3010)
C
      IMT = 0
C-----------------------------------------------------------------------
      DO JA = 1,NCF
        DO JB = JA,NCF
C
          CALL TNSRJJ(KA,IOPAR,JA,JB,IA1,IA2,VSHELL)
C-----------------------------------------------------------------------
          IF (IA1.GT.0) THEN
            IF (IA1.EQ.IA2) THEN
C
              DO IA1 = 1,NW
C
                COEF = VSHELL(IA1)
C
                IF (ABS(COEF).GE.EPS10) THEN
C
                  IF (NOUT2.GT.0) WRITE (NOUT2) JA,JB,IA1,IA1,COEF
C
                  IF (IBUG1.EQ.1) THEN
C
                    WRITE (IWRITE,3000) JA,JB,NP(IA1),NH(IA1),NP(IA1),NH!
     +(IA1),COEF
C
                    CALL RAT1(COEF,IRAT)
C
                    XA = IRAT(1)
                    XB = IRAT(2)
                    XC = IRAT(3)
                    XD = IRAT(4)
C
                    IF (XD.EQ.1) THEN
                      IF (XC.EQ.1) THEN
                        IF (XB.EQ.1) THEN
                          MODE = 1
                        ELSE
                          MODE = 2
                        ENDIF
                      ELSE
                        IF (XB.EQ.1) THEN
                          IF (XA.EQ.1) THEN
                            MODE = 7
                          ELSE
                            MODE = 3
                          ENDIF
                        ELSE
                          MODE = 5
                        ENDIF
                      ENDIF
                    ELSE
                      IF (XB.EQ.1) THEN
                        IF (XA.EQ.1) THEN
                          MODE = 8
                        ELSE
                          MODE = 6
                        ENDIF
                      ELSE
                        MODE = 4
                      ENDIF
                    ENDIF
C
                    IF (MODE.EQ.1) THEN
                      WRITE (IPUNCH,3030) KA,JA,JB,NP(IA1),NH(IA1),NP(IA!
     +1),NH(IA1),XA
                    ENDIF
C
                    IF (MODE.EQ.2) THEN
                      WRITE (IPUNCH,3040) KA,JA,JB,NP(IA1),NH(IA1),NP(IA!
     +1),NH(IA1),XA,XB
                    ENDIF
C
                    IF (MODE.EQ.3) THEN
                      WRITE (IPUNCH,3050) KA,JA,JB,NP(IA1),NH(IA1),NP(IA!
     +1),NH(IA1),XA,XC
                    ENDIF
C
                    IF (MODE.EQ.4) THEN
                      WRITE (IPUNCH,3060) KA,JA,JB,NP(IA1),NH(IA1),NP(IA!
     +1),NH(IA1),XA,XB,XC,XD
                    ENDIF
C
                    IF (MODE.EQ.5) THEN
                      WRITE (IPUNCH,3070) KA,JA,JB,NP(IA1),NH(IA1),NP(IA!
     +1),NH(IA1),XA,XB,XC
                    ENDIF
C
                    IF (MODE.EQ.6) THEN
                      WRITE (IPUNCH,3080) KA,JA,JB,NP(IA1),NH(IA1),NP(IA!
     +1),NH(IA1),XA,XC,XD
                    ENDIF
C
                    IF (MODE.EQ.7) THEN
                      WRITE (IPUNCH,3090) KA,JA,JB,NP(IA1),NH(IA1),NP(IA!
     +1),NH(IA1),XC
                    ENDIF
C
                    IF (MODE.EQ.8) THEN
                      WRITE (IPUNCH,3100) KA,JA,JB,NP(IA1),NH(IA1),NP(IA!
     +1),NH(IA1),XC,XD
                    ENDIF
C
                  ENDIF
C
                  IMT = IMT+1
                ENDIF
C
              ENDDO
C-----------------------------------------------------------------------
            ELSE
C-----------------------------------------------------------------------
              COEF = VSHELL(1)
C
              IF (ABS(COEF).GE.EPS10) THEN
C
                IF (NOUT2.GT.0) WRITE (NOUT2) JA,JB,IA1,IA2,COEF
C
                IF (IBUG1.EQ.1) THEN
C
                  WRITE (IWRITE,3000) JA,JB,NP(IA1),NH(IA1),NP(IA2),NH(I!
     +A2),COEF
C
                  CALL RAT1(COEF,IRAT)
C
                  XA = IRAT(1)
                  XB = IRAT(2)
                  XC = IRAT(3)
                  XD = IRAT(4)
C
                  IF (XD.EQ.1) THEN
                    IF (XC.EQ.1) THEN
                      IF (XB.EQ.1) THEN
                        MODE = 1
                      ELSE
                        MODE = 2
                      ENDIF
                    ELSE
                      IF (XB.EQ.1) THEN
                        IF (XA.EQ.1) THEN
                          MODE = 7
                        ELSE
                          MODE = 3
                        ENDIF
                      ELSE
                        MODE = 5
                      ENDIF
                    ENDIF
                  ELSE
                    IF (XB.EQ.1) THEN
                      IF (XA.EQ.1) THEN
                        MODE = 8
                      ELSE
                        MODE = 6
                      ENDIF
                    ELSE
                      MODE = 4
                    ENDIF
                  ENDIF
C
                  IF (MODE.EQ.1) THEN
                    WRITE (IPUNCH,3030) KA,JA,JB,NP(IA1),NH(IA1),NP(IA2)!
     +,NH(IA2),XA
                  ENDIF
C
                  IF (MODE.EQ.2) THEN
                    WRITE (IPUNCH,3040) KA,JA,JB,NP(IA1),NH(IA1),NP(IA2)!
     +,NH(IA2),XA,XB
                  ENDIF
C
                  IF (MODE.EQ.3) THEN
                    WRITE (IPUNCH,3050) KA,JA,JB,NP(IA1),NH(IA1),NP(IA2)!
     +,NH(IA2),XA,XC
                  ENDIF
C
                  IF (MODE.EQ.4) THEN
                    WRITE (IPUNCH,3060) KA,JA,JB,NP(IA1),NH(IA1),NP(IA2)!
     +,NH(IA2),XA,XB,XC,XD
                  ENDIF
C
                  IF (MODE.EQ.5) THEN
                    WRITE (IPUNCH,3070) KA,JA,JB,NP(IA1),NH(IA1),NP(IA2)!
     +,NH(IA2),XA,XB,XC
                  ENDIF
C
                  IF (MODE.EQ.6) THEN
                    WRITE (IPUNCH,3080) KA,JA,JB,NP(IA1),NH(IA1),NP(IA2)!
     +,NH(IA2),XA,XC,XD
                  ENDIF
C
                  IF (MODE.EQ.7) THEN
                    WRITE (IPUNCH,3090) KA,JA,JB,NP(IA1),NH(IA1),NP(IA2)!
     +,NH(IA2),XC
                  ENDIF
C
                  IF (MODE.EQ.8) THEN
                    WRITE (IPUNCH,3100) KA,JA,JB,NP(IA1),NH(IA1),NP(IA2)!
     +,NH(IA2),XC,XD
                  ENDIF
C
                ENDIF
C
                IMT = IMT+1
              ENDIF
C-----------------------------------------------------------------------
            ENDIF
          ENDIF
C-----------------------------------------------------------------------
        ENDDO
      ENDDO
C-----------------------------------------------------------------------
      WRITE (IWRITE,3020) IMT
      WRITE (IPUNCH,3020) IMT
C
      IF (NOUT2.GT.0) WRITE (NOUT2) IZ,IZ,IZ,IZ,ZERO
C-----------------------------------------------------------------------
 3000 FORMAT (7X,2I4,2X,2(I2,A2,1X),5X,1P,E16.9)
 3010 FORMAT (/10X,'R',3X,'S',4X,'A',4X,'B',9X,'coefficient'/)
 3020 FORMAT (/1X,I6,' MCT (one-electron) coefficients calculated')
 3030 FORMAT (1X,I2,2I4,' T(  ;',I2,A2,',',I2,A2,')',10X,'  ',I7)
 3040 FORMAT (1X,I2,2I4,' T(  ;',I2,A2,',',I2,A2,')',10X,'  ',I7,'/',I7)
 3050 FORMAT (1X,I2,2I4,' T(  ;',I2,A2,',',I2,A2,')',10X,'  ',I7,' ',7X,!
     +' * S (',I7,' ',7X,')')
 3060 FORMAT (1X,I2,2I4,' T(  ;',I2,A2,',',I2,A2,')',10X,'  ',I7,'/',I7,!
     +' * S (',I7,'/',I7,')')
 3070 FORMAT (1X,I2,2I4,' T(  ;',I2,A2,',',I2,A2,')',10X,'  ',I7,'/',I7,!
     +' * S (',I7,' ',7X,')')
 3080 FORMAT (1X,I2,2I4,' T(  ;',I2,A2,',',I2,A2,')',10X,'  ',I7,' ',7X,!
     +' * S (',I7,'/',I7,')')
 3090 FORMAT (1X,I2,2I4,' T(  ;',I2,A2,',',I2,A2,')',10X,'  ',7X,' ',7X,!
     +'   S (',I7,' ',7X,')')
 3100 FORMAT (1X,I2,2I4,' T(  ;',I2,A2,',',I2,A2,')',10X,'  ',7X,' ',7X,!
     +'   S (',I7,'/',I7,')')
      END
C
C                             *******************
C
      SUBROUTINE MCTIN(IO7)
C
C-----------------------------------------------------------------------
C
C  This routine reads the MCT coefficients from stream IO7
C  and loads them into the arrays XSLDR and ISLDR.
C
C  No subroutines called.
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  Parameter variables
C
      INTEGER N18
      PARAMETER (N18=MXNC*(MXNC+1)/2)
C
C  Argument variables
C
      INTEGER IO7
C
C  Local variables
C
      CHARACTER*80 IHEDIN
      CHARACTER*20 RECIN
      DOUBLE PRECISION COEFF
      INTEGER I,IA,IB,IC
      INTEGER IRS,IRSM,ITR,JTR
      INTEGER NCFIN,NWA,NWIN
C
C  Common variables
C
      INTEGER IPUNCH,IREAD,IWRITE
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
C
C  Common variables
C
      DOUBLE PRECISION XSLDR(MXNM)
      INTEGER ISLDR(MXNM),NMCP
      COMMON / MCPA   / XSLDR,ISLDR,NMCP
C
C  Common variables
C
      INTEGER NNLDR(N18),NSLDF(N18)
      COMMON / MCPB   / NNLDR,NSLDF
C
C  Common variables
C
      INTEGER IOPAR,KA
      COMMON / MCTA   / KA,IOPAR
C
C  Common variables
C
      INTEGER LTC(20)
      COMMON / OPT04  / LTC
C
C  Common variables
C
      CHARACTER*2 NH(MXNW)
      COMMON / ORB00  / NH
C
C  Common variables
C
      INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF
      INTEGER NP(MXNW),NW
      COMMON / ORB04  / NW,NCF,NP,NAK,IQ
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
C
C  Read basic information regarding tensor operator.
C
C-----------------------------------------------------------------------
      WRITE (IWRITE,3070)
      REWIND IO7
C
      READ (IO7) IHEDIN,RECIN
      READ (IO7) NCFIN,NWIN
      IF (NW.NE.NWIN .OR. NCF.NE.NCFIN) GOTO 30
      READ (IO7)
      READ (IO7)
      READ (IO7)
      READ (IO7)
      READ (IO7)
      READ (IO7)
      READ (IO7)
      READ (IO7) KA,IOPAR
      WRITE (IWRITE,3020) IHEDIN(1:40),IHEDIN(41:80),RECIN,KA,IOPAR
      IF (KA.EQ.0) GOTO 40
C
      NWA = NW+1
C
      IRSM = NCF*(NCF+1)/2
      DO I = 1,IRSM
        NNLDR(I) = 0
      ENDDO
C
C  Begin reading MCT coefficients.
C
      IF (LTC(5).EQ.1) WRITE (IWRITE,3060)
      NMCP = 0
   10 CONTINUE
      READ (IO7) ITR,JTR,IA,IB,COEFF
      IF (ITR.EQ.0) GOTO 20
      IF (LTC(5).EQ.1) WRITE (IWRITE,3040) ITR,JTR,NP(IA),NH(IA),NP(IB),!
     +NH(IB),COEFF
      NMCP = NMCP+1
      IF (NMCP.GT.MXNM) GOTO 50
      IRS = (ITR-1)*(NCF+NCF-ITR)/2+JTR
      NNLDR(IRS) = NNLDR(IRS)+1
      ISLDR(NMCP) = NWA*IA+IB
      XSLDR(NMCP) = COEFF
      GOTO 10
C
C  Store start and number of coefficients read for each configuration.
C
   20 CONTINUE
      IC = 1
      DO I = 1,IRSM
        NSLDF(I) = IC
        IC = IC+NNLDR(I)
      ENDDO
C
      WRITE (IWRITE,3050) NMCP
      RETURN
C
C  error messages
C
   30 CONTINUE
      WRITE (IWRITE,3000)
      STOP
C
   40 CONTINUE
      WRITE (IWRITE,3010)
      STOP
C
   50 CONTINUE
      WRITE (IWRITE,3030)
      STOP
C
 3000 FORMAT (/' ERROR in MCTIN : inconsistent MCT dump ... STOPPING')
 3010 FORMAT (/' ERROR in MCTIN : tensor rank is zero ... STOPPING')
 3020 FORMAT (/' MCT dump : ',A40/'            ',A40/'            ',A20/!
     +' tensor rank ',I2,'and parity ',I2/)
 3030 FORMAT (/                                                         !
     +' ERROR in MCTIN : dimension for MCT coefficients ... STOPPING')
 3040 FORMAT (2X,I4,2X,I4,2X,I2,A2,2X,I2,A2,2X,1P,E15.8)
 3050 FORMAT (/1X,I6,' MCT (one-electron) coefficients read')
 3060 FORMAT (/'    I    J   A     B      coefficient'/)
 3070 FORMAT (/                                                         !
     +' >>>> routine MCTIN called : read the one-electron coefficients')
      END
C
C                             *******************
C
      SUBROUTINE MODJ23
C
C-----------------------------------------------------------------------
C
C  Restores common block /ANG00/ from saved values.
C  For exchange case.
C
C  No subroutines called.
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
C
C  Parameter variables
C
      INTEGER MANGM
      PARAMETER (MANGM=60)
      INTEGER MTRIAD
      PARAMETER (MTRIAD=20)
C
C  Local variables
C
      INTEGER I,J,NS2
C
C  Common variables
C
      INTEGER J1(MANGM),J2(MTRIAD,3)
      INTEGER J3(MTRIAD,3),MMOM,NMOM
      LOGICAL FREE(MANGM)
      COMMON / ANG00  / MMOM,NMOM,J1,J2,J3,FREE
C
C  Common variables
C
      INTEGER J2S(MTRIAD,3),J3S(MTRIAD,3)
      COMMON / ANG09  / J2S,J3S
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
      NS2 = NMOM-1
      DO J = 1,3
        DO I = 1,NS2
          J2(I,J) = J2S(I,J)
          J3(I,J) = J3S(I,J)
        ENDDO
      ENDDO
C
      I = J3(1,3)
      J3(1,3) = J2(1,1)
      J2(1,1) = I
C
      END
C
C                             *******************
C
      SUBROUTINE MUMDAD(IS,KAPS,X)
C
C-----------------------------------------------------------------------
C
C  Evaluate the product of 4 CFPs.
C
C  Subroutines called:  CFP
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  Parameter variables
C
      DOUBLE PRECISION EPS10
      PARAMETER (EPS10=1.D-10)
      DOUBLE PRECISION ZERO
      PARAMETER (ZERO=0.D0)
      DOUBLE PRECISION ONE
      PARAMETER (ONE=1.D0)
C
C  Argument variables
C
      DOUBLE PRECISION X
      INTEGER IS(2,2),KAPS(2,2)
C
C  Local variables
C
      DOUBLE PRECISION C
      INTEGER II,IJD,IJP,IVD
      INTEGER IVP,IWD,IWP,LOCK
      INTEGER NEL
C
C  Common variables
C
      INTEGER JBQ1(3,MXNW),JBQ2(3,MXNW)
      INTEGER JTQ1(3),JTQ2(3)
      COMMON / ANG08  / JBQ1,JBQ2,JTQ1,JTQ2
C
C  Common variables
C
      INTEGER NQ1(MXNW),NQ2(MXNW)
      COMMON / ANG11  / NQ1,NQ2
C
C  Common variables
C
      INTEGER JJQ1(3,MXNW),JJQ2(3,MXNW)
      COMMON / ANG12  / JJQ1,JJQ2
C
C  Common variables
C
      INTEGER IBUG1,IBUG2,IBUG3,IBUG4
      INTEGER IBUG5,IBUG6
      COMMON / DEBUG  / IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6
C
C  Common variables
C
      INTEGER IPUNCH,IREAD,IWRITE
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
      X = ONE
C-----------------------------------------------------------------------
C
C   First index
C
C-----------------------------------------------------------------------
      LOCK = KAPS(1,1)
      IF (ABS(LOCK).EQ.2) GOTO 10
C
      II = IS(1,1)
      NEL = NQ1(II)
      IVP = JBQ1(1,II)
      IWP = JBQ1(2,II)
      IJP = JBQ1(3,II)-1
C
      IF (IS(1,1).NE.IS(2,1)) THEN
C
C  IA1<>IB1 and IA2<>IB2; use JJQ array.
C
        IVD = JJQ1(1,II)
        IWD = JJQ1(2,II)
        IJD = JJQ1(3,II)-1
C
      ELSE
C
C  IA1=IB1 or IA2=IB2; JTQ array needed.
C
        NEL = NEL-1
        IVD = JTQ1(1)
        IWD = JTQ1(2)
        IJD = JTQ1(3)-1
      ENDIF
C
      CALL CFP(LOCK,NEL,IJD,IVD,IWD,IJP,IVP,IWP,C)
      IF (IBUG2.EQ.1) WRITE (IWRITE,3000) LOCK,NEL,IJD,IVD,IWD,IJP,IVP,I!
     +WP,C
      IF (ABS(C).LT.EPS10) GOTO 50
      X = X*C
C-----------------------------------------------------------------------
   10 CONTINUE
      LOCK = KAPS(2,1)
      IF (ABS(LOCK).EQ.2) GOTO 20
      II = IS(2,1)
      NEL = NQ1(II)
      IVD = JJQ1(1,II)
      IWD = JJQ1(2,II)
      IJD = JJQ1(3,II)-1
C
      IF (IS(1,1).NE.IS(2,1)) THEN
        IVP = JBQ1(1,II)
        IWP = JBQ1(2,II)
        IJP = JBQ1(3,II)-1
      ELSE
        IVP = JTQ1(1)
        IWP = JTQ1(2)
        IJP = JTQ1(3)-1
      ENDIF
C
      CALL CFP(LOCK,NEL,IJD,IVD,IWD,IJP,IVP,IWP,C)
      IF (IBUG2.EQ.1) WRITE (IWRITE,3000) LOCK,NEL,IJD,IVD,IWD,IJP,IVP,I!
     +WP,C
      IF (ABS(C).LT.EPS10) GOTO 50
      X = X*C
C-----------------------------------------------------------------------
C
C   Second index
C
C-----------------------------------------------------------------------
   20 CONTINUE
      LOCK = KAPS(1,2)
      IF (ABS(LOCK).EQ.2) GOTO 30
      II = IS(1,2)
      NEL = NQ2(II)
      IVP = JBQ2(1,II)
      IWP = JBQ2(2,II)
      IJP = JBQ2(3,II)-1
C
      IF (IS(1,2).NE.IS(2,2)) THEN
C
C  IA1<>IB1 and IA2<>IB2; use JJQ array.
C
        IVD = JJQ2(1,II)
        IWD = JJQ2(2,II)
        IJD = JJQ2(3,II)-1
C
      ELSE
C
C  IA1=IB1 or IA2=IB2; JTQ array needed.
C
        NEL = NEL-1
        IVD = JTQ2(1)
        IWD = JTQ2(2)
        IJD = JTQ2(3)-1
      ENDIF
C
      CALL CFP(LOCK,NEL,IJD,IVD,IWD,IJP,IVP,IWP,C)
      IF (IBUG2.EQ.1) WRITE (IWRITE,3000) LOCK,NEL,IJD,IVD,IWD,IJP,IVP,I!
     +WP,C
      IF (ABS(C).LT.EPS10) GOTO 50
      X = X*C
C-----------------------------------------------------------------------
   30 CONTINUE
      LOCK = KAPS(2,2)
      IF (ABS(LOCK).EQ.2) GOTO 40
      II = IS(2,2)
      NEL = NQ2(II)
      IVD = JJQ2(1,II)
      IWD = JJQ2(2,II)
      IJD = JJQ2(3,II)-1
C
      IF (IS(1,2).NE.IS(2,2)) THEN
        IVP = JBQ2(1,II)
        IWP = JBQ2(2,II)
        IJP = JBQ2(3,II)-1
      ELSE
        IVP = JTQ2(1)
        IWP = JTQ2(2)
        IJP = JTQ2(3)-1
      ENDIF
C
      CALL CFP(LOCK,NEL,IJD,IVD,IWD,IJP,IVP,IWP,C)
      IF (IBUG2.EQ.1) WRITE (IWRITE,3000) LOCK,NEL,IJD,IVD,IWD,IJP,IVP,I!
     +WP,C
      IF (ABS(C).LT.EPS10) GOTO 50
      X = X*C
   40 CONTINUE
      RETURN
C-----------------------------------------------------------------------
   50 CONTINUE
      X = ZERO
C-----------------------------------------------------------------------
 3000 FORMAT (' CFP  ',I4,I4,I7,2I4,I7,2I4,1P,E20.9)
      END
C
C                             *******************
C
      SUBROUTINE NCHARG
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
C
C  Common variables
C
      INTEGER IPUNCH,IREAD,IWRITE
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
      WRITE (IWRITE,3000)
      WRITE (IPUNCH,3000)
      STOP
C
 3000 FORMAT (/' Routine NCHARG called'/                                !
     +' This is a dummy routine called for NUCTYP > 2 OR < 0'/          !
     +' Code is STOPPING'/                                              !
     +' Please rewrite this routine or change the value of NUCTYP')
      END
C
C                             *******************
C
      SUBROUTINE NEWBAS
C
C-----------------------------------------------------------------------
C
C  Subroutine to transform eigenvectors from JJ to LS CSF basis.
C  Note : argument IW not used.
C
C  Subroutine called : MATOUT
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  Parameter variables
C
      DOUBLE PRECISION EPS10
      PARAMETER (EPS10=1.D-10)
      INTEGER N10
      PARAMETER (N10=MXNX*MXNC)
C
C  Local variables
C
      DOUBLE PRECISION AM,EAU,SUM,WA
      DOUBLE PRECISION WMAX1,WMAX2,WMAX3
      INTEGER I,IA,IB,IC
      INTEGER J,K,MEV(MXNC)
      INTEGER NEV(MXNC)
C
C  Common variables
C
      DOUBLE PRECISION COUVEC(MXNC,MXNC)
      COMMON / BRET1  / COUVEC
C
C  Common variables
C
      DOUBLE PRECISION HALF,ONE,TEN,TENTH
      DOUBLE PRECISION THREE,TWO,ZERO
      COMMON / CONS   / ZERO,HALF,TENTH,ONE,TWO,THREE,TEN
C
C  Common variables
C
      DOUBLE PRECISION ACCY,C,EPH,H
      DOUBLE PRECISION RNT,Z
      INTEGER N,NCPRIN,NW1
      COMMON / DEF01  / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN
C
C  Common variables
C
      DOUBLE PRECISION BREENG(MXNC),COUENG(MXNC)
      COMMON / ENRG1  / COUENG,BREENG
C
C  Common variables
C
      INTEGER IPUNCH,IREAD,IWRITE
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
C
C  Common variables
C
      DOUBLE PRECISION TC(MXNC,MXNC)
      COMMON / NRD00  / TC
C
C  Common variables
C
      INTEGER ITC(50)
      COMMON / OPT01  / ITC
C
C  Common variables
C
      INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF
      INTEGER NP(MXNW),NW
      COMMON / ORB04  / NW,NCF,NP,NAK,IQ
C
C  Common variables
C
      INTEGER LEV(MXNC)
      COMMON / PAT1   / LEV
C
C  Common variables
C
      CHARACTER*14 NRCSF(MXNC)
      COMMON / PATX   / NRCSF
C
C  Common variables
C
      DOUBLE PRECISION CCR(N10),CHK(N10)
      COMMON / SEMI   / CHK,CCR
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
      DO I = 1,NCF
        DO J = 1,NCF
          SUM = ZERO
          DO K = 1,NCF
            SUM = SUM+COUVEC(K,I)*TC(K,J)
          ENDDO
          IF (ABS(SUM).LT.EPS10) SUM = ZERO
          CHK(J) = SUM
        ENDDO
        DO J = 1,NCF
          COUVEC(J,I) = CHK(J)
        ENDDO
      ENDDO
C
C  Set up the array LEV
C
      DO J = 1,NCF
        IA = 0
        IB = 0
        IC = 0
        WMAX1 = ZERO
        WMAX2 = ZERO
        WMAX3 = ZERO
        DO I = 1,NCF
          WA = ABS(COUVEC(I,J))
          IF (WA.GE.WMAX1) THEN
            WMAX3 = WMAX2
            WMAX2 = WMAX1
            WMAX1 = WA
            IC = IB
            IB = IA
            IA = I
          ELSE
            IF (WA.GE.WMAX2) THEN
              WMAX3 = WMAX2
              WMAX2 = WA
              IC = IB
              IB = I
            ELSE
              IF (WA.GE.WMAX3) THEN
                WMAX3 = WA
                IC = I
              ENDIF
            ENDIF
          ENDIF
        ENDDO
        LEV(J) = IA
        MEV(J) = IB
        NEV(J) = IC
      ENDDO
C
C  Output the level energies
C
      WRITE (IWRITE,3000)
      WRITE (IWRITE,3010)
      WRITE (IPUNCH,3000)
      WRITE (IPUNCH,3010)
      DO J = 1,NCPRIN
        IA = LEV(J)
        AM = COUVEC(IA,J)
        IF (J.GT.1) THEN
          EAU = (BREENG(J)-BREENG(1))*TWO
        ELSE
          EAU = BREENG(J)*TWO
        ENDIF
        WRITE (IWRITE,3020) J,NRCSF(IA),IA,AM,EAU
        WRITE (IPUNCH,3020) J,NRCSF(IA),IA,AM,EAU
        IB = MEV(J)
        IF (IB.GT.0) THEN
          AM = COUVEC(IB,J)
          IF (ABS(AM).GT..4D0) THEN
            WRITE (IWRITE,3030) NRCSF(IB),IB,AM
            WRITE (IPUNCH,3030) NRCSF(IB),IB,AM
          ENDIF
        ENDIF
        IC = NEV(J)
        IF (IC.GT.0) THEN
          AM = COUVEC(IC,J)
          IF (ABS(AM).GT..4D0) THEN
            WRITE (IWRITE,3030) NRCSF(IC),IC,AM
            WRITE (IPUNCH,3030) NRCSF(IC),IC,AM
          ENDIF
        ENDIF
      ENDDO
C
      IF (ITC(31).EQ.1)CALL MATOUT(IWRITE,COUVEC,NCF,NCPRIN,MXNC,MXNC,3)
C
 3000 FORMAT (/' >>>> routine NEWBAS called'/                           !
     +' >>>> eigenvectors transformed from jj to LS CSF basis')
 3010 FORMAT (/                                                         !
     +' eigenenergies (absolute for groundstate, relative for others)'/ !
     +' -------------'/'                    dominant'/                  !
     +' level  state         CSF   mix         Ryd.'/)
 3020 FORMAT (1X,I4,2X,A14,2X,I4,2X,F6.3,2X,1P,4E20.12)
 3030 FORMAT (6X,A14,2X,I4,2X,F6.3)
      END
C
C                             *******************
C
      SUBROUTINE NJSYM(RECUP,IGEN,FAIL)
C
C-----------------------------------------------------------------------
C
C  This is an adaption of the revised NJSYM program due to Scott and
C  Hibbert. AAON CPC 28 (1982) 189
C
C  A program to calculate a general recoupling coefficient.
C  P.G.Burke -- modified by N.S.Scott and A.Hibbert
C  Queens University Belfast.
C
C-----------------------------------------------------------------------
C
C  RECUP the resultant recoupling coefficient
C
C  IGEN=0  normal call to NJSYM
C      =1  only GENSUM is called
C      =-1 GENSUM is not called
C
C-----------------------------------------------------------------------
C
C  Dimension parameters set in the program :
C
C  MANGM  test on dimension of J1 array (and J4, J5 arrays)
C  MTRIAD test on dimensions of J2 and J3 arrays
C  M3MNGM test on dimensions of J6 and J8 arrays
C  M3MNGM test on dimensions of J7 array
C  MTRIAD test on dimensions of JSUM1, JSUM2 etc arrays used in GENSUM
C  M6J    test on dimension of JW array
C
C  Renamed some common blocks :
C
C       COUPLE ---> ANG00
C       ARG0   ---> NJS00
C       ARG1   ---> NJS01
C       ARG2   ---> NJS02
C       DEPTHS ---> NJS03
C       WCOMI9 ---> NJS04
C
C  Description of common blocks
C  ============================
C
C  Common block ANG00
C  ------------------
C
C  M   the total number of angular momentum values in the initial and
C      final states
C
C  N   the number of basic angular momentum values that are coupled
C
C  (J1(I),I=1,M)
C  the angular momentum values stored as 2J+1
C
C  ((J2(I,J),I=1,(N-1)),J=1,3)
C  the position in the J1 array of the initial state triads
C
C  ((J3(I,J),I=1,(N-1)),J=1,3)
C  the position in the J1 array of the final state triads
C
C  FREE  not used
C
C  Common block DEBUG
C  ------------------
C
C  IBUG1  not used
C  IBUG2  not used
C  IBUG3  debug prints in NJSYM and GENSUM if IBUG3 equals 1
C  IBUG4  not used
C  IBUG5  not used
C  IBUG6  not used
C
C  Common block INFORM
C  -------------------
C
C  IREAD   input channel number
C  IWRITE  output channel number
C  IPUNCH  not used
C
C  Common block NJS00
C  ------------------
C
C  J6C   the number of elements in the J6 array
C
C  J7C   the number of elements in the J7 array
C
C  J8C   the number of elements in the J8 array
C
C  JWC   the number of columns in the JW array
C
C  Common block NJS01
C  ------------------
C
C  (J6(I),I=1,J6C)
C  each entry corresponds to a factor SQRT(2J+1) in RECUP. The
C  value of J6 gives position in J1 array where J value is found
C
C  (J7(I),I=1,J7C)
C  each entry corresponds to a factor (-1)**J in RECUP
C
C  (J8(I),I=1,J8C)
C  each entry corresponds to a factor (-1)**(-J) in RECUP
C
C  ((JW(I,J),I=1,6),J=1,JWC)
C  each column corresponds to a Racah coefficient in RECUP
C
C  Common block NJS02
C  ------------------
C
C  ICOUNT
C  (J2TEST(I),I=1,ICOUNT)
C  (J3TEST(I),I=1,ICOUNT)
C
C  Common block NJS03
C  ------------------
C
C  (J4(J),J=1,M)  the level of J in the J2 coupling tree evaluated
C                 by subroutine GENJ45
C
C  (J5(J),J=1,M)  the level of J in the J3 coupling tree evaluated
C                 by subroutine GENJ45
C
C  Common block NJS04
C  ------------------
C
C  I3  contains the column of the J2 array which contains the first
C      element to be brought into the same triad by recoupling. Input
C      to subroutine GENI9
C
C  I4  contains the column of the J2 array which contains the second
C      element to be brought into the same triad by recoupling. Input
C      to subroutine GENI9
C
C  I5  contains the row of the J2 array which contains the first
C      element. Input to subroutine GENI9
C
C  I6  contains the row of the J2 array which contains the second
C      element. Input to subroutine GENI9
C
C  I7  contains the level of the I5 triad below the common triad in
C      coupling scheme of J2, evaluated by subroutine GENI9
C
C  I8  contains the level of the I6 triad below the common triad in
C      coupling scheme of J2, evaluated by subroutine GENI9
C
C  I9  contains the number of recouplings plus two, evaluated by
C      subroutine GENI9
C
C  I17 contains the row of the J2 array containing the highest
C      element, evaluated by subroutine GENI9
C
C  I18 contains the row of the J2 array containing the lowest element,
C      evaluated by SUBROUTINE GENI9
C
C  I19 contains the column of the J2 array containing the highest
C      element, evaluated by subroutine GENI9
C
C  I20 contains the column of the J2 array containing the lowest
C      element, evaluated by subroutine GENI9
C
C-----------------------------------------------------------------------
C
C  The arrays J6,J7,J8 and JW are evaluated by NJSYM. The entry in
C  each case corresponds to a position in the J1 array where the
C  2J+1 value is found if less than or equal to M, or to a summation
C  variable if greater than M
C
C  The summation over the variables in J6,J7,J8 and JW and the
C  evaluation of RECUP is carried out in GENSUM
C
C  GENSUM can be re-entered directly to evaluate different recoupling
C  coefficients with the same structure by just altering the numbers in
C  the J1 array.
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C
      IMPLICIT NONE
C
C  Parameter variables
C
      INTEGER MANGM
      PARAMETER (MANGM=60)
      INTEGER MTRIAD
      PARAMETER (MTRIAD=20)
      INTEGER M3MNGM
      PARAMETER (M3MNGM=3*MANGM)
      INTEGER M6J
      PARAMETER (M6J=20)
C
C  Argument variables
C
      INTEGER IGEN
      DOUBLE PRECISION RECUP
      LOGICAL FAIL
C
C  Local variables
C
      INTEGER I,I1,I10,I11
      INTEGER I12,I13,I14,I15
      INTEGER I16,I2,IJKL,IP
      INTEGER IQ,ITEST,ITEST1,J
      INTEGER JJ2,JJ3,JP,MP
C
C  Common variables
C
      INTEGER J1(MANGM),J2(MTRIAD,3)
      INTEGER J3(MTRIAD,3),M,N
      LOGICAL FREE(MANGM)
      COMMON / ANG00  / M,N,J1,J2,J3,FREE
C
C  Common variables
C
      INTEGER IBUG1,IBUG2,IBUG3,IBUG4
      INTEGER IBUG5,IBUG6
      COMMON / DEBUG  / IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6
C
C  Common variables
C
      INTEGER IPUNCH,IREAD,IWRITE
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
C
C  Common variables
C
      INTEGER J6C,J7C,J8C,JWC
      COMMON / NJS00  / J6C,J7C,J8C,JWC
C
C  Common variables
C
      INTEGER J6(M3MNGM),J7(M3MNGM),J8(M3MNGM)
      INTEGER JW(6,M6J)
      COMMON / NJS01  / J6,J7,J8,JW
C
C  Common variables
C
      INTEGER ICOUNT,J2TEST(MTRIAD)
      INTEGER J3TEST(MTRIAD)
      COMMON / NJS02  / ICOUNT,J2TEST,J3TEST
C
C  Common variables
C
      INTEGER I17,I18,I19,I20
      INTEGER I3,I4,I5,I6
      INTEGER I7,I8,I9
      COMMON / NJS04  / I3,I4,I5,I6,I7,I8,I9,I17,I18,I19,I20
C
C  Common variables
C
      INTEGER NUMC,NUMR,NUMSTO
      COMMON / RACAHV / NUMC,NUMR,NUMSTO
C
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C
C  Common block ANG00:
C    Elements used but never set: M N J1
C    Elements never used, never set: FREE
C  
C  Common block DEBUG:
C    Elements used but never set: IBUG3
C    Elements never used, never set: IBUG1 IBUG2 IBUG4 IBUG5 IBUG6
C  
C  Common block INFORM:
C    Elements used but never set: IWRITE
C    Elements never used, never set: IREAD IPUNCH
C  
C  Common block NJS04:
C    Elements used but never set: I9 I17 I18 I19 I20
C  
C  Common block RACAHV:
C    Elements set but never used: all
C
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      SAVE IJKL
C
      DATA IJKL/0/
C-----------------------------------------------------------------------
C
C   Call the routine FACTT when NJSYM is first used
C
      IF (IJKL.EQ.0) THEN
        NUMC = 0
        NUMR = 0
        NUMSTO = 0
        CALL FACTT
        IJKL = 1
      ENDIF
C
      FAIL = .FALSE.
C-----------------------------------------------------------------------
      IF (IBUG3.EQ.1) THEN
        IF (IGEN.EQ.0) WRITE (IWRITE,3130)
        IF (IGEN.EQ.1) WRITE (IWRITE,3140)
        IF (IGEN.EQ.-1) WRITE (IWRITE,3150)
      ENDIF
C-----------------------------------------------------------------------
      IF (IGEN.EQ.1) GOTO 750
C-----------------------------------------------------------------------
C
C  test some of the dimensions
C
C-----------------------------------------------------------------------
      IF (MTRIAD.LT.N-1) GOTO 770
      IF (MANGM.LT.M) GOTO 780
C
C  IP is the number of inequivalent triads which have to be recoupled.
C  It is set initially to the total number of triads and then decreased
C  in section 1 below as the recoupling proceeds until eventually it
C  reaches zero.
C
      IP = N-1
C
C  debug prints
C
      IF (IBUG3.EQ.1) THEN
        WRITE (IWRITE,3020)
        DO I = 1,IP
          WRITE (IWRITE,3030) (J2(I,J),J=1,3), (J3(I,J),J=1,3)
        ENDDO
      ENDIF
C
C  Set counts zero. MP is count on the J values which are summed over.
C
      J6C = 0
      J7C = 0
      J8C = 0
      JWC = 0
      MP = M
      ICOUNT = 0
C-----------------------------------------------------------------------
C
C  Section 1
C
C  The following section searches the J2 and J3 arrays to see if any
C  triads are equivalent. If so it puts them at end of J2 and J3 arrays
C  and sets IP equal to the number of inequivalent triads remaining. If
C  IP=0 then the recouping has been completed and exit is made to GENSUM
C  to carry out the summations.
C
C-----------------------------------------------------------------------
  510 CONTINUE
      I1 = 1
  520 CONTINUE
      DO I2 = 1,IP
        IF (J2(I2,1).EQ.J3(I1,1)) GOTO 530
        IF (J2(I2,2).EQ.J3(I1,1)) GOTO 540
      ENDDO
C
C  No equivalent triads with this value of I1. Increase I1 and try again
C
      GOTO 580
C
  530 CONTINUE
      IF (J2(I2,2)-J3(I1,2)) 580,550,580
  540 CONTINUE
      IF (J2(I2,1)-J3(I1,2)) 580,550,580
  550 CONTINUE
C
C  Rearrange so that equivalent triads occur at the end of J2 and
C  J3 arrays
C
      IF (I2.LT.IP) THEN
        I3 = J2(I2,1)
        I4 = J2(I2,2)
        I5 = J2(I2,3)
        I6 = I2+1
        DO I7 = I6,IP
          DO I8 = 1,3
            J2(I7-1,I8) = J2(I7,I8)
          ENDDO
        ENDDO
        J2(IP,1) = I3
        J2(IP,2) = I4
        J2(IP,3) = I5
      ENDIF
C
      IF (I1.LT.IP) THEN
        I3 = J3(I1,1)
        I4 = J3(I1,2)
        I5 = J3(I1,3)
        I6 = I1+1
        DO I7 = I6,IP
          DO I8 = 1,3
            J3(I7-1,I8) = J3(I7,I8)
          ENDDO
        ENDDO
        J3(IP,1) = I3
        J3(IP,2) = I4
        J3(IP,3) = I5
      ENDIF
C
C  Is the third element in J2 summed over? If so replace by third
C  element in J3 array.
C
      IF (J2(IP,3).LE.M) GOTO 570
C
  560 CONTINUE
      J = J3(IP,3)
      JP = J2(IP,3)
      J2(IP,3) = J
C
C  Now replace all other elements in J2,JW,J7,J8 and J6 which are
C  summed over at the same time by the same quantity J
C
      IF (IP.GE.2) THEN
        IQ = IP-1
        DO I3 = 1,IQ
          DO I4 = 1,3
            IF (J2(I3,I4).EQ.JP) THEN
              J2(I3,I4) = J
            ENDIF
          ENDDO
        ENDDO
      ENDIF
C
      IF (JWC.GT.0) THEN
        DO I = 1,6
          DO I3 = 1,JWC
            IF (JW(I,I3).EQ.JP) THEN
              JW(I,I3) = J
            ENDIF
          ENDDO
        ENDDO
      ENDIF
C
      IF (J7C.GT.0) THEN
        DO I3 = 1,J7C
          IF (J7(I3).EQ.JP) THEN
            J7(I3) = J
          ENDIF
        ENDDO
      ENDIF
C
      IF (J8C.GT.0) THEN
        DO I3 = 1,J8C
          IF (J8(I3).EQ.JP) THEN
            J8(I3) = J
          ENDIF
        ENDDO
      ENDIF
C
      IF (J6C.GT.0) THEN
        DO I3 = 1,J6C
          IF (J6(I3).EQ.JP) THEN
            J6(I3) = J
          ENDIF
        ENDDO
      ENDIF
C
C  Set I1 back to 1 in order to start search for equivalent triads
C  again since some elements may have been altered
C
      I1 = 1
C
C  test whether triangle matches
C
  570 CONTINUE
      JJ2 = J2(IP,3)
      JJ3 = J3(IP,3)
C
C  Assume equivalent triad but store kronecker delta information
C  in arrays J2TEST and J3TEST.
C
      IF (JJ2.NE.JJ3) THEN
        ICOUNT = ICOUNT+1
        J2TEST(ICOUNT) = JJ2
        J3TEST(ICOUNT) = JJ3
        GOTO 560
      ENDIF
C
C  If J2 angular momenta are in opposite order to J3 angular
C  momenta interchange them and store sign changes in J7 and J8.
C  Check dimensions
C
      IF (J2(IP,1).NE.J3(IP,1)) THEN
C
        J = J2(IP,1)
        J2(IP,1) = J2(IP,2)
        J2(IP,2) = J
        J7(J7C+1) = J2(IP,1)
        J7(J7C+2) = J2(IP,2)
        J7C = J7C+2
        J8(J8C+1) = J2(IP,3)
        J8C = J8C+1
C
        IF (M3MNGM.LT.J7C) GOTO 800
        IF (M3MNGM.LT.J8C) GOTO 800
C
      ENDIF
C
C  Decrease IP and return to look for further equivalent triads
C
      IP = IP-1
      GOTO 590
C
  580 CONTINUE
      I1 = I1+1
C
  590 CONTINUE
      IF (I1.LE.IP) GOTO 520
C
C  If IP = 0 this means that all triads have been transformed to be
C  equivalent. Now exit to sum over Racah coefficients
C
      IF (IP.LE.0) GOTO 750
C-----------------------------------------------------------------------
C
C  Section 2
C
C  ITEST = 0
C  Determines the mimimum recoupling of J2 array to obtain an equivalent
C  triad to one in J3 array. Store row of J3 array in ITEST1.
C
C  ITEST = 1
C  Determine recoupling of J2 array to obtain an equivalent triad of
C  ITEST1 row of J3 array.
C
C  In both cases store information on recoupling
C
C-----------------------------------------------------------------------
      I10 = 9999
      ITEST = 0
      I1 = 1
C
C  GENJ45 determines the level of each J in the coupling tree of J2
C  and J3 and stores the result in the J4 and J5 arrays respectively
C
  600 CONTINUE
      CALL GENJ45(IP)
C
C  look for J in J2 array which is same as first element in J3 array
C
  610 CONTINUE
      DO I2 = 1,IP
        IF (J2(I2,1).EQ.J3(I1,1)) GOTO 620
        IF (J2(I2,2).EQ.J3(I1,1)) GOTO 630
      ENDDO
      GOTO 680
C
C  I3 and I5 denotes position in J2 array of common J
C
  620 CONTINUE
      I3 = 1
      GOTO 640
C
  630 CONTINUE
      I3 = 2
  640 CONTINUE
      I5 = I2
C
C  now look for J in J2 array which is same as other element in J3
C  array
C
      DO I2 = 1,IP
        IF (J2(I2,1).EQ.J3(I1,2)) GOTO 650
        IF (J2(I2,2).EQ.J3(I1,2)) GOTO 660
      ENDDO
      GOTO 680
C
C  I4 and I6 denotes position in J2 array of common J
C
  650 CONTINUE
      I4 = 1
      GOTO 670
C
  660 CONTINUE
      I4 = 2
  670 CONTINUE
      I6 = I2
C
C  I7 and I8 denote the position in the J1 array of the two common J
C  values in J2 and J3
C
      I7 = J2(I5,I3)
      I8 = J2(I6,I4)
C
C  GENI9 determines the number of recouplings of two elements of J2
C  necessary to obtain identical triads in J2 and J3 arrays. This
C  number plus two is stored in I9
C
      CALL GENI9(IP)
C
      IF (I9.GE.I10) GOTO 680
C
C  A smaller recoupling pair found. Store lowest as J2(I13,I14) and
C  highest as J2(I11,I12). I15 and I16 contain level of these below
C  common triads. Finally ITEST1 denotes triad in J3 for next entry
C  to section 2 and is required if more than one recoupling
C
      I10 = I9
      I11 = I17
      I12 = I19
      I13 = I18
      I14 = I20
      I15 = I7
      I16 = I8
      ITEST1 = I1
C
  680 CONTINUE
C
C  I1 is only increased if searching for smallest recoupling pair
C
      IF (ITEST.EQ.0) THEN
        I1 = I1+1
        IF (I1.LE.IP) GOTO 610
      ENDIF
C
      IF (I10.GE.9999) GOTO 760
C-----------------------------------------------------------------------
C
C  Section 3
C
C  The pair of J values that require the smallest number of recouplings
C  of J2 to bring into the same order as J3 has now been found. This
C  section now carries out one recoupling.
C
C-----------------------------------------------------------------------
C
C  I1 and I2 denotes the level above the given levels of the triad
C  of elements to be recoupled
C
      IF (I15.LT.I16) THEN
        I1 = I15-1
        I2 = I16-2
      ELSE
        I1 = I16-1
        I2 = I15-2
      ENDIF
C
      I3 = I11
      I4 = I13
      I5 = I12
      I6 = I14
C
C  Find first element to be recoupled
C
      IF (I1.GT.0) THEN
C
        DO I = 1,I1
C
          DO I7 = 1,IP
            IF (J2(I7,1).EQ.J2(I3,3)) GOTO 690
            IF (J2(I7,2).EQ.J2(I3,3)) GOTO 700
          ENDDO
C
  690     CONTINUE
          I5 = 1
          GOTO 710
  700     CONTINUE
          I5 = 2
C
  710     CONTINUE
          I3 = I7
C
        ENDDO
C
      ENDIF
C
C  First element to be recoupled is J2(I3,I5)
C  Now find second element to be recoupled
C
      IF (I2.GT.0) THEN
C
        DO I = 1,I2
C
          DO I7 = 1,IP
            IF (J2(I7,1).EQ.J2(I4,3)) GOTO 720
            IF (J2(I7,2).EQ.J2(I4,3)) GOTO 730
          ENDDO
C
  720     CONTINUE
          I6 = 1
          GOTO 740
  730     CONTINUE
          I6 = 2
C
  740     CONTINUE
          I4 = I7
C
        ENDDO
C
      ENDIF
C
C  Second element to be recoupled is J2(I4,I6)
C
C  Interchange elements of I4 row of J2 if necessary and include
C  signs in J7 and J8 arrays
C
      IF (I6.LE.1) THEN
        J7(J7C+1) = J2(I4,1)
        J7(J7C+2) = J2(I4,2)
        J7C = J7C+2
        J8(J8C+1) = J2(I4,3)
        J8C = J8C+1
        I = J2(I4,1)
        J2(I4,1) = J2(I4,2)
        J2(I4,2) = I
      ENDIF
C
C  Interchange elements of I3 row of J2 if necessary and store signs
C  in J7 and J8 arrays
C
      IF (I5.LE.1) THEN
        J7(J7C+1) = J2(I3,1)
        J7(J7C+2) = J2(I3,2)
        J7C = J7C+2
        J8(J8C+1) = J2(I3,3)
        J8C = J8C+1
        I = J2(I3,1)
        J2(I3,1) = J2(I3,2)
        J2(I3,2) = I
      ENDIF
C
C  Now recouple the two elements of J2 and store square roots in J6
C  and Racah coefficient in JW arrays. MP denotes a J which will be
C  summed over.
C
      J6(J6C+1) = J2(I4,3)
      MP = MP+1
      J6(J6C+2) = MP
      J6C = J6C+2
      JWC = JWC+1
      JW(1,JWC) = J2(I4,1)
      JW(2,JWC) = J2(I4,2)
      JW(3,JWC) = J2(I3,3)
      JW(4,JWC) = J2(I3,2)
      JW(5,JWC) = J2(I3,1)
      JW(6,JWC) = MP
      J2(I3,1) = J2(I4,1)
      J2(I4,1) = J2(I4,2)
      J2(I4,2) = J2(I3,2)
      J2(I4,3) = MP
      J2(I3,2) = MP
C
C  Test dimensions and exit if failure
C
      IF (M3MNGM.LT.J7C) GOTO 800
      IF (M3MNGM.LT.J8C) GOTO 800
      IF (MANGM.LT.MP) GOTO 800
      IF (M3MNGM.LT.J6C) GOTO 800
      IF (M6J.LT.JWC) GOTO 790
C
      IF (I1+I2.LE.0) GOTO 510
C
C  More than one recoupling required. Return to section 2 to decide
C  which elements of J2 to recouple in next step. If all recouplings
C  of a particular pair have been carried out then identical pairs
C  are now present in J2 and J3 arrays. Return to section 1 to see
C  if any more recoupling required.
C
      ITEST = 1
      I1 = ITEST1
      I10 = 9999
      GOTO 600
C
C  debug prints
C
  750 CONTINUE
      IF (IBUG3.EQ.1) THEN
C
        WRITE (IWRITE,3010) (J1(I),I=1,M)
        WRITE (IWRITE,3040)
C
        IF (JWC.GT.0) THEN
          DO J = 1,JWC
            WRITE (IWRITE,3050) (JW(I,J),I=1,6)
          ENDDO
        ELSE
          WRITE (IWRITE,3090)
        ENDIF
C
        IF (J6C.GT.0) THEN
          WRITE (IWRITE,3060) (J6(J),J=1,J6C)
        ELSE
          WRITE (IWRITE,3100)
        ENDIF
C
        IF (J7C.GT.0) THEN
          WRITE (IWRITE,3070) (J7(J),J=1,J7C)
        ELSE
          WRITE (IWRITE,3110)
        ENDIF
C
        IF (J8C.GT.0) THEN
          WRITE (IWRITE,3080) (J8(J),J=1,J8C)
        ELSE
          WRITE (IWRITE,3120)
        ENDIF
C
        IF (ICOUNT.GT.0) THEN
          WRITE (IWRITE,3160) (J2TEST(J),J=1,ICOUNT)
          WRITE (IWRITE,3170) (J3TEST(J),J=1,ICOUNT)
        ELSE
          WRITE (IWRITE,3180)
        ENDIF
C
      ENDIF
C-----------------------------------------------------------------------
C
C  carry out summations
C
C-----------------------------------------------------------------------
      IF (IGEN.EQ.-1) RETURN
      CALL GENSUM(J6C,J7C,J8C,JWC,J6,J7,J8,JW,ICOUNT,J2TEST,J3TEST,RECUP!
     +)
      RETURN
C-----------------------------------------------------------------------
C
C  fail because no pair in J2 and J3 found which could be recoupled
C
  760 CONTINUE
      WRITE (IWRITE,3000)
      STOP
C
C  fail due to dimensions
C
  770 CONTINUE
      WRITE (IWRITE,3190)
      STOP
  780 CONTINUE
      WRITE (IWRITE,3200)
      STOP
  790 CONTINUE
      WRITE (IWRITE,3210)
      STOP
  800 CONTINUE
      WRITE (IWRITE,3220)
      STOP
C-----------------------------------------------------------------------
 3000 FORMAT (' FAIL in NJSYM recoupling program')
 3010 FORMAT (/' J1=',10I5)
 3020 FORMAT (/' J2                  J3')
 3030 FORMAT (3I5,I10,2I5)
 3040 FORMAT (' JW')
 3050 FORMAT (6I5)
 3060 FORMAT (' J6=',15I3)
 3070 FORMAT (' J7=',15I3)
 3080 FORMAT (' J8=',15I3)
 3090 FORMAT (' no JW arrays set')
 3100 FORMAT (' no J6 arrays set')
 3110 FORMAT (' no J7 arrays set')
 3120 FORMAT (' no J8 arrays set')
 3130 FORMAT (/'  ** NJSYM called **  IGEN=0  normal')
 3140 FORMAT (/'  ** NJSYM called **  IGEN=1  only GENSUM called')
 3150 FORMAT (/'  ** NJSYM called **  IGEN=-1 GENSUM not called')
 3160 FORMAT (' J2TEST : ',20I3)
 3170 FORMAT (' J3TEST : ',20I3)
 3180 FORMAT (' no J2TEST,J3TEST arrays set')
 3190 FORMAT (' FAIL in NJSYM : MTRIAD dimension failure')
 3200 FORMAT (' FAIL in NJSYM : MANGM dimension failure')
 3210 FORMAT (' FAIL in NJSYM : M6J dimension failure')
 3220 FORMAT (' FAIL in NJSYM : M3MNGM dimension failure')
      END
C
C                             *******************
C
      SUBROUTINE NRCSF(NST,NFI,NJ)
C
C-----------------------------------------------------------------------
C
C  This subroutine sets up nonrelativistic CSF data : V,S and L values
C  for each subshell and coupled S and L values for the combination of
C  subshells that may arise, subject to the total S and L coupling to
C  give the appropriate J value. The coupled angular momentum values
C  are stored in the array LSV. Routines are called to set up the
C  possible V,S and L values for each subshell and to calculate the
C  transformation between JJ and LS coupled configurations.
C
C  Subroutines called : LSTERM,JCLIST,NJSYM,JJLS
C
C-----------------------------------------------------------------------
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      CHARACTER*2 NH
      LOGICAL FREE
      LOGICAL FAILN
C
      INCLUDE 'grasp0.inc'
      PARAMETER (MANGM=60)
      PARAMETER (MTRIAD=20)
C
      COMMON / ANG00  / MMOM,NMOM,J1(MANGM),J2(MTRIAD,3),J3(MTRIAD,3),  !
     +                  FREE(MANGM)
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
      COMMON / NRD01  / MLX(4),MQX(4),JPOS(4),NOPEN
      COMMON / NRD02  / NTERM(4),LSVT(5,16,4)
      COMMON / NRD06  / LSV(5,4,MXNC)
      COMMON / ORB00  / NH(MXNW)
      COMMON / ORB04  / NW,NCF,NP(MXNW),NAK(MXNW),IQ(MXNW,MXNC)
C
      DIMENSION INDEX(4)
C-----------------------------------------------------------------------
      CALL LSTERM
      CALL JCLIST(NST,NFI)
      NCFN = NST-1
      I1 = 0
C
C  Initialise arrays for NJSYM
C
      NPN = NOPEN
      IF (NPN.EQ.1) NPN = NPN + 1
      MMOM = 6*(NPN-1)
      NMOM = 2*NPN-1
C
      DO K = 1,3
        KK = 3*(K-1)
        DO L = 3,NMOM,2
          LL = 3*(L-2)
          J2(L-1,K) = LL+K
          LL = LL+KK
          DO J = 1,2
            J3(L-J,K) = LL-J
          ENDDO
          J2(L,K) = LL
        ENDDO
        J2(1,K) = K
        J3(NMOM,K) = MMOM+K
      ENDDO
C
      MMOM = MMOM+3
      NMOM = NMOM+1
      DO J = 1,MMOM
        J1(J) = 1
        FREE(J) = .TRUE.
      ENDDO
C
      CALL NJSYM (RECUP,-1,FAILN)
      J1(MMOM) = NJ
C
C  Loop thru terms for first unfilled subshell
C
   10 CONTINUE
      I1 = I1+1
      IF (I1.GT.NTERM(1)) GOTO 130
      INDEX(1) = I1
      NS1 = LSVT(2,I1,1)
      NL1 = LSVT(3,I1,1)
      LSVT(4,I1,1) = NS1
      LSVT(5,I1,1) = NL1
      J1(1) = NL1
      J1(2) = NS1
      NS = NS1
      NL = NL1
C
C  Branch here for one unfilled subshell.
C
      IF (NOPEN.EQ.1) GOTO 110
C
C  Loop thru terms for second unfilled subshell.
C
      I2 = 0
   20 CONTINUE
      I2 = I2+1
      IF (I2.GT.NTERM(2)) GOTO 10
      INDEX(2) = I2
      NS2 = LSVT(2,I2,2)
      NL2 = LSVT(3,I2,2)
      J1(4) = NL2
      J1(5) = NS2
      NSMIN1 = ABS(NS1-NS2)+1
      NLMIN1 = ABS(NL1-NL2)+1
      NSI = NS1+NS2+1
      NLMAX1 = NL1+NL2+1
C
C  Loop thru coupled S values.
C
   30 CONTINUE
      NSI = NSI-2
      IF (NSI.LT.NSMIN1) GOTO 20
      LSVT(4,I2,2) = NSI
      J1(8) = NSI
      NS = NSI
C
C  Loop thru coupled L values.
C
      NLI = NLMAX1
   40 CONTINUE
      NLI = NLI-2
      IF (NLI.LT.NLMIN1) GOTO 30
      LSVT(5,I2,2) = NLI
      J1(7) = NLI
      NL = NLI
C
C  Branch here for two unfilled subshells.
C
      IF (NOPEN.EQ.2) GOTO 110
C
C  Loop thru terms for third unfilled subshell.
C
      I3 = 0
   50 CONTINUE
      I3 = I3+1
      IF (I3.GT.NTERM(3)) GOTO 40
      INDEX(3) = I3
      NS3 = LSVT(2,I3,3)
      NL3 = LSVT(3,I3,3)
      J1(10) = NL3
      J1(11) = NS3
      NSMIN2 = ABS(NSI-NS3)+1
      NLMIN2 = ABS(NLI-NL3)+1
      NSJ = NSI+NS3+1
      NLMAX2 = NLI+NL3+1
C
C  Loop thru coupled S values.
C
   60 CONTINUE
      NSJ = NSJ-2
      IF (NSJ.LT.NSMIN2) GOTO 50
      LSVT(4,I3,3) = NSJ
      J1(14) = NSJ
      NS = NSJ
C
C  Loop thru coupled L values.
C
      NLJ = NLMAX2
   70 CONTINUE
      NLJ = NLJ-2
      IF (NLJ.LT.NLMIN2) GOTO 60
      LSVT(5,I3,3) = NLJ
      J1(13) = NLJ
      NL = NLJ
C
C  Branch here for three unfilled subshells.
C
      IF (NOPEN.EQ.3) GOTO 110
C
C  Loop thru terms for fourth unfilled subshell.
C
      I4 = 0
   80 CONTINUE
      I4 = I4+1
      IF (I4.GT.NTERM(4)) GOTO 70
      INDEX(4) = I4
      NS4 = LSVT(2,I4,4)
      NL4 = LSVT(3,I4,4)
      J1(16) = NL4
      J1(17) = NS4
      NSMIN3 = ABS(NSJ-NS4)+1
      NLMIN3 = ABS(NLJ-NL4)+1
      NS = NSJ+NS4+1
      NLMAX3 = NLJ+NL4+1
C
C  Loop thru coupled S values.
C
   90 CONTINUE
      NS = NS-2
      IF (NS.LT.NSMIN3) GOTO 80
      LSVT(4,I4,4) = NS
      J1(20) = NS
C
C  Loop thru coupled L values.
C
      NL = NLMAX3
  100 CONTINUE
      NL = NL-2
      IF (NL.LT.NLMIN3) GOTO 90
      LSVT(5,I4,4) = NL
      J1(19) = NL
  110 CONTINUE
      IF (NJ.GE.NL+NS .OR. NJ.LE.ABS(NL-NS)) GOTO 120
      NCFN = NCFN+1
      DO K = 1,NOPEN
        L = INDEX(K)
        DO I = 1,5
          LSV(I,K,NCFN) = LSVT(I,L,K)
        ENDDO
      ENDDO
C
      CALL JJLS(NST,NCFN,IFAIL,CHECK)
      IF (IFAIL.EQ.NCFN) GOTO 140
      IF (IFAIL.GT.0) GOTO 150
C
  120 CONTINUE
      GOTO (10,40,70,100),NOPEN
C
  130 CONTINUE
      IF (NCFN.EQ.NFI) RETURN
C
C   Error messages
C   ==============
C
      WRITE (IWRITE,3030) NCFN,NST,NFI
      WRITE (IWRITE,3000) NOPEN
      WRITE (IPUNCH,3030) NCFN,NST,NFI
      WRITE (IPUNCH,3000) NOPEN
      DO IJK = 1,NW
        WRITE (IWRITE,3010) NP(IJK),NH(IJK)
        WRITE (IWRITE,3020) (IQ(IJK,IJKL),IJKL=NST,NCF)
        WRITE (IPUNCH,3010) NP(IJK),NH(IJK)
        WRITE (IPUNCH,3020) (IQ(IJK,IJKL),IJKL=NST,NCF)
      ENDDO
      STOP
C
  140 CONTINUE
      WRITE (IWRITE,3040) NCFN,CHECK
      WRITE (IPUNCH,3040) NCFN,CHECK
      STOP
C
  150 CONTINUE
      WRITE (IWRITE,3050) NCFN,IFAIL,CHECK
      WRITE (IPUNCH,3050) NCFN,IFAIL,CHECK
      STOP
C
 3000 FORMAT (/'  NOPEN : ',I6)
 3010 FORMAT (/'  ORBITAL : ',I2,A2)
 3020 FORMAT (' IQ : ',15I4)
 3030 FORMAT (/' *** ERROR in NRCSF....STOPPING ***'/                   !
     +' Too many nonrelativistic configurations'/' NCFN,NST,NFI : ',3I6)
 3040 FORMAT (/' *** ERROR in NRCSF....STOPPING ***'/                   !
     +' ERROR in normalization of transformation vector for nonrel CSF '!
     +,I5/' Discrepancy is ',1P,E12.5)
 3050 FORMAT (/' *** ERROR in NRCSF....STOPPING ***'/                   !
     +' ERROR in orthogonality of transformation vectors for nonrel CS',!
     +'F ',I5,' and ',I5/' discrepancy is ',1P,E12.5)
      END
C
C                             *******************
C
      SUBROUTINE NROUT(NMAN,NWM,IOP,IWRITE)
C
C-----------------------------------------------------------------------
C
C  Print non-relativistic configuration data in a neat format.
C  Print transformation coefficients.
C  (each column corresponds to a non-relativistic configuration)
C
C    NMAN - number of non-relativistic CSFS
C    NWM  - number of non-relativistic orbitals
C    IOP  - control parameter
C           =0   return
C           =1   no printing but array NRCSF is set-up
C           =2,3 print non-relativistic CSFs
C           =3   print transformation coefficients
C    IWRITE  - lineprinter stream
C
C  Subroutines called : MATOUT
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  Argument variables
C
      INTEGER IOP,IWRITE,NMAN,NWM
C
C  Local variables
C
      CHARACTER IBL
      CHARACTER*4 IPAR(2),JLAB(20)
      CHARACTER*14 LABT
      CHARACTER LLAB(20),NL,NLCUP(MXNW)
      CHARACTER NLN(MXNW),NLSUB(MXNW)
      CHARACTER*2 NOCCP(MXNW),NUM(20)
      INTEGER I,J,J1,J2
      INTEGER K,LLR,LUP,MX
      INTEGER NCF,NCOR,NCORE,NFULL
      INTEGER NOC,NOPEN,NPN(MXNW),NS
      INTEGER NSCUP(MXNW),NSSUB(MXNW),NVSUB(MXNW),NX
      LOGICAL IPRT
C
C  Common variables
C
      DOUBLE PRECISION TC(MXNC,MXNC)
      COMMON / NRD00  / TC
C
C  Common variables
C
      INTEGER NLX(MXNW),NPX(MXNW),NQX(MXNW,MXNC)
      COMMON / NRD03  / NPX,NLX,NQX
C
C  Common variables
C
      INTEGER IPOS(MXNW),KPOS(4,MXNC)
      INTEGER NPOS(MXNC)
      COMMON / NRD04  / IPOS,NPOS,KPOS
C
C  Common variables
C
      INTEGER LSV(5,4,MXNC)
      COMMON / NRD06  / LSV
C
C  Common variables
C
      INTEGER ISPAR(MXNC),ITJPO(MXNC)
      COMMON / ORB07  / ITJPO,ISPAR
C
C  Common variables
C
      CHARACTER*14 NRCSF(MXNC)
      COMMON / PATX   / NRCSF
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      DATA IBL/' '/
      DATA IPAR/'even','odd '/
      DATA NUM/'0 ','1 ','2 ','3 ','4 ','5 ','6 ','7 ','8 ','9 ','10','1!
     +1','12','13','14','15','16','17','18','19'/
      DATA JLAB/'0   ','1/2 ','1   ','3/2 ','2   ','5/2 ','3   ','7/2 ',!
     +'4   ','9/2 ','5   ','11/2','6   ','13/2','7   ','15/2','8   ','17!
     +/2','9   ','19/2'/
      DATA LLAB/'S','P','D','F','G','H','I','K','L','M','N','O','Q','R',!
     +'T','U','V','W','X','Y'/
C-----------------------------------------------------------------------
      IF (IOP.EQ.0) RETURN
      IPRT = (IOP.EQ.2.OR.IOP.EQ.3)
C
      NCORE = 0
      NCF = NPOS(NMAN)
C
      LABT = NUM(2)//IBL//LLAB(1)//IBL//JLAB(1)//IBL//IPAR(1)
      DO I = 1,NCF
        NRCSF(I) = LABT
      ENDDO
C
      DO J = 1,NWM
        NFULL = NLX(J)*4+2
        DO I = 1,NMAN
          IF (NQX(J,I).NE.NFULL) GOTO 10
        ENDDO
        NCORE = NCORE+1
      ENDDO
C
   10 CONTINUE
      NCOR = NCORE+1
C
      IF (IPRT) WRITE (IWRITE,3000)
C
      IF (NCORE.EQ.0) THEN
        IF (IPRT) WRITE (IWRITE,3050)
      ELSE
        DO I = 1,NCORE
          NX = NQX(I,1)
          NOCCP(I) = NUM(NX+1)
          NX = NLX(I)+1
          NLN(I) = LLAB(NX)
        ENDDO
        IF (IPRT) THEN
          WRITE (IWRITE,3020)
          WRITE (IWRITE,3030) (NOCCP(I),I=1,NCORE)
          WRITE (IWRITE,3040) (NPX(I),NLN(I),I=1,NCORE)
        ENDIF
      ENDIF
C
      IF (NCORE.GE.NWM) THEN
        IF (IPRT) WRITE (IWRITE,3060)
      ELSE
        IF (IPRT) WRITE (IWRITE,3070)
        LLR = 1
        DO K = 1,NMAN
          NOC = 0
C
          LUP = NPOS(K)
          IF (LUP.LT.LLR) GOTO 30
C
          DO J = NCOR,NWM
            IF (NQX(J,K).GT.0) THEN
              NOC = NOC+1
              NX = NQX(J,K)
              NOCCP(NOC) = NUM(NX+1)
              NPN(NOC) = NPX(J)
              NX = NLX(J)+1
              NLN(NOC) = LLAB(NX)
            ENDIF
          ENDDO
C
          LUP = NPOS(K)
C
          DO I = LLR,LUP
            NL = LLAB(1)
            NS = 1
            NOPEN = 1
            NOC = 0
            DO J = NCOR,NWM
              IF (NQX(J,K).GT.0) THEN
                NOC = NOC+1
                IF (J.NE.KPOS(NOPEN,K)) THEN
                  NVSUB(NOC) = 0
                  NSSUB(NOC) = 1
                  NLSUB(NOC) = LLAB(1)
                ELSE
                  NVSUB(NOC) = LSV(1,NOPEN,I)
                  NSSUB(NOC) = LSV(2,NOPEN,I)
                  NX = (LSV(3,NOPEN,I)+1)/2
                  NLSUB(NOC) = LLAB(NX)
                  NS = LSV(4,NOPEN,I)
                  NX = (LSV(5,NOPEN,I)+1)/2
                  NL = LLAB(NX)
                  NOPEN = NOPEN+1
                ENDIF
                NSCUP(NOC) = NS
                NLCUP(NOC) = NL
              ENDIF
            ENDDO
C
            MX = ITJPO(I)
            IF (ISPAR(I).LT.0) THEN
              IF (IPRT) WRITE (IWRITE,3110) I,JLAB(MX)
              NRCSF(I) = NUM(NS+1)//IBL//NL//IBL//JLAB(MX)//IBL//IPAR(2)
            ELSE
              IF (IPRT) WRITE (IWRITE,3120) I,JLAB(MX)
              NRCSF(I) = NUM(NS+1)//IBL//NL//IBL//JLAB(MX)//IBL//IPAR(1)
            ENDIF
C
            J1 = 1
   20       CONTINUE
            J2 = NOC
            IF (J2.GT.J1+6) J2 = J1 + 6
            IF (IPRT) THEN
              WRITE (IWRITE,3080) (NOCCP(J),NSSUB(J),NSCUP(J),J=J1,J2)
              WRITE (IWRITE,3090) (NPN(J),NLN(J),NLSUB(J),NLCUP(J),J=J1,!
     +J2)
              WRITE (IWRITE,3100) (NVSUB(J),J=J1,J2)
            ENDIF
            J1 = J1+7
            IF (J2.LT.NOC) GOTO 20
C
          ENDDO
   30     CONTINUE
          LLR = LUP+1
        ENDDO
C
        IF (IOP.EQ.3) THEN
          WRITE (IWRITE,3130)
          CALL MATOUT(IWRITE,TC,NCF,NCF,MXNC,MXNC,4)
        ENDIF
C
      ENDIF
C
      WRITE (IWRITE,3010)
C-----------------------------------------------------------------------
 3000 FORMAT (/1X,71('*')/' routine NROUT: write out LS-coupled CSFs'/1X!
     +,71('*'))
 3010 FORMAT (/1X,71('*'))
 3020 FORMAT (/' The core common to all CSFs is : ')
 3030 FORMAT (/2X,10(3X,A2,1X))
 3040 FORMAT (2X,10(I2,A1,3X))
 3050 FORMAT (/' No core has been defined')
 3060 FORMAT (/' No valence orbitals have been defined')
 3070 FORMAT (/' CSFs are defined using format :    Q  S   S"'/         !
     +'                                  NL  ( L)   L"'/                !
     +'                                       V')
 3080 FORMAT (/1X,7(3X,A2,2X,I1,I4,4X))
 3090 FORMAT (1X,7(I2,A1,'   ( ',A1,')  ',A1,3X))
 3100 FORMAT (1X,7(I8,8X))
 3110 FORMAT (/' CSF ',I4,'  J = ',A4,' odd')
 3120 FORMAT (/' CSF ',I4,'  J = ',A4,' even')
 3130 FORMAT (/' Transformation coefficients'/)
      END
C
C                             *******************
C
      SUBROUTINE NUCPOT
C
C-----------------------------------------------------------------------
C
C  Evaluate the nuclear potential.
C
C  Routines called: NCHARG,YZK,QUAD
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  Parameter variables
C
      DOUBLE PRECISION CONNUC
      PARAMETER (CONNUC=2.2677D-5)
      INTEGER N11
      PARAMETER (N11=MXNP+10)
C
C  Local variables
C
      DOUBLE PRECISION ARG,ATM,DNORM,FAC
      DOUBLE PRECISION RAD,SKI,WA
      INTEGER I,NGRID,NOPTS,NOPTSP
C
C  Common variables
C
      DOUBLE PRECISION HALF,ONE,TEN,TENTH
      DOUBLE PRECISION THREE,TWO,ZERO
      COMMON / CONS   / ZERO,HALF,TENTH,ONE,TWO,THREE,TEN
C
C  Common variables
C
      DOUBLE PRECISION ACCY,C,EPH,H
      DOUBLE PRECISION RNT,Z
      INTEGER N,NCPRIN,NW1
      COMMON / DEF01  / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN
C
C  Common variables
C
      DOUBLE PRECISION RGRID(MXNP)
      COMMON / GRID   / RGRID
C
C  Common variables
C
      INTEGER IPUNCH,IREAD,IWRITE
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
C
C  Common variables
C
      INTEGER NBPAR,NCPAR,NMOTYP
      COMMON / MPAR1  / NMOTYP,NBPAR,NCPAR
C
C  Common variables
C
      DOUBLE PRECISION APAR,BBPAR(4),BPAR(4)
      DOUBLE PRECISION CCPAR(4),CPAR(4)
      COMMON / MPAR2  / APAR,BPAR,BBPAR,CPAR,CCPAR
C
C  Common variables
C
      DOUBLE PRECISION PARM(4),Z1
      INTEGER NPARM,NUCTYP
      COMMON / NPAR   / PARM,Z1,NUCTYP,NPARM
C
C  Common variables
C
      DOUBLE PRECISION ZZ(MXNP)
      COMMON / NPOT   / ZZ
C
C  Common variables
C
      INTEGER NPOTYP
      COMMON / PPAR1  / NPOTYP
C
C  Common variables
C
      DOUBLE PRECISION POLPAR(2)
      COMMON / PPAR2  / POLPAR
C
C  Common variables
C
      DOUBLE PRECISION TA(N11),TB(N11)
      COMMON / TATB   / TA,TB
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
      WRITE (IWRITE,3000)
C
C   Point nucleus
C
      IF (NUCTYP.EQ.0) THEN
        Z1 = ZERO
        DO I = 1,N
          ZZ(I) = Z
        ENDDO
        WRITE (IWRITE,3010)
        GOTO 30
      ENDIF
C-----------------------------------------------------------------------
C
C   Finite nucleus
C   uniform charge distribution
C
      IF (NUCTYP.EQ.1) THEN
        ATM = PARM(1)
        IF (ATM.LE.ZERO) GOTO 40
C
        RAD = CONNUC*ATM**(ONE/THREE)
        WA = RNT/RAD
        NOPTS = INT(ONE-LOG(WA)/H)
        WA = RAD*RAD
        FAC = Z/(TWO*RAD*WA)
        WA = WA*THREE
        Z1 = THREE*Z/(TWO*RAD)
        DO I = 1,NOPTS
          ZZ(I) = FAC*RGRID(I)*(WA-RGRID(I)*RGRID(I))
        ENDDO
        NOPTSP = NOPTS+1
        DO I = NOPTSP,N
          ZZ(I) = Z
        ENDDO
        WRITE (IWRITE,3030) ATM,RAD,NOPTS
        GOTO 30
C
      ENDIF
C-----------------------------------------------------------------------
C
C   Finite nucleus
C   Fermi two-parameter charge distribution
C
      IF (NUCTYP.EQ.2) THEN
        RAD = PARM(1)
        SKI = PARM(2)
        IF (RAD.LE.ZERO .OR. SKI.LE.ZERO) GOTO 40
C
        DO I = 1,N
          ARG = (RGRID(I)-RAD)/SKI
          IF (ARG.GT.80.D0) GOTO 10
          TA(I) = (RGRID(I)*RGRID(I))/(ONE+EXP(ARG))
        ENDDO
        NGRID = N
        GOTO 20
C
   10   CONTINUE
        NGRID = I-1
        IF (MOD(NGRID,2).EQ.0) THEN
          NGRID = NGRID+1
          TA(NGRID) = ZERO
        ENDIF
C
   20   CONTINUE
        CALL QUAD(NGRID,Z1)
C
        DO I = 1,NGRID
          TA(I) = TA(I)*RGRID(I)
        ENDDO
        CALL YZK(NGRID,0)
C
C   normalise to Z at large R
C
        DNORM = Z/TB(NGRID)
        PARM(3) = TB(NGRID)
        DO I = 1,NGRID
          ZZ(I) = TB(I)*DNORM
        ENDDO
        Z1 = Z1*DNORM
        NOPTS = INT(ONE-LOG(RNT/RAD)/H)
        IF (NGRID.LT.N) THEN
          DO I = NGRID+1,N
            ZZ(I) = Z
          ENDDO
        ENDIF
C
        WRITE (IWRITE,3040) RAD,SKI,NOPTS
        GOTO 30
C
      ENDIF
C-----------------------------------------------------------------------
C
C   Finite nucleus
C   for other values of NUCTYP a call is made to NCHARG
C
      WRITE (IWRITE,3020)
      CALL NCHARG
C
C =============== NUCLEAR POTENTIAL HAS BEEN EVALUATED
C =============== NOW CONSIDER ADDING POLARISATION OR MODEL POTENTIALS
C
   30 CONTINUE
      RETURN
C-----------------------------------------------------------------------
C
C  error messages
C
   40 CONTINUE
      WRITE (IWRITE,3050)
      WRITE (IPUNCH,3050)
      STOP
C-----------------------------------------------------------------------
 3000 FORMAT (/                                                         !
     +' >>>> routine NUCPOT called : evaluate nuclear potential')
 3010 FORMAT (/' point nucleus case')
 3020 FORMAT (/' finite nucleus case - call to NCHARG')
 3030 FORMAT (/' finite nucleus with uniform charge distribution'/      !
     +'    atomic mass                = ',1P,E12.5/                     !
     +'    nuclear radius             = ',E12.5/                        !
     +'    grid points inside nucleus = ',I4)
 3040 FORMAT (/                                                         !
     +' finite nucleus with a two-parameter Fermi charge distribution'/ !
     +'    half radius                = ',1P,E12.5/                     !
     +'    skin depth                 = ',E12.5/                        !
     +'    grid points inside nucleus = ',I4)
 3050 FORMAT (/' incorrect nuclear parameters - STOPPING in NUCPOT')
      END
C
C                             *******************
C
      FUNCTION OCON(IA1,IB1,IA2,IB2)
C
C-----------------------------------------------------------------------
C
C  Evaluates the multiplicative statistical factor.
C  It is assumed that states are ordered so that
C  IA1.LE.IB1 and IA2.LE.IB2.
C
C  No subroutines called.
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      DOUBLE PRECISION OCON
      INCLUDE 'grasp0.inc'
C
C  Argument variables
C
      INTEGER IA1,IA2,IB1,IB2
C
C  Local variables
C
      DOUBLE PRECISION WA,WB,WC
      INTEGER IDL,IDR,IPHAS,K
      INTEGER LLD1,LLD2,LRD1,LRD2
C
C  Common variables
C
      INTEGER NQ1(MXNW),NQ2(MXNW)
      COMMON / ANG11  / NQ1,NQ2
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
      WA = DBLE(NQ1(IA1)*NQ1(IB1))
      IF (IA1.EQ.IB1) WA = WA - DBLE(NQ1(IA1))
      WB = DBLE(NQ2(IA2)*NQ2(IB2))
      IF (IA2.EQ.IB2) WB = WB - DBLE(NQ2(IB2))
C
      WC = WA*WB
      OCON = SQRT(WC)
C
C   Set phase factor (-1)**(DELTA P)
C
      LRD1 = MIN(IA2,IB2)+1
      LRD2 = MAX(IA2,IB2)
      IDR = 0
      IF (LRD1.LE.LRD2) THEN
        IDR = 1
        DO K = LRD1,LRD2
          IDR = IDR+NQ2(K)
        ENDDO
      ENDIF
C
      LLD1 = MIN(IA1,IB1)+1
      LLD2 = MAX(IA1,IB1)
      IDL = 0
      IF (LLD1.LE.LLD2) THEN
        IDL = 1
        DO K = LLD1,LLD2
          IDL = IDL+NQ1(K)
        ENDDO
      ENDIF
C
      IPHAS = IDR-IDL
      IF (MOD(IPHAS,2).NE.0) OCON = -OCON
C
      END
C
C                             *******************
C
      SUBROUTINE ORBPR(IR3,IP3)
C
C-----------------------------------------------------------------------
C
C  This routine writes orbital data to the ORBITALS file.
C  Two records of information are written for each orbital.
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  Argument variables
C
      INTEGER IP3,IR3
C
C  Local variables
C
      CHARACTER*2 NHX
      DOUBLE PRECISION EX,HX,PZX,QZX
      DOUBLE PRECISION RNTX,ZX
      INTEGER I,IJ,IJ1,IJ2
      INTEGER J,L,NAKX,NGRID
      INTEGER NPX,NX
C
C  Common variables
C
      DOUBLE PRECISION ACCY,C,EPH,H
      DOUBLE PRECISION RNT,Z
      INTEGER N,NCPRIN,NW1
      COMMON / DEF01  / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN
C
C  Common variables
C
      DOUBLE PRECISION PZ(MXNW),QZ(MXNW)
      COMMON / EXCO   / PZ,QZ
C
C  Common variables
C
      INTEGER IPUNCH,IREAD,IWRITE
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
C
C  Common variables
C
      DOUBLE PRECISION P(MXNP),PC(MXNP),Q(MXNP)
      DOUBLE PRECISION QC(MXNP)
      COMMON / INT2   / P,Q,PC,QC
C
C  Common variables
C
      INTEGER ITC(50)
      COMMON / OPT01  / ITC
C
C  Common variables
C
      CHARACTER*2 NH(MXNW)
      COMMON / ORB00  / NH
C
C  Common variables
C
      DOUBLE PRECISION E(MXNW)
      COMMON / ORB01  / E
C
C  Common variables
C
      INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF
      INTEGER NP(MXNW),NW
      COMMON / ORB04  / NW,NCF,NP,NAK,IQ
C
C  Common variables
C
      INTEGER MPOIN(MXNW),MPOS(MXNW)
      COMMON / PATY   / MPOIN,MPOS
C
C  Common variables
C
      DOUBLE PRECISION PF(MXNG),QF(MXNG)
      COMMON / WAVE   / PF,QF
C
C  Common variables
C
      INTEGER ILO(MXNW),IWO(MXNW),NWO
      COMMON / WRO    / NWO,IWO,ILO
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
      IF (IR3.GT.0) THEN
        IF (ITC(41).EQ.1) THEN
          REWIND IR3
   10     CONTINUE
          READ (IR3,END=20) NHX,NPX,NAKX,NX,ZX,HX,RNTX,EX,PZX,QZX
          READ (IR3) (P(I),I=1,NX), (Q(I),I=1,NX)
          WRITE (IP3) NHX,NPX,NAKX,NX,ZX,HX,RNTX,EX,PZX,QZX
          WRITE (IP3) (P(I),I=1,NX), (Q(I),I=1,NX)
          WRITE (IWRITE,3000) NPX,NHX
          GOTO 10
        ENDIF
      ENDIF
C
   20 CONTINUE
      IF (NWO.EQ.0) RETURN
      DO L = 1,NWO
        J = IWO(L)
        NGRID = MPOIN(J)
        IJ1 = MPOS(J)
        IJ2 = IJ1+NGRID-1
        WRITE (IP3) NH(J),NP(J),NAK(J),NGRID,Z,H,RNT,E(J),PZ(J),QZ(J)
        WRITE (IP3) (PF(IJ),IJ=IJ1,IJ2), (QF(IJ),IJ=IJ1,IJ2)
        WRITE (IWRITE,3000) NP(J),NH(J)
      ENDDO
      REWIND IP3
C
 3000 FORMAT (/1X,I2,A2,' copied to orbitals file')
      END
C
C                             *******************
C
      SUBROUTINE OSCL(IO7,IO8)
C
C-----------------------------------------------------------------------
C
C  This routine controls the main sequence of routine calls for the
C  calculation of transition oscillator strengths between MCDF levels.
C
C   OSCL
C       BESSJ
C       CSFM
C       ENGOUT
C       LOAD
C       MATOUT
C       MCTIN
C       PRINTA
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  Statement functions
C
      LOGICAL ITRG
C
C  Parameter variables
C
      CHARACTER*4 IAU
      PARAMETER (IAU = 'a.u.')
      CHARACTER*4 IEV
      PARAMETER (IEV = 'eV  ')
      CHARACTER*4 ICM
      PARAMETER (ICM = 'cm-1')
      CHARACTER*4 IAN
      PARAMETER (IAN = 'Ang ')
C
C  Argument variables
C
      INTEGER IO7,IO8
C
C  Local variables
C
      CHARACTER*47 IEN
      CHARACTER*4 IUNITS
      DOUBLE PRECISION ARGU,ASFA,ASFB,FACTOR
      DOUBLE PRECISION OMEGA,VALUE
      INTEGER I,IELEC,II,ITEST
      INTEGER ITKPO,ITR,J,J1
      INTEGER J2,J3,JC,JCASE
      INTEGER JJ,JJJ,JREAD,JTMP1
      INTEGER JTMP2,LEV1,LEV2,LEVEL
      INTEGER LEVF,LEVI,LEVX,MAXV
C
C  Common variables
C
      DOUBLE PRECISION ATW,FACTAN,FACTCM,FACTEV
      DOUBLE PRECISION FACTRY
      COMMON / ATOM   / ATW,FACTRY,FACTCM,FACTEV,FACTAN
C
      DOUBLE PRECISION BJ(6,MXNP),DUM(2),TC(MXNP)
      DOUBLE PRECISION TD(MXNP)
      COMMON / BESS1  / DUM,BJ,TC,TD
C
      DOUBLE PRECISION COUVEC(MXNC,MXNC)
      COMMON / BRET1  / COUVEC
C
      DOUBLE PRECISION HALF,ONE,TEN,TENTH
      DOUBLE PRECISION THREE,TWO,ZERO
      COMMON / CONS   / ZERO,HALF,TENTH,ONE,TWO,THREE,TEN
C
      DOUBLE PRECISION ACCY,C,EPH,H
      DOUBLE PRECISION RNT,Z
      INTEGER N,NCPRIN,NW1
      COMMON / DEF01  / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN
C
      DOUBLE PRECISION BREENG(MXNC),COUENG(MXNC)
      COMMON / ENRG1  / COUENG,BREENG
C
      INTEGER IPUNCH,IREAD,IWRITE
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
C
      INTEGER LEVELS(MXNC),NLEV
      COMMON / LEVL   / NLEV,LEVELS
C
      DOUBLE PRECISION ENLEV(MXNC),GAUGE1,GAUGE2
      COMMON / LEVM   / ENLEV,GAUGE1,GAUGE2
C
      INTEGER IOPAR,KA
      COMMON / MCTA   / KA,IOPAR
C
      INTEGER LTC(20)
      COMMON / OPT04  / LTC
C
      INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF
      INTEGER NP(MXNW),NW
      COMMON / ORB04  / NW,NCF,NP,NAK,IQ
C
      INTEGER ISPAR(MXNC),ITJPO(MXNC)
      COMMON / ORB07  / ITJPO,ISPAR
C
      INTEGER IASPAR(MXNC),IATJPO(MXNC)
      COMMON / OSC1   / IATJPO,IASPAR
C
      INTEGER KK,LK
      COMMON / OSC2   / LK,KK
C
      CHARACTER*80 IHED
      CHARACTER*20 RECORD
      COMMON / TITL   / IHED,RECORD
C
      DOUBLE PRECISION XCON1
      DOUBLE PRECISION XCON2
      DOUBLE PRECISION XCON3
      DOUBLE PRECISION XCON4
      DOUBLE PRECISION XCL
      DOUBLE PRECISION XPI
      DOUBLE PRECISION XTAU
      COMMON / XCONS / XCON1, XCON2, XCON3, XCON4, XCL, XPI, XTAU
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      ITRG(J1,J2,J3) = ABS(J1-J2).LE.J3 .AND.
     +                 J3.LE.J1+J2 .AND.
     +                 MOD(J1+J2+J3,2).EQ.0
C-----------------------------------------------------------------------
C
C  Set the conversion factor for the transition wavelength.
C
      IF (LTC(14)+LTC(15)+LTC(16).EQ.0) THEN
        IUNITS = IAN
        FACTOR = FACTAN/FACTCM
        GOTO 10
      ENDIF
C
      IF (LTC(14)+LTC(15)+LTC(16).GT.1) THEN
        IUNITS = IAN
        FACTOR = FACTAN/FACTCM
        GOTO 10
      ENDIF
C
      IF (LTC(14).EQ.1) THEN
        IUNITS = ICM
        FACTOR = FACTCM
        GOTO 10
      ENDIF
C
      IF (LTC(15).EQ.1) THEN
        IUNITS = IEV
        FACTOR = FACTEV
        GOTO 10
      ENDIF
C
      IF (LTC(16).EQ.1) THEN
        IUNITS = IAU
        FACTOR = ONE
        GOTO 10
      ENDIF
C-----------------------------------------------------------------------
   10 CONTINUE
      WRITE (IWRITE,3000) IHED(1:40),IHED(41:80),RECORD
      WRITE (IPUNCH,3000) IHED(1:40),IHED(41:80),RECORD
      PRINT 3000,IHED(1:40),IHED(41:80),RECORD
      IF (LTC(19).EQ.1) THEN
        WRITE (IWRITE,3150) GAUGE1,GAUGE2
        WRITE (IPUNCH,3150) GAUGE1,GAUGE2
      ENDIF
C
C  Read and check MCT coefficient file.
C
      CALL MCTIN(IO7)
C
C  Read and check MCDF wavefunction file.
C
      REWIND IO8
      CALL LOAD(IO8)
C
      C = XCL
      WRITE (IWRITE,3120) C
C
C  Set parity and total J of levels
C
      DO LEVEL = 1,NCF
        MAXV = 0
        VALUE = ZERO
        DO ITR = 1,NCF
          IF (ABS(COUVEC(ITR,LEVEL)).GE.VALUE) THEN
            MAXV = ITR
            VALUE = ABS(COUVEC(ITR,LEVEL))
          ENDIF
        ENDDO
        IASPAR(LEVEL) = ISPAR(MAXV)
        IATJPO(LEVEL) = ITJPO(MAXV)
      ENDDO
C
      WRITE (IWRITE,3020) NLEV
      DO I = 1,NLEV
        II = LEVELS(I)
        jtmp1 = IATJPO(II)
        IF (mod(jtmp1,2).eq.1) THEN
          jtmp2 = (jtmp1-1)/2
          IF (IASPAR(II).eq.1) THEN
            WRITE (IWRITE,3050) II,jtmp2
          ELSE
            WRITE (IWRITE,3060) II,jtmp2
          ENDIF
        ELSE
          jtmp2 = jtmp1-1
          IF (IASPAR(II).eq.1) THEN
            WRITE (IWRITE,3070) II,jtmp2
          ELSE
            WRITE (IWRITE,3080) II,jtmp2
          ENDIF
        ENDIF
      ENDDO
C
C  LK = order of multipole  = KA
C
      LK = KA
C
C ============================================
C = Loop over the number of cases to be done =
C ============================================
C
      IF (LTC(9)+LTC(10)+LTC(11).EQ.0) LTC(11) = 1
      JCASE = LTC(9)+LTC(10)+LTC(11)
      JREAD = 0
C
      DO JC = 1,JCASE
C
C  use MCDF energies
C
        IF (LTC(9).EQ.1) THEN
          LTC(9) = 0
          IEN = 'using Coulomb eigenvectors and Coulomb energies'
          GOTO 30
        ENDIF
C
C  use BENA energies
C
        IF (LTC(10).EQ.1) THEN
          LTC(10) = 0
          IEN = 'using Breit eigenvectors and Breit energies    '
          READ (IO8,END=20) ((COUVEC(I,J),J=1,NCF),I=1,NCF)
          READ (IO8) (COUENG(I),I=1,NCF)
          JREAD = 1
          GOTO 30
        ENDIF
C
C  use BENA+QED energies
C
        IF (LTC(11).EQ.1) THEN
          LTC(11) = 0
          IEN = 'using Breit eigenvectors and Breit+QED energies'
          IF (JREAD.EQ.0) THEN
            READ (IO8,END=20) ((COUVEC(I,J),J=1,NCF),I=1,NCF)
            READ (IO8)
          ENDIF
          READ (IO8) (COUENG(I),I=1,NCF)
          REWIND IO8
          GOTO 30
        ENDIF
C
        GOTO 90
C
C  ERROR message
C  BENA program was not called and energies are not available
C  use MCDF energies if they have not already been used.
C
   20   CONTINUE
        WRITE (IWRITE,3160)
        LTC(10) = 0
        LTC(11) = 0
        IF (JC.GT.1) GOTO 90
        LTC(9) = 0
        IEN = 'using Coulomb eigenvectors and Coulomb energies'
C
C  Print out level energies and eigenvectors if requested.
C
   30   CONTINUE
        IF (LTC(12).EQ.1) THEN
          WRITE (IWRITE,3130) IEN
          CALL ENGOUT(COUENG,NCPRIN,IWRITE)
          CALL MATOUT(IWRITE,COUVEC,NCF,NCPRIN,MXNC,MXNC,3)
        ENDIF
C-----------------------------------------------------------------------
C
C  KK = 0  for electric multi-pole.
C     = 1  for magnetic multi-pole.
C
C  IOPAR = (-1)**N      electric N-pole
C        = (-1)**(N+1)  magnetic N-pole.
C
C-----------------------------------------------------------------------
        IELEC = (-1)**KA
        IF (IOPAR.EQ.0) GOTO 40
        IF (IELEC.NE.IOPAR) GOTO 50
C
C  electric case
C
   40   CONTINUE
        KK = 0
        GOTO 60
C
C  magnetic case
C
   50   CONTINUE
        KK = 1
        IELEC = -IELEC
C
C  Choose pairs of levels and evaluate oscillator strengths.
C
   60   CONTINUE
        IF (LTC(17).EQ.1) WRITE (IWRITE,3170)
        IF (KK.EQ.1) THEN
          WRITE (IWRITE,3040) KA
          WRITE (IWRITE,3140)
          WRITE (IWRITE,3130) IEN
          WRITE (IWRITE,3100) IUNITS
          WRITE (IPUNCH,3040) KA
          WRITE (IPUNCH,3140)
          WRITE (IPUNCH,3130) IEN
          WRITE (IPUNCH,3100) IUNITS
        ELSE
          WRITE (IWRITE,3030) KA
          WRITE (IWRITE,3140)
          WRITE (IWRITE,3130) IEN
          WRITE (IWRITE,3090) IUNITS
          WRITE (IPUNCH,3030) KA
          WRITE (IPUNCH,3140)
          WRITE (IPUNCH,3130) IEN
          WRITE (IPUNCH,3090) IUNITS
        ENDIF
        IF(LTC(4).EQ.1)THEN
           WRITE (IWRITE,3180)
           WRITE (IPUNCH,3180)
        ENDIF
C-----------------------------------------------------------------------
        DO LEVF = 1,NLEV
          DO LEVI = LEVF,NLEV
C
            LEV2 = LEVELS(LEVF)
            LEV1 = LEVELS(LEVI)
            IF (LEV1.EQ.LEV2) GOTO 80
C
C  Check for consistent parity and J
C
            ITKPO = KA+KA
            IF (ITRG(IATJPO(LEV1)-1,IATJPO(LEV2)-1,ITKPO)) GOTO 70
            GOTO 80
C
   70       CONTINUE
            ITEST = IASPAR(LEV1)*IASPAR(LEV2)*IELEC
            IF (ITEST.LT.0) GOTO 80
C
C  Find OMEGA and evaluate required Bessel functions.
C
            OMEGA = COUENG(LEV1)-COUENG(LEV2)
            IF (LTC(17).EQ.1) OMEGA = ENLEV(LEVI) - ENLEV(LEVF)
C
            IF (OMEGA.LT.ZERO) THEN
              OMEGA = -OMEGA
              LEVX = LEV1
              LEV1 = LEV2
              LEV2 = LEVX
            ENDIF
C
            ARGU = OMEGA/C
            CALL BESSJ(ARGU,LK)
C
            IF (LTC(6).EQ.1) THEN
              DO JJ = 1,3
                JJJ = LK-2+JJ
                WRITE (IWRITE,3110) JJJ, (BJ(JJ,II),II=1,N)
              ENDDO
            ENDIF
C
C  Calculate oscillator strength w.r.t. ASF
C
            CALL CSFM(ASFA,ASFB,LEV1,LEV2)
            CALL PRINTA(ASFA,ASFB,LEV1,LEV2,OMEGA,FACTOR)
C
   80       CONTINUE
C
          ENDDO
        ENDDO
C-----------------------------------------------------------------------
        IF (IOPAR.EQ.0 .AND. KK.EQ.0) GOTO 50
C
   90   CONTINUE
      ENDDO
C
C  End loop over cases.
C
      WRITE (IWRITE,3010)
      WRITE (IPUNCH,3010)
C-----------------------------------------------------------------------
 3000 FORMAT (/1X,71('*')/
     +' routine OSCL : calculate transition probabilities'/1X,71('*')/
     +' Title  : ',A40/'          ',A40/' Run at : ',A20/1X,71('*'))
 3010 FORMAT (/1X,71('*'))
 3020 FORMAT (/' Transitions between the following ',I4,' levels'/)
 3030 FORMAT (/' Electric 2**(',I2,')-pole transitions')
 3040 FORMAT (/' Magnetic 2**(',I2,')-pole transitions')
 3050 FORMAT (9X,I4,5X,I4,'  ',3X,'even')
 3060 FORMAT (9X,I4,5X,I4,'  ',3X,'odd')
 3070 FORMAT (9X,I4,5X,I4,'/2',3X,'even')
 3080 FORMAT (9X,I4,5X,I4,'/2',3X,'odd')
 3090 FORMAT (/
     +' A IJ ... emission transition probability (sec-1) ... length'/
     +' F JI ... absorption oscillator strength ... length'/
     +' S IJ ... line-strength (a.u.) ... length'//
     +'    J   I    energy      A IJ        F JI        S IJ       vel',
     +'/len'/'              ',A4/)
 3100 FORMAT (/' A IJ ... emission transition probability (sec-1)'/
     +' F JI ... absorption oscillator strength'/
     +' S IJ ... line-strength (a.u.)'//
     +'    J   I    energy      A IJ        F JI        S IJ'/
     +'              ',A4/)
 3110 FORMAT (/' Bessel function of order ',I3/(1P,4E18.10))
 3120 FORMAT (/' The speed of light has been reset to ',1P,E17.10)
 3130 FORMAT (/1X,A47)
 3140 FORMAT (1X,33('-'))
 3150 FORMAT (/' option 19 set'/' different gauge factors will be used'/
     +'   Babushkin is replaced by gauge factor ',1P,E12.5/
     +'   Coulomb   is replaced by gauge factor ',E12.5)
 3160 FORMAT (/
     +' *** WARNING - BENA has not been called - calculation continuin',
     +'g ***')
 3170 FORMAT (/' *** using input level energies ***')
 3180 FORMAT (12X,' 2j 2i',2X,' 2mj 2mi',4X,'CG',5X,'Q',4X,'S IJ',
     +8X,'A IJ'/)
      END
C
C                             *******************
C
      SUBROUTINE OUT(NODES,JORB,VN,AST,QZE,ALX,ALY,ECL,JC,JP,M,MAW,MA)
C
C-----------------------------------------------------------------------
C
C   This subroutine carries out the step-by-step outward
C   integration for the inhomogeneous pair of Dirac radial
C   equations
C
C                        Data
C
C   NODES number of nodes in the large component
C   JORB  serial number of function to be computed
C   VN    coefficient of r in series expansion of direct potential
C   ALX   leading coefficients in the series expansions
C   ALY      of the two exchange terms
C   AST   current estimate of the parameter A
C   ECL   current estimate of the eigenvalue E
C   JC    if this is non-zero, it indicates the point
C          at which the step-by-step integration is to
C          terminate. If JC is zero, this point is
C          determined in the course of the calculation.
C   MAW   If this is non-zero, it indicates the point at
C          which the use of the series expansion is to stop,
C          and the step-by-step integration is to begin.
C
C                          Results
C
C   M     is a failure warning, and should normally be zero.
C   =-1   indicates that P(R) has passed through too many zeros
C   =+1   indicates that either the end of the table has been reached,
C          or that P(R) has exceeded 10**6 in magnitude,
C          or that P(R) did not pass through enough zeros.
C   JP    indicates the point at which the integration terminated.
C   MA    indicates the last point for the series expansion.
C   QZE   leading coefficient in expansion of Q(R)
C   P     two common arrays in which the required
C   Q        solutions are tabulated
C
C   No subroutines called.
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  Parameter variables
C
      DOUBLE PRECISION QUART
      PARAMETER (QUART=.25D0)
      DOUBLE PRECISION DELTA
      PARAMETER (DELTA=1.D6)
C
C  Argument variables
C
      DOUBLE PRECISION ALX,ALY,AST,ECL
      DOUBLE PRECISION QZE,VN
      INTEGER JC,JORB,JP,M
      INTEGER MA,MAW,NODES
C
C  Local variables
C
      DOUBLE PRECISION AE,BE,FKJ,GAJ
      DOUBLE PRECISION PUN,PZE,QUN,WA
      DOUBLE PRECISION WAB,WB,WC,WD
      DOUBLE PRECISION WE,WFK
      INTEGER I,II,JS,KJ
      INTEGER MB,NGRID
C
C  Common variables
C
      DOUBLE PRECISION HALF,ONE,TEN,TENTH
      DOUBLE PRECISION THREE,TWO,ZERO
      COMMON / CONS   / ZERO,HALF,TENTH,ONE,TWO,THREE,TEN
C
C  Common variables
C
      DOUBLE PRECISION ACCY,C,EPH,H
      DOUBLE PRECISION RNT,Z
      INTEGER N,NCPRIN,NW1
      COMMON / DEF01  / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN
C
C  Common variables
C
      DOUBLE PRECISION RGRID(MXNP)
      COMMON / GRID   / RGRID
C
C  Common variables
C
      INTEGER IPUNCH,IREAD,IWRITE
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
C
C  Common variables
C
      DOUBLE PRECISION P(MXNP),PC(MXNP),Q(MXNP)
      DOUBLE PRECISION QC(MXNP)
      COMMON / INT2   / P,Q,PC,QC
C
C  Common variables
C
      DOUBLE PRECISION XF(MXNP),XG(MXNP),XR(MXNP)
      DOUBLE PRECISION XS(MXNP),XU(MXNP),XV(MXNP)
      COMMON / INT3   / XU,XV,XR,XS,XF,XG
C
C  Common variables
C
      DOUBLE PRECISION PARM(4),Z1
      INTEGER NPARM,NUCTYP
      COMMON / NPAR   / PARM,Z1,NUCTYP,NPARM
C
C  Common variables
C
      INTEGER ITC(50)
      COMMON / OPT01  / ITC
C
C  Common variables
C
      CHARACTER*2 NH(MXNW)
      COMMON / ORB00  / NH
C
C  Common variables
C
      DOUBLE PRECISION GAMA(MXNW),XAM(MXNW)
      COMMON / ORB02  / GAMA,XAM
C
C  Common variables
C
      INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF
      INTEGER NP(MXNW),NW
      COMMON / ORB04  / NW,NCF,NP,NAK,IQ
C
C  Common variables
C
      INTEGER MPOIN(MXNW),MPOS(MXNW)
      COMMON / PATY   / MPOIN,MPOS
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
      JS = NODES
C
      BE = ECL/C
      AE = C+C-BE
      GAJ = GAMA(JORB)
      KJ = NAK(JORB)
      FKJ = DBLE(KJ)
      WFK = (FKJ*FKJ-QUART)*H*H*QUART
C
C   Compute coefficients in the power series expansions of P and Q
C
      IF (NUCTYP.GT.0) THEN
C
C   Finite nucleus case
C
        MA = 3
C
        IF (KJ.LT.0) THEN
          PZE = AST
          QZE = ZERO
          PUN = ZERO
          QUN = -(ALY-PZE*(BE-VN/C))/(GAJ+GAJ+ONE)
        ELSE
          PZE = ZERO
          QZE = AST*(GAJ+FKJ)*C/Z
          PUN = -(ALX-QZE*(AE+VN/C))/(GAJ+GAJ+ONE)
          QUN = ZERO
        ENDIF
C
      ELSE
C
C   Point nucleus case
C
        PZE = AST
C
        IF (KJ.LT.0) THEN
          QZE = -PZE*Z/(C*(GAJ-FKJ))
        ELSE
          QZE = PZE*(GAJ+FKJ)*C/Z
        ENDIF
C
        WA = GAJ+GAJ+ONE
        WB = ALX-QZE*(AE+VN/C)
        WC = ALY-PZE*(BE-VN/C)
        PUN = (-(GAJ+ONE-FKJ)*WB-Z*WC/C)/WA
        QUN = (-(GAJ+ONE+FKJ)*WC+Z*WB/C)/WA
C
C   If MAW is zero, estimate number of points at which series
C   expansions can be used. Number must be at least 3.
C
        IF (MAW.LE.0) THEN
          WA = ONE/(H*(GAJ+ONE))
          WB = LOG(RNT)/H
          MA = INT(LOG(ABS(ACCY/PUN))*WA-WB)
          MB = INT(LOG(ABS(ACCY/QUN))*WA-WB)
          IF (MA.GT.MB) MA = MB
          IF (MA.LT.3) MA = 3
        ELSE
          MA = MAW
        ENDIF
C
      ENDIF
C
C  Tabulate P and Q from series expansions
C  ---------------------------------------
C
      WA = RNT**GAJ
      WB = EPH**GAJ
      DO I = 1,MA
        P(I) = WA*(PZE+RGRID(I)*PUN)
        Q(I) = WA*(QZE+RGRID(I)*QUN)
        WA = WA*WB
      ENDDO
C
C  Debug print out if option 15 is set
C
      IF (ITC(15).EQ.1) THEN
        WRITE (IWRITE,3000) NP(JORB),NH(JORB),WC,VN,ALX,ALY,PZE,QZE,PUN,!
     +QUN
        DO I = 1,MA,10
          WRITE (IWRITE,3000) NP(JORB),NH(JORB),P(I),Q(I)
        ENDDO
      ENDIF
C
C  Tabulate P and Q by step-by-step integration
C  --------------------------------------------
C
      WA = H*FKJ*HALF+ONE
      WB = WA-TWO
      WAB = WA*WB
C
      IF (JC.GT.0) THEN
        II = MA+1
        DO I = II,JC
          WC = XU(I-1)-WB*P(I-1)-XF(I-1)*Q(I-1)
          WD = XV(I-1)+WA*Q(I-1)-XG(I-1)*P(I-1)
          WE = XF(I)*XG(I)+WAB
          P(I) = (XF(I)*WD+WB*WC)/WE
          Q(I) = (XG(I)*WC-WA*WD)/WE
        ENDDO
        M = 0
        I = JC
      ELSE
        I = MA
        NGRID = MPOIN(JORB)
   10   CONTINUE
        I = I+1
        WC = XU(I-1)-WB*P(I-1)-XF(I-1)*Q(I-1)
        WD = XV(I-1)+WA*Q(I-1)-XG(I-1)*P(I-1)
        WE = XF(I)*XG(I)+WAB
        P(I) = (XF(I)*WD+WB*WC)/WE
        Q(I) = (XG(I)*WC-WA*WD)/WE
C
C   Test for change of sign
C   Count zeros
C   Exit with M=-1 if required number is exceeded
C
        IF (P(I)*P(I-1).LE.ZERO) THEN
C
          JS = JS-1
          IF (JS.LT.0) THEN
            M = -1
            GOTO 50
          ELSE
            GOTO 10
          ENDIF
C
        ELSE
C
C   Exit with M=1 if P grows too large
C
          IF (ABS(P(I)).GE.DELTA) THEN
            M = 1
            GOTO 50
          ENDIF
C
C   Exit with M=2 if end of table is reached
C
          IF (I.GE.NGRID) THEN
            M = 2
            GOTO 50
          ENDIF
C
C   Test for change of sign of discriminant
C
          IF (WFK+XF(I)*XG(I)) 10,20,20
   20     CONTINUE
          IF (WFK+XF(I-2)*XG(I-2)) 40,40,30
   30     CONTINUE
          IF (XF(I)*XG(I)-XF(I-1)*XG(I-1)) 10,40,40
C
C   Normal termination when discriminant changes from negative
C   to positive, or when it passes through a positive minimum.
C   Exit with M=1 if P has not passed through enough zeros.
C
   40     CONTINUE
          IF (JS.GT.0) THEN
            M = 1
          ELSE
            M = 0
          ENDIF
C
        ENDIF
C
      ENDIF
C
   50 CONTINUE
      JP = I
      IF (ITC(15).EQ.1) WRITE (IWRITE,3010) NP(JORB),NH(JORB),JS,M,MA,JP
C
C   Debug print out if option 14 is set
C
      IF (ITC(14).EQ.1) THEN
        II = MA+1
        DO I = II,JP,10
          WRITE (IWRITE,3020) NP(JORB),NH(JORB),P(I),Q(I),XF(I),XG(I),XU!
     +(I-1),XV(I-1)
        ENDDO
      ENDIF
C
 3000 FORMAT ('   OUT15  ',I2,A2,2X,1P,4E12.4/'                ',4E12.4)
 3010 FORMAT ('   OUT15  ',I2,A2,2X,4I12)
 3020 FORMAT ('   OUT14  ',I2,A2,2X,1P,4E12.4/'                ',4E12.4)
      END
C
C                             *******************
C
      SUBROUTINE PRINTA(ASFA,ASFB,I,J,OMEGA,FACTOR)
C
C-----------------------------------------------------------------------
C
C  This routine prints the basic oscillator strength information
C  for transitions between level I and level J.
C
C  ASFA   : 
C  ASFB   : 
C  I      : level label 
C  J      : level label
C  OMEGA  : 
C  FACTOR : 
C
C  No subroutines called.
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  Parameter variables
C
      DOUBLE PRECISION EPS10,EPS70
      PARAMETER (EPS10=1.D-10)
      PARAMETER (EPS70=1.D-70)
C
C  Argument variables
C
      DOUBLE PRECISION ASFA,ASFB,FACTOR,OMEGA
      INTEGER I,J
C
C  Local variables
C
      DOUBLE PRECISION ASFA2,ASFB2,ENG,FOS
      DOUBLE PRECISION FSEP,SEB
      DOUBLE PRECISION SEC,TOB,TOC
      DOUBLE PRECISION FACALF,LINESTR,VELLEN
C
C  Common variables
C
      DOUBLE PRECISION HALF,ONE,TEN,TENTH
      DOUBLE PRECISION THREE,TWO,ZERO
      COMMON / CONS   / ZERO,HALF,TENTH,ONE,TWO,THREE,TEN
C
      DOUBLE PRECISION ACCY,C,EPH,H
      DOUBLE PRECISION RNT,Z
      INTEGER N,NCPRIN,NW1
      COMMON / DEF01  / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN
C
      INTEGER IPUNCH,IREAD,IWRITE
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
C
      INTEGER LTC(20)
      COMMON / OPT04  / LTC
C
      INTEGER IASPAR(MXNC),IATJPO(MXNC)
      COMMON / OSC1   / IATJPO,IASPAR
C
      INTEGER KK,LK
      COMMON / OSC2   / LK,KK
C
      INTEGER IQ,IER,LL,LLL
      DOUBLE PRECISION XJ1,XJ2,XJ3,XM1,XM2,XM3,CG
      DOUBLE PRECISION XCON1
      DOUBLE PRECISION XCON2
      DOUBLE PRECISION XCON3
      DOUBLE PRECISION XCON4
      DOUBLE PRECISION XCL
      DOUBLE PRECISION XPI
      DOUBLE PRECISION XTAU
      COMMON / XCONS / XCON1, XCON2, XCON3, XCON4, XCL, XPI, XTAU
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
      IF (ABS(OMEGA).LT.EPS10) RETURN
C
C  evaluate relevant constants
C
C  FOS = \frac{c^2\:(2J_r+1)}{\omega\:(2L+1)\:(2J_s+1)}
C
      FOS = C*C/(OMEGA*DBLE(LK+LK+1))
      FOS = FOS*DBLE(IATJPO(I))/DBLE(IATJPO(J))
C
C  FSEP = \frac{2\omega}{c\:(2L+1)\:\tau_o}
C  where $\tau_o$ is the atomic unit of time is seconds
C
      FSEP = (TWO*OMEGA)/(C*DBLE(LK+LK+1))
      FSEP = FSEP/XTAU
C
C  convert energy to the required units
C
      IF (LTC(14)+LTC(15)+LTC(16).EQ.0) THEN
        ENG = FACTOR/OMEGA
      ELSE
        ENG = OMEGA*FACTOR
      ENDIF
C
      IF (KK.EQ.0) THEN
C
C  electric case
C
        ASFA2 = ASFA**2
        ASFB2 = ASFB**2
        TOB = ASFB2*FOS
        SEB = ASFB2*FSEP
        VELLEN = ASFB2                                   !NRB
        IF(VELLEN.GT.EPS70)VELLEN = ASFA2/ASFB2          !NRB
C
        IF (LK.EQ.1) THEN
          FACALF = 1.D0
        ELSE
          IF (LK.EQ.2) THEN
            FACALF = 3.756D5/OMEGA**2
          ELSE
            FACALF = 0.D0
          ENDIF
        ENDIF
C
        LINESTR = 1.5D0*FACALF*DBLE(IATJPO(I))*SEB/(3.213D10*OMEGA**3)
C
C optional magentic sub-level resolution
C
        IF(LTC(4).EQ.1)THEN
          DO LL=-(IATJPO(J)-1),(IATJPO(J)-1),2
            DO LLL=-(IATJPO(I)-1),(IATJPO(I)-1),2
              DO IQ=-1,1,1
                IER=0
                XJ1=REAL(IATJPO(J)-1)*0.5d0
                XJ2=1.0d0
                XJ3=REAL(IATJPO(I)-1)*0.5d00
                XM1=REAL(LL)*0.5d0
                XM2=REAL(IQ)
                XM3=REAL(LLL)*0.5d0
C
                CALL CLEBGOR(XJ1,XJ2,-XM1,XM2,XJ3,XM3,CG,IER)
C
                IF(IER.EQ.0)THEN
                  CG=CG/SQRT(REAL(IATJPO(I)))
                  CG=CG**2
C                  write(iwrite,999)' LEV= ',j,' LEV= ',i,' 2J_final=',
C     X            IATJPO(J)-1,' 2J_init=',IATJPO(I)-1,
C     X            ' 2m_i=',nint(2*XM1),' 2m_j=',nint(2*XM3),CG,IQ,
C     X            LINESTR*CG,SEB*CG
                  WRITE(IWRITE,3000) J,I,IATJPO(J)-1,IATJPO(I)-1,
     X            nint(2*XM1),nint(2*XM3),CG,IQ,LINESTR*CG,SEB*CG
                  WRITE(IPUNCH,3000) J,I,IATJPO(J)-1,IATJPO(I)-1,
     X            nint(2*XM1),nint(2*XM3),CG,IQ,LINESTR*CG,SEB*CG
                ENDIF
              ENDDO
            ENDDO
          ENDDO
        ENDIF
C
        WRITE (IWRITE,3010) J,I,ENG,SEB,TOB,LINESTR,VELLEN
        WRITE (IPUNCH,3010) J,I,ENG,SEB,TOB,LINESTR,VELLEN
C
      ELSE
C
C  magnetic case
C
        ASFA2 = ASFA**2
        TOC = ASFA2*FOS
        SEC = ASFA2*FSEP
C
        IF (LK.EQ.1) THEN
          FACALF = 7.511D4
        ELSE
          IF (LK.EQ.2) THEN
            FACALF = 2.821D10/OMEGA**2
          ELSE
            FACALF = 0.D0
          ENDIF
        ENDIF
C
        LINESTR = 1.5D0*FACALF*DBLE(IATJPO(I))*SEC/(3.213D10*OMEGA**3)
C
C optional magentic sub-level resolution
C
        IF(LTC(4).EQ.1)THEN
          DO LL=-(IATJPO(J)-1),(IATJPO(J)-1),2
            DO LLL=-(IATJPO(I)-1),(IATJPO(I)-1),2
              DO IQ=-1,1,1
                IER=0
                XJ1=REAL(IATJPO(J)-1)*0.5d0
                XJ2=1.0d0
                XJ3=REAL(IATJPO(I)-1)*0.5d00
                XM1=REAL(LL)*0.5d0
                XM2=REAL(IQ)
                XM3=REAL(LLL)*0.5d0
C
                CALL CLEBGOR(XJ1,XJ2,-XM1,XM2,XJ3,XM3,CG,IER)
C
                IF(IER.eq.0)THEN
                  CG=CG/SQRT(REAL(IATJPO(I)))
                  CG=CG**2
C                  write(iwrite,999)' LEV= ',j,' LEV= ',i,' 2J_final=',
C     X            IATJPO(J)-1,' 2J_init=',IATJPO(I)-1,
C     X            ' 2m_i=',nint(2*XM1),' 2m_j=',nint(2*XM3),CG,IQ,
C     X            LINESTR*CG,SEC*CG
                  WRITE(IWRITE,3000) J,I,IATJPO(J)-1,IATJPO(I)-1,
     X            nint(2*XM1),nint(2*XM3),CG,IQ,LINESTR*CG,SEC*CG
                  WRITE(IPUNCH,3000) J,I,IATJPO(J)-1,IATJPO(I)-1,
     X            nint(2*XM1),nint(2*XM3),CG,IQ,LINESTR*CG,SEC*CG
                ENDIF
              ENDDO
            ENDDO
          ENDDO
        ENDIF
C
        WRITE (IWRITE,3020) J,I,ENG,SEC,TOC,LINESTR
        WRITE (IPUNCH,3020) J,I,ENG,SEC,TOC,LINESTR
C
      ENDIF
C
C 999  FORMAT(2(A6,I3),A10,I3,A9,I3,2(A6,F9.5),F9.5,I3,F15.9,1X,E12.4)
 3000 FORMAT (1X,2I5,3X,2I5,2X,2I5,F9.5,I3,1P,2E12.4)
 3010 FORMAT (1X,2I5,1P,4E12.4,1X,E9.1)
 3020 FORMAT (1X,2I5,1P,4E12.4)
      END
C
C                             *******************
C
      SUBROUTINE PROPG(IJK)
C
C-----------------------------------------------------------------------
C
C   This subroutine calculates various properties of the orbitals
C   and prints out information  i.e.
C
C    (1)  orbital eigenvalues in a.u. , expectation values of 1/r ,
C         r and r*r , screening numbers (SC)
C
C    (2)  Lagrange multipliers
C
C    (3)  checks orthogonality and Schmidt orthogonalises if necessary
c
c         Re-written for L-spinors viz. single pass orthogonalization
c         on-the-fly, which is highly accurate     -     nrb 16/01/08
C
C    (4)  ordered eigenvalues and eigenvectors of the Hamiltonian
C
C   IJK controls the output :
C
C    =0   final print out using (1),(2),(3),(4)
C
C    =1   check orthogonality of initial wave functions using (3)
C         with no print out
C
C   Routines called : RINT , ZEFR , MATOUT
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  External functions
C
      EXTERNAL RINT
      DOUBLE PRECISION RINT
C
C  Parameter variables
C
      DOUBLE PRECISION EPS6
      PARAMETER (EPS6=1.D-6)
      DOUBLE PRECISION EPS10
      PARAMETER (EPS10=1.D-10)
C
C  Argument variables
C
      INTEGER IJK
C
C  Local variables
C
      DOUBLE PRECISION AM,EAN,EAU,ECM
      DOUBLE PRECISION EEV,ERY,ORTH,RN
      DOUBLE PRECISION WA,WB,WC,WD
      DOUBLE PRECISION RT(MXNW)
      double precision eps
      INTEGER I,II,IJ,IP
      INTEGER J,L
      INTEGER LI,LJ,MA,MB
      INTEGER NGRID
      integer jf2                                       !,nt
C
C  Common variables
C
      DOUBLE PRECISION ATW,FACTAN,FACTCM,FACTEV
      DOUBLE PRECISION FACTRY
      COMMON / ATOM   / ATW,FACTRY,FACTCM,FACTEV,FACTAN
C
C  Common variables
C
      DOUBLE PRECISION COUVEC(MXNC,MXNC)
      COMMON / BRET1  / COUVEC
C
C  Common variables
C
      DOUBLE PRECISION HALF,ONE,TEN,TENTH
      DOUBLE PRECISION THREE,TWO,ZERO
      COMMON / CONS   / ZERO,HALF,TENTH,ONE,TWO,THREE,TEN
C
C  Common variables
C
      DOUBLE PRECISION ACCY,C,EPH,H
      DOUBLE PRECISION RNT,Z
      INTEGER N,NCPRIN,NW1
      COMMON / DEF01  / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN
C
C  Common variables
C
      DOUBLE PRECISION BREENG(MXNC),COUENG(MXNC)
      COMMON / ENRG1  / COUENG,BREENG
C
C  Common variables
C
      double precision pz(mxnw),qz(mxnw)
      common / exco   / pz,qz
C
C  Common variables
C
      INTEGER JFIX(MXNW)
      COMMON / FIXD   / JFIX
C
C  Common variables
C
      INTEGER IPUNCH,IREAD,IWRITE
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
C
C  Common variables
C
      DOUBLE PRECISION ECV(MXNO)
      INTEGER IECC(MXNO),NEC
      COMMON / OFFD   / ECV,IECC,NEC
C
C  Common variables
C
      INTEGER ITC(50)
      COMMON / OPT01  / ITC
C
C  Common variables
C
      integer jtc(20)
      common / opt02  / jtc
C
C  Common variables
C
      CHARACTER*2 NH(MXNW)
      COMMON / ORB00  / NH
C
C  Common variables
C
      DOUBLE PRECISION E(MXNW)
      COMMON / ORB01  / E
C
C  Common variables
C
      INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF
      INTEGER NP(MXNW),NW
      COMMON / ORB04  / NW,NCF,NP,NAK,IQ
C
C  Common variables
C
      INTEGER ISPAR(MXNC),ITJPO(MXNC)
      COMMON / ORB07  / ITJPO,ISPAR
C
C  Common variables
C
      INTEGER LEV(MXNC)
      COMMON / PAT1   / LEV
C
C  Common variables
C
      INTEGER MPOIN(MXNW),MPOS(MXNW)
      COMMON / PATY   / MPOIN,MPOS
C
C  Common variables
C
      DOUBLE PRECISION PF(MXNG),QF(MXNG)
      COMMON / WAVE   / PF,QF
C
C  Common variables
C
      logical lspin
      common /nrb000/lspin
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
C
C   Section (1)
C
C-----------------------------------------------------------------------
      IF (IJK.EQ.1) GOTO 10
C-----------------------------------------------------------------------
      WRITE (IWRITE,3010)
      WRITE (IPUNCH,3010)
C
      DO J = 1,NW
        IF (JFIX(J).EQ.0) THEN
          NGRID = MPOIN(J)
          WB = RINT(J,J,1)
          RT(J) = WB
          CALL ZEFR(J,WB,WD)
          WD = Z-WD
          WRITE (IWRITE,3020) J,NP(J),NH(J),E(J),WD,NGRID
          WRITE (IPUNCH,3020) J,NP(J),NH(J),E(J),WD,NGRID
        ENDIF
      ENDDO
C-----------------------------------------------------------------------
      WRITE (IWRITE,3230)
      WRITE (IPUNCH,3230)
C
      DO J = 1,NW
        IF (JFIX(J).EQ.0) THEN
          WA = RINT(J,J,-1)
          WB = RT(J)
          WC = RINT(J,J,2)
          WRITE (IWRITE,3240) J,NP(J),NH(J),WA,WB,WC
          WRITE (IPUNCH,3240) J,NP(J),NH(J),WA,WB,WC
        ENDIF
      ENDDO
C-----------------------------------------------------------------------
C
C   Section (2)
C
C-----------------------------------------------------------------------
      IF (NEC.GT.0) THEN
        WRITE (IWRITE,3040)
        DO I = 1,NEC
          MA = IECC(I)/NW1
          MB = IECC(I)-NW1*MA
          WRITE (IWRITE,3050) NP(MB),NH(MB),NP(MA),NH(MA),ECV(I)
        ENDDO
      ENDIF
C-----------------------------------------------------------------------
C
C   Section (3)
C
C-----------------------------------------------------------------------
   10 CONTINUE
      IF (NW.EQ.1) GOTO 30
C
   20 CONTINUE
      WRITE (IWRITE,3030)
C
      if(lspin)then
        jf2=-2
        eps=eps10
      else
        jf2=2
        eps=eps6
      endif
c      nt = 0
      DO I = 1,nw
        IP = I-1
        DO J = 1,IP
          IF (NAK(I).EQ.NAK(J)) THEN
            IF (JFIX(I)+JFIX(J).NE.jf2) THEN
              NGRID = MIN(MPOIN(I),MPOIN(J))
              ORTH = RINT(I,J,0)
              if(itc(22).eq.0.and.(ijk.eq.1.or.abs(orth).gt.eps))then
                write (iwrite,3045) np(i),nh(i),np(j),nh(j),orth
c                nt = nt+1
                li = mpos(i)
                lj = mpos(j)
                do l = 1,ngrid
                  pf(li) = pf(li)-orth*pf(lj)
                  qf(li) = qf(li)-orth*qf(lj)
                  li = li+1
                  lj = lj+1
                enddo
                pz(i) = pz(i)-orth*pz(j)
                qz(i) = qz(i)-orth*qz(j)
              elseif(abs(orth).gt.eps.or.itc(22).eq.1)then
                WRITE (IWRITE,3050) NP(I),NH(I),NP(J),NH(J),ORTH
              endif
            ENDIF
          ENDIF
        ENDDO
c        if(nt.gt.0)then         
c        do when nt=0, as improves norm for subsequent L-spinor overlaps
        ngrid = mpoin(i)
        rn = rint(i,i,0)
cw                        write (iwrite,3050) np(i),nh(i),np(i),nh(i),rn
        rn = one/sqrt(rn)
        li = mpos(i)
        do l = 1,ngrid
          pf(li) = pf(li)*rn
          qf(li) = qf(li)*rn
          li = li+1
        enddo
        pz(i) = pz(i)*rn
        qz(i) = qz(i)*rn
c        nt=0
c        endif
cw        li = mpos(i)
cw                        write(*,*)i,qz(i)/pz(i),qf(li)/pf(li)
      ENDDO
C-----------------------------------------------------------------------
   30 CONTINUE
      IF (IJK.EQ.1.or.jtc(13).eq.0) RETURN
C-----------------------------------------------------------------------
C
C   Section (4)
C
C-----------------------------------------------------------------------
      WRITE (IPUNCH,3110)
      DO J = 1,NCPRIN
        IF (J.EQ.1) THEN
          EAU = BREENG(J)
        ELSE
          EAU = BREENG(J)-BREENG(1)
        ENDIF
        ERY = EAU*FACTRY
        I = LEV(J)
        IJ = ITJPO(I)-1
        IP = ISPAR(I)
        AM = COUVEC(I,J)
        IF (MOD(IJ,2).EQ.0) THEN
          IJ = IJ/2
          IF (IP.EQ.1) THEN
            WRITE (IPUNCH,3180) J,IJ,I,AM,EAU,ERY
          ELSE
            WRITE (IPUNCH,3170) J,IJ,I,AM,EAU,ERY
          ENDIF
        ELSE
          IF (IP.EQ.1) THEN
            WRITE (IPUNCH,3160) J,IJ,I,AM,EAU,ERY
          ELSE
            WRITE (IPUNCH,3150) J,IJ,I,AM,EAU,ERY
          ENDIF
        ENDIF
      ENDDO
C-----------------------------------------------------------------------
      IF (ABS(ATW).LT.EPS10) THEN
        WRITE (IWRITE,3090) FACTCM,FACTEV
      ELSE
        WRITE (IWRITE,3100) ATW,FACTCM,FACTEV
      ENDIF
C
      DO J = 1,NCPRIN
        EAU = BREENG(J)
        ERY = EAU*FACTRY
        I = LEV(J)
        IJ = ITJPO(I)-1
        IP = ISPAR(I)
        AM = COUVEC(I,J)
        IF (MOD(IJ,2).EQ.0) THEN
          IJ = IJ/2
          IF (IP.EQ.1) THEN
            WRITE (IWRITE,3180) J,IJ,I,AM,EAU,ERY
          ELSE
            WRITE (IWRITE,3170) J,IJ,I,AM,EAU,ERY
          ENDIF
        ELSE
          IF (IP.EQ.1) THEN
            WRITE (IWRITE,3160) J,IJ,I,AM,EAU,ERY
          ELSE
            WRITE (IWRITE,3150) J,IJ,I,AM,EAU,ERY
          ENDIF
        ENDIF
      ENDDO
C
      WRITE (IWRITE,3130)
      DO J = 1,NCPRIN
        EAU = BREENG(J)
        ECM = EAU*FACTCM
        EEV = EAU*FACTEV
        I = LEV(J)
        IJ = ITJPO(I)-1
        IP = ISPAR(I)
        AM = COUVEC(I,J)
        IF (MOD(IJ,2).EQ.0) THEN
          IJ = IJ/2
          IF (IP.EQ.1) THEN
            WRITE (IWRITE,3180) J,IJ,I,AM,ECM,EEV
          ELSE
            WRITE (IWRITE,3170) J,IJ,I,AM,ECM,EEV
          ENDIF
        ELSE
          IF (IP.EQ.1) THEN
            WRITE (IWRITE,3160) J,IJ,I,AM,ECM,EEV
          ELSE
            WRITE (IWRITE,3150) J,IJ,I,AM,ECM,EEV
          ENDIF
        ENDIF
      ENDDO
C
      IF (NCPRIN.GT.1) THEN
C
        WRITE (IWRITE,3120)
        DO J = 1,NCPRIN
          EAU = BREENG(J)-BREENG(1)
          ERY = EAU*FACTRY
          I = LEV(J)
          IJ = ITJPO(I)-1
          IP = ISPAR(I)
          AM = COUVEC(I,J)
          IF (MOD(IJ,2).EQ.0) THEN
            IJ = IJ/2
            IF (IP.EQ.1) THEN
              WRITE (IWRITE,3220) J,IJ,I,AM,EAU,ERY
            ELSE
              WRITE (IWRITE,3210) J,IJ,I,AM,EAU,ERY
            ENDIF
          ELSE
            IF (IP.EQ.1) THEN
              WRITE (IWRITE,3200) J,IJ,I,AM,EAU,ERY
            ELSE
              WRITE (IWRITE,3190) J,IJ,I,AM,EAU,ERY
            ENDIF
          ENDIF
        ENDDO
C
        WRITE (IWRITE,3140)
        DO J = 1,NCPRIN
          EAU = BREENG(J)-BREENG(1)
          ECM = EAU*FACTCM
          EEV = EAU*FACTEV
          EAN = ZERO
          IF (J.GT.1) EAN = FACTAN/ECM
          I = LEV(J)
          IJ = ITJPO(I)-1
          IP = ISPAR(I)
          AM = COUVEC(I,J)
          IF (MOD(IJ,2).EQ.0) THEN
            IJ = IJ/2
            IF (IP.EQ.1) THEN
              WRITE (IWRITE,3220) J,IJ,I,AM,ECM,EEV,EAN
            ELSE
              WRITE (IWRITE,3210) J,IJ,I,AM,ECM,EEV,EAN
            ENDIF
          ELSE
            IF (IP.EQ.1) THEN
              WRITE (IWRITE,3200) J,IJ,I,AM,ECM,EEV,EAN
            ELSE
              WRITE (IWRITE,3190) J,IJ,I,AM,ECM,EEV,EAN
            ENDIF
          ENDIF
        ENDDO
C
      ENDIF
C-----------------------------------------------------------------------
C
C  Print the eigenvectors if option 32 is set
C
      IF (ITC(32).EQ.1)CALL MATOUT(IWRITE,COUVEC,NCF,NCPRIN,MXNC,MXNC,3)
C-----------------------------------------------------------------------
 3000 FORMAT (1X)
 3010 FORMAT (/' orbital properties'/' ------------------'/21X,         !
     +'E  (a.u.)',8X,'SC'/)
 3020 FORMAT (1X,I2,1X,I2,A2,3X,1P,E20.12,E15.7,I6)
 3030 FORMAT (/' orthogonality integrals'/)
 3040 FORMAT (/' Lagrange multipliers'/)
 3045 format (1x,i2,a2,2x,i2,a2,3x,1p,e15.7,'  Schmidt orthogonalised')
 3050 FORMAT (1X,I2,A2,2X,I2,A2,3X,1P,E15.7)
 3090 FORMAT (/' atomic level properties'/' -----------------------'/   !
     +' conversion of units using atomic weight set to infinity'/       !
     +'    1 a.u. = ',1P,E17.10,' cm-1'/'    1 a.u. = ',E17.10,' eV'//  !
     +' eigenenergies'/' -------------'/'                    dominant'/ !
     +' level  J   parity  CSF   mix       a.u.',16X,'Ryd.'/)
 3100 FORMAT (/' atomic level properties'/' -----------------------'/   !
     +' conversion of units using atomic weight = ',F10.5/              !
     +'    1 a.u. = ',1P,E17.10,' cm-1'/'    1 a.u. = ',E17.10,' eV'//  !
     +' eigenenergies'/' -------------'/'                    dominant'/ !
     +' level  J   parity  CSF   mix       a.u.',16X,'Ryd.'/)
 3110 FORMAT (/' atomic level properties'/' -----------------------'/   !
     +' eigenenergies (absolute for groundstate; relative for others)'/ !
     +' -------------'/'                    dominant'/                  !
     +' level  J   parity  CSF   mix       a.u.',16X,'Ryd.'/)
 3120 FORMAT (/' eigenenergies relative to the lowest'/                 !
     +' ------------------------------------'/                          !
     +'                    dominant'/                                   !
     +' level  J   parity  CSF   mix       a.u.',12X,'Ryd.'/)
 3130 FORMAT (/'                    dominant'/                          !
     +' level  J   parity  CSF   mix       cm-1',16X,' eV '/)
 3140 FORMAT (/' eigenenergies relative to the lowest'/                 !
     +' ------------------------------------'/                          !
     +'                    dominant'/                                   !
     +' level  J   parity  CSF   mix       cm-1',12X,' eV ',12X,'Ang.'/)
 3150 FORMAT (1X,I4,2X,I4,'/2  odd    ',I4,2X,F5.3,1X,1P,2E20.12)
 3160 FORMAT (1X,I4,2X,I4,'/2  even   ',I4,2X,F5.3,1X,1P,2E20.12)
 3170 FORMAT (1X,I4,2X,I4,'    odd    ',I4,2X,F5.3,1X,1P,2E20.12)
 3180 FORMAT (1X,I4,2X,I4,'    even   ',I4,2X,F5.3,1X,1P,2E20.12)
 3190 FORMAT (1X,I4,2X,I4,'/2  odd    ',I4,2X,F5.3,1X,1P,3E16.8)
 3200 FORMAT (1X,I4,2X,I4,'/2  even   ',I4,2X,F5.3,1X,1P,3E16.8)
 3210 FORMAT (1X,I4,2X,I4,'    odd    ',I4,2X,F5.3,1X,1P,3E16.8)
 3220 FORMAT (1X,I4,2X,I4,'    even   ',I4,2X,F5.3,1X,1P,3E16.8)
 3230 FORMAT (/16X,'1/r',12X,' r ',12X,'r*r'/)
 3240 FORMAT (1X,I2,1X,I2,A2,3X,1P,3E15.7)
      END
C
C                             *******************
C
      SUBROUTINE PRWF(J)
C
C-----------------------------------------------------------------------
C
C   Print wavefunctions
C   The wavefunctions are written formatted to PRWF.DAT on stream 29.
C   This file is in the form of a SHELL program that can be run to
C   split up the file. This facilitates input into a graphics package.
C   The file ORB files details on the contents of the other files.
C
C   There are two modes :
C     (1) J>0  - used as a debug option in SOLV0/1, wavefunctions for
C                orbital J are printed if option 16 is set.
C              - also called from STWAVE
C     (2) J=0  - a final print out of wavefunctions is made if option 8
C                is set.
C              - an initial print out wavefunctions is made if option 9
C                is set.
C
C   Subroutine called : IN2CH3
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  Argument variables
C
      INTEGER J
C
C  Local variables
C
      CHARACTER*3 LABEL
      CHARACTER*6 ORBNAM
      INTEGER I,IK,INDORB,IPRWF
      INTEGER K,NGRID
C
C  Common variables
C
      DOUBLE PRECISION RGRID(MXNP)
      COMMON / GRID   / RGRID
C
C  Common variables
C
      INTEGER IPUNCH,IREAD,IWRITE
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
C
C  Common variables
C
      DOUBLE PRECISION P(MXNP),PC(MXNP),Q(MXNP)
      DOUBLE PRECISION QC(MXNP)
      COMMON / INT2   / P,Q,PC,QC
C
C  Common variables
C
      CHARACTER*2 NH(MXNW)
      COMMON / ORB00  / NH
C
C  Common variables
C
      DOUBLE PRECISION E(MXNW)
      COMMON / ORB01  / E
C
C  Common variables
C
      INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF
      INTEGER NP(MXNW),NW
      COMMON / ORB04  / NW,NCF,NP,NAK,IQ
C
C  Common variables
C
      INTEGER MPOIN(MXNW),MPOS(MXNW)
      COMMON / PATY   / MPOIN,MPOS
C
C  Common variables
C
      DOUBLE PRECISION PF(MXNG),QF(MXNG)
      COMMON / WAVE   / PF,QF
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      SAVE INDORB
      DATA INDORB/0/
C-----------------------------------------------------------------------
      IPRWF = 29
      IF (INDORB.EQ.0) THEN
        OPEN (UNIT=IPRWF,FILE='GRASP.SH',FORM='FORMATTED',STATUS='UNKNOW!
     +N')
      ENDIF
C
      IF (J.GT.0) THEN
C
C   Mode (1)
C
        NGRID = MPOIN(J)
        DO I = 1,NGRID
          PC(I) = P(I)*P(I)+Q(I)*Q(I)
        ENDDO
        INDORB = INDORB+1
        CALL IN2CH3 (INDORB,LABEL,IWRITE)
        ORBNAM = 'orb'//LABEL
        WRITE (IPRWF,3000) ORBNAM,NP(J),NH(J),NAK(J),NGRID,E(J)
        WRITE (IPRWF,3010) ORBNAM
        WRITE (IPRWF,3020) (RGRID(I),P(I),Q(I),PC(I),I=1,NGRID)
        WRITE (IPRWF,3030)
C
      ELSE
C
C   Mode (2)
C
        DO K = 1,NW
          NGRID = MPOIN(K)
          IK = MPOS(K)
          DO I = 1,NGRID
            P(I) = PF(IK)
            Q(I) = QF(IK)
            IK = IK+1
          ENDDO
          DO I = 1,NGRID
            PC(I) = P(I)*P(I)+Q(I)*Q(I)
          ENDDO
          INDORB = INDORB+1
          CALL IN2CH3 (INDORB,LABEL,IWRITE)
          ORBNAM = 'orb'//LABEL
          WRITE (IPRWF,3000) ORBNAM,NP(K),NH(K),NAK(K),NGRID,E(K)
          WRITE (IPRWF,3010) ORBNAM
          WRITE (IPRWF,3020) (RGRID(I),P(I),Q(I),PC(I),I=1,NGRID)
          WRITE (IPRWF,3030)
        ENDDO
C
      ENDIF
C
 3000 FORMAT ('cat << eof >> INDEX'/A6,' : ',I2,1X,A2,1X,I3,            !
     +' : r (a.u.) : ',I4,1X,1P,E12.5/'eof')
 3010 FORMAT ('cat << eof >> ',A6)
 3020 FORMAT (1X,1P,4E12.4)
 3030 FORMAT ('eof')
      END
C
C                             *******************
C
      SUBROUTINE QED
C
C-----------------------------------------------------------------------
C
C  This routine evaluates the QED corrections to the energy levels
C  due to vacuum polarisation (correct to first order) and a crude
C  approximation to the self energy.
C  The V.P. contribution is calculated using the results of Fullerton
C  and Rinker Phys. Rev. A  Vol 13  P 1283 (1976) while the S.E.
C  contribution is estimated for S, P- and P orbitals by interpolating
C  among the values given by P. Mohr for Coulomb type wavefunctions
C  after an effective nuclear charge, ZEFF, is obtained by finding the
C  ZEFF required to give a Coulomb orbital with the same average R
C  as the MCDF orbital.
C
C  Subroutines called : RINT,FZALF,QUAD,VACPOL,ZEFR
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  External functions
C
      EXTERNAL RINT
      DOUBLE PRECISION RINT
C
C  Parameter variables
C
      DOUBLE PRECISION ZERO
      PARAMETER (ZERO=0.D0)
      INTEGER N11
      PARAMETER (N11=MXNP+10)
C
C  Local variables
C
      DOUBLE PRECISION ALLINT,COEF,CONT,ENG
      DOUBLE PRECISION RAV,SFCONT,SLFINT(MXNW)
      DOUBLE PRECISION VALU,VPCONT,VPINT(MXNW),ZEFF
      INTEGER I,I1,J,K
      INTEGER LEV,NGRID
C
C  Common variables
C
      DOUBLE PRECISION COUVEC(MXNC,MXNC)
      COMMON / BRET1  / COUVEC
C
      DOUBLE PRECISION SFENG(MXNC),VPENG(MXNC)
      COMMON / ENRG2  / VPENG,SFENG
C
      INTEGER IPUNCH,IREAD,IWRITE
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
C
      INTEGER KTC(20)
      COMMON / OPT03  / KTC
C
      CHARACTER*2 NH(MXNW)
      COMMON / ORB00  / NH
C
      INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF
      INTEGER NP(MXNW),NW
      COMMON / ORB04  / NW,NCF,NP,NAK,IQ
C
      INTEGER MPOIN(MXNW),MPOS(MXNW)
      COMMON / PATY   / MPOIN,MPOS
C
      DOUBLE PRECISION TA(N11),TB(N11)
      COMMON / TATB   / TA,TB
C
      DOUBLE PRECISION PF(MXNG),QF(MXNG)
      COMMON / WAVE   / PF,QF
C
      DOUBLE PRECISION XCON1
      DOUBLE PRECISION XCON2
      DOUBLE PRECISION XCON3
      DOUBLE PRECISION XCON4
      DOUBLE PRECISION XCL
      DOUBLE PRECISION XPI
      DOUBLE PRECISION XTAU
      COMMON / XCONS / XCON1, XCON2, XCON3, XCON4, XCL, XPI, XTAU
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C
C  Calculate the vacuum polarisation potential at each of the grid
C  points
C
      CALL VACPOL
C
C  Obtain contribution from each orbital
C
      DO I = 1,NW
C
C  Obtain v.p. contribution for orbital I
C
        NGRID = MPOIN(I)
        I1 = MPOS(I)
        DO K = 1,NGRID
          TA(K) = (PF(I1)*PF(I1)+QF(I1)*QF(I1))*TB(K)
          I1 = I1+1
        ENDDO
        CALL QUAD(NGRID,ALLINT)
        VPINT(I) = ALLINT
C
C  Obtain s.e. contribution for orbital I
C
        IF (NAK(I).GT.1 .OR. NAK(I).LT.-2) THEN
C
C  No estimate for other than s, p- or p states
C
          VALU = ZERO
C
        ELSE
C
C  ...find average R for MCDF orbital...
C
          RAV = RINT(I,I,1)
C
C  ...find effective Z of Coulomb orbital with same average R...
C
          CALL ZEFR(I,RAV,ZEFF)
C
C  ...interpolate among P. Mohr data...
C
          CALL FZALF(ZEFF,I,VALU)
C
C  ...scale as required...
C
          VALU = (ZEFF**4/XCL**3)*VALU/(XPI*DBLE(NP(I)**3))
C
          if(ktc(9).eq.1)
     x    write(iwrite,3030)np(i),nh(i),zeff,rav,allint,valu
C
        ENDIF
C
        SLFINT(I) = VALU
C
      ENDDO
C
C
      DO LEV = 1,NCF
        IF (KTC(9).EQ.1) WRITE (IWRITE,3000) LEV
        VPENG(LEV) = ZERO
        SFENG(LEV) = ZERO
        ENG = ZERO
        DO I = 1,NW
C
C  Calculate coefficient
C
          COEF = ZERO
          DO J = 1,NCF
            COEF = COEF+IQ(I,J)*(COUVEC(J,LEV)**2)
          ENDDO
          VPCONT = COEF*VPINT(I)
          SFCONT = COEF*SLFINT(I)
          CONT = VPCONT+SFCONT
          VPENG(LEV) = VPENG(LEV)+VPCONT
          SFENG(LEV) = SFENG(LEV)+SFCONT
          ENG = ENG+CONT
C
C  Print contributions if requested
C
          IF (KTC(9).EQ.1)
     +    WRITE (IWRITE,3010) NP(I),NH(I),COEF,VPINT(I),
     +                        VPCONT,SLFINT(I),SFCONT,CONT
        ENDDO
C
C  Print totals if requested
C
        IF (KTC(9).EQ.1) WRITE (IWRITE,3020) VPENG(LEV),SFENG(LEV),ENG
      ENDDO
C
 3000 FORMAT (/' Contribution of Q.E.D. to level',I4,' energy'//
     +' orbital   coeff.          v.p. integral    v.p. contrib.    s.',
     +'e. integral    s.e. contrib.    Q.E.D. contribution'/)
 3010 FORMAT (1X,1X,I2,A2,4X,E15.8,5(2X,E15.8))
 3020 FORMAT (44X,15('-'),19X,15('-'),2X,15('-')/44X,E15.8,19X,E15.8,2X,
     +E15.8)
 3030 format('Orbital',2x,i2,a2,3x,'zeff=',f8.4,3x,'rav=',f8.4,3x,
     x'v.p. int.=',e15.8,3x,'s.e. int.=',e15.8)
      END
C
C                             *******************
C
      SUBROUTINE QUAD(NGRID,RESULT)
C
C-----------------------------------------------------------------------
C
C  The value of RESULT is the integral of F(R) from
C  zero to infinity, where the values of R*F(R) are
C  tabulated in the array TA. The integral is computed by
C  use of Simpson's rule. The contribution of the interval
C  from 0 to the start of the Simpson's rule quadrature is
C  included by assuming that for small values of R the function
C  R*F(R) behaves like W*R**PX, where W is a constant which need
C  not be specified. The value of PX is obtained by comparing the
C  first two significant terms in TA.
C  The contribution of the tail of the function beyond the
C  last tabular point is assumed to be negligible.
C
C    No subroutines called.
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  Parameter variables
C
      DOUBLE PRECISION EPS35
      PARAMETER (EPS35=1.D-35)
      DOUBLE PRECISION ZERO
      PARAMETER (ZERO=0.D0)
      DOUBLE PRECISION ONE
      PARAMETER (ONE=1.D0)
      DOUBLE PRECISION TWO
      PARAMETER (TWO=2.D0)
      DOUBLE PRECISION THREE
      PARAMETER (THREE=3.D0)
      DOUBLE PRECISION FOUR
      PARAMETER (FOUR=4.D0)
      DOUBLE PRECISION THIRD
      PARAMETER (THIRD=ONE/THREE)
      INTEGER N11
      PARAMETER (N11=MXNP+10)
C
C  Argument variables
C
      DOUBLE PRECISION RESULT
      INTEGER NGRID
C
C  Local variables
C
      DOUBLE PRECISION COP,RPX,S1,S2
      DOUBLE PRECISION SUM1,SUM2
      INTEGER I,J,NP
C
C  Common variables
C
      DOUBLE PRECISION ACCY,C,EPH,H
      DOUBLE PRECISION RNT,Z
      INTEGER N,NCPRIN,NW1
      COMMON / DEF01  / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN
C
C  Common variables
C
      DOUBLE PRECISION TA(N11),TB(N11)
      COMMON / TATB   / TA,TB
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
C
C   Find the starting point for the integration. this is the point
C   where the integrand ta first becomes significant, and is chosen
C   to prevent dividing by zero.
C
      DO J = 1,NGRID
        IF (ABS(TA(J)).GT.EPS35) GOTO 10
      ENDDO
      RESULT = ZERO
      RETURN
C
C   Simpson's rule
C
   10 CONTINUE
C
      NP = NGRID-J+1
      IF (MOD(NP,2).EQ.0) THEN
        NP = NP+1
        TA(NGRID+1) = ZERO
      ENDIF
C
      S1 = ZERO
      DO I = 1,NP,2
        S1 = S1+TA(J+I-1)
      ENDDO
      S1 = S1*TWO
C
      S2 = ZERO
      DO I = 2,NP,2
        S2 = S2+TA(J+I-1)
      ENDDO
      S2 = S2*FOUR
C
      SUM2 = S1+S2
      SUM2 = SUM2-(TA(J)+TA(J+NP-1))
      SUM2 = SUM2*H*THIRD
C
C   Add the contribution from 0 to R(J), plus the contribution
C   to Simpson's rule from TA(J).
C
      COP = TA(J+1)/TA(J)
      IF (COP.LE.ONE) THEN
        RPX = ZERO
      ELSE
        RPX = H/LOG(COP)
      ENDIF
C
      SUM1 = TA(J)*RPX
C
      RESULT = SUM1+SUM2
C
      END
C
C                             *******************
C
      SUBROUTINE QUARTZ(I)
C-----------------------------------------------------------------------
C
C  This subroutine calculates the CPU time which has been used.
C
C  I=-1  used to initialise the time stored in TIME1
C  I= 0  writes out time used in seconds since last call
C  I= 2  returns in TIME2 the time used in seconds since last call
C
C-----------------------------------------------------------------------
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON / CASIO  / TIME1,TIME2
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
C-----------------------------------------------------------------------
      IF (I.EQ.0 .OR. I.EQ.2) THEN
C
        call cpu_time(time2)
        time2=time2-time1
C
        IF (I.EQ.0) THEN
          IF (IWRITE.GT.0) WRITE (IWRITE,3000) TIME2
          IF (IPUNCH.GT.0) WRITE (IPUNCH,3000) TIME2
        ENDIF
C
        TIME1 = TIME1+TIME2
        RETURN
C
      ENDIF
C-----------------------------------------------------------------------
      IF (I.EQ.-1) THEN
        call cpu_time(time1)
        RETURN
      ENDIF
C-----------------------------------------------------------------------
C
C  Error
C
C-----------------------------------------------------------------------
      IF (IWRITE.GT.0) WRITE (IWRITE,3010) I
      IF (IPUNCH.GT.0) WRITE (IPUNCH,3010) I
      STOP
C-----------------------------------------------------------------------
 3000 FORMAT (/' Time used = ',F10.2,' sec')
 3010 FORMAT (/' ERROR in QUARTZ.'/                                     !
     +' Routine was called with parameter I = ',I3/                     !
     +' The parameter must be -1, 0 or 2.'/' Code is stopping.')
      END
C
C                             *******************
C
      SUBROUTINE RAT1(XX,IRAT)
C
C-----------------------------------------------------------------------
C
C   This subroutine returns a rational approximation to the number XX.
C   It determines whether surd form is better and attempts to factorise
C   a surd.
C
C   XX =  ( IRAT(1)/IRAT(2) ) * SQRT ( IRAT(3)/IRAT(4) )
C
C   Subroutines called : RAT2
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
C
C  Parameter variables
C
      DOUBLE PRECISION ONE
      PARAMETER (ONE=1.D0)
C
C  Argument variables
C
      DOUBLE PRECISION XX
      INTEGER IRAT(4)
C
C  Local variables
C
      DOUBLE PRECISION XX1,XX2
      INTEGER DEN1,DEN2,I,ISIGNX
      INTEGER ITEST,J,NUM1,NUM2
      INTEGER NX,NXX,NY,NYY
      INTEGER PRIME(8),XSTO(8),YSTO(8)
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      DATA PRIME/2,3,5,7,11,13,17,19/
C-----------------------------------------------------------------------
      ISIGNX = INT(SIGN(ONE,XX))
C
      XX1 = ABS(XX)
      CALL RAT2(XX1,NUM1,DEN1)
C
      XX2 = XX1*XX1
      CALL RAT2(XX2,NUM2,DEN2)
C
      IF (NUM2.GE.NUM1 .AND. NUM1.GT.0) THEN
        NUM2 = 0
      ENDIF
C
      IF (NUM1.GT.NUM2 .AND. NUM2.GT.0) THEN
        NUM1 = 0
      ENDIF
C
      IF (NUM1.EQ.0 .AND. NUM2.EQ.0) THEN
        IRAT(1) = 0
        IRAT(2) = 1
        IRAT(3) = 1
        IRAT(4) = 1
        RETURN
      ENDIF
C
      IF (NUM2.EQ.0) THEN
        IRAT(1) = SIGN(NUM1,ISIGNX)
        IRAT(2) = DEN1
        IRAT(3) = 1
        IRAT(4) = 1
        RETURN
      ENDIF
C
      IF (NUM1.EQ.0) THEN
C
        DO I = 1,8
          XSTO(I) = 0
          YSTO(I) = 0
        ENDDO
C
        NX = NUM2
C
        DO I = 1,8
          IF (NX.EQ.1) GOTO 20
          ITEST = PRIME(I)
          DO J = 1,8
            IF (MOD(NX,ITEST).NE.0) GOTO 10
            NX = NX/ITEST
            XSTO(I) = XSTO(I)+1
          ENDDO
   10     CONTINUE
        ENDDO
C
   20   CONTINUE
        NXX = 1
C
        DO I = 1,8
   30     CONTINUE
          IF (XSTO(I).LE.1) GOTO 40
          NXX = NXX*PRIME(I)
          XSTO(I) = XSTO(I)-2
          GOTO 30
   40     CONTINUE
          IF (XSTO(I).EQ.1) NX = NX*PRIME(I)
        ENDDO
C
        NY = DEN2
C
        DO I = 1,8
          IF (NY.EQ.1) GOTO 60
          ITEST = PRIME(I)
          DO J = 1,8
            IF (MOD(NY,ITEST).NE.0) GOTO 50
            NY = NY/ITEST
            YSTO(I) = YSTO(I)+1
          ENDDO
   50     CONTINUE
        ENDDO
C
   60   CONTINUE
        NYY = 1
C
        DO I = 1,8
   70     CONTINUE
          IF (YSTO(I).LE.1) GOTO 80
          NYY = NYY*PRIME(I)
          YSTO(I) = YSTO(I)-2
          GOTO 70
   80     CONTINUE
          IF (YSTO(I).EQ.1) NY = NY*PRIME(I)
        ENDDO
C
        IRAT(1) = SIGN(NXX,ISIGNX)
        IRAT(2) = NYY
        IRAT(3) = NX
        IRAT(4) = NY
        RETURN
C
      ENDIF
C
      END
C
C                             *******************
C
      SUBROUTINE RAT2(XX,NUM,DEN)
C
C-----------------------------------------------------------------------
C
C   This routine returns the rational approximation to XX as NUM/DEN.
C
C   No routines called.
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
C
C  Parameter variables
C
      DOUBLE PRECISION ONE
      PARAMETER (ONE=1.D0)
      DOUBLE PRECISION DMAX
      PARAMETER (DMAX=1.D5)
C
C  Argument variables
C
      DOUBLE PRECISION XX
      INTEGER DEN,NUM
C
C  Local variables
C
      DOUBLE PRECISION P,X,YY
      INTEGER D(15),I,K,NUMSIG
      INTEGER T
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
      X = ABS(XX)
      K = 1
      D(K) = INT(X)
      X = X-D(K)
      P = ONE/DMAX
C
   10 CONTINUE
      IF (X.LE.P) GOTO 20
      IF (K.EQ.15) GOTO 20
      X = ONE/X
      K = K+1
      D(K) = INT(X)
      X = X-D(K)
      P = P*D(K)
      GOTO 10
C
   20 CONTINUE
      NUM = D(K)
      DEN = 1
      DO I = K-1,1,-1
        T = NUM
        NUM = D(I)*NUM+DEN
        DEN = T
      ENDDO
C
      YY = ONE
      NUMSIG = NINT(SIGN(YY,XX))
      NUM = NUM*NUMSIG
C
      END
C
C                             *******************
C
      SUBROUTINE READA(IO4,ICOUL,IBREIT)
C
C-----------------------------------------------------------------------
C
C Routine for checking the angular dump.
C
C  IO4 - stream for MCP/MCBP coefficients.
C
C  ICOUL = 0  on exit if no MCP coefficients are read
C  ICOUL = 1  on exit if    MCP coefficients are read
C
C  IBREIT = 0  on exit if no MCBP coefficients are read
C  IBREIT = 1  on exit if    MCBP coefficients are read
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  Argument variables
C
      INTEGER IBREIT,ICOUL,IO4
C
C  Local variables
C
      DOUBLE PRECISION COEF
      INTEGER I,ISTORE,ITYP,ITYPE
      INTEGER JA,JAP,JB,JBP
      INTEGER NCFP,NUMB,NUMBEL,NUMBT
      INTEGER NUMC,NUMCEL,NUMCT,NWP
C
C  Common variables
C
      INTEGER IPUNCH,IREAD,IWRITE
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
C
C  Common variables
C
      INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF
      INTEGER NP(MXNW),NW
      COMMON / ORB04  / NW,NCF,NP,NAK,IQ
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
      WRITE (IWRITE,3030)
      PRINT 3030
C
      NUMCT = 0
      NUMBT = 0
      NUMCEL = 0
      NUMBEL = 0
C-----------------------------------------------------------------------
C
C   Position stream IO4 which reads in MCP/MCBP coefficients.
C
C   Check that NW and NCF are consistent with the dump.
C
      REWIND IO4
      READ (IO4)
      READ (IO4) NCFP,NWP
      IF (NW.NE.NWP .OR. NCF.NE.NCFP) GOTO 40
      DO I = 1,7
        READ (IO4)
      ENDDO
C-----------------------------------------------------------------------
      DO JA = 1,NCF
        DO JB = JA,NCF
C
C  Read coefficients for configuration pair JA,JB.
C
          READ (IO4) JAP,JBP
          IF (JA.NE.JAP .OR. JB.NE.JBP) GOTO 30
          NUMC = 0
          NUMB = 0
C
C   Coefficients stored as : ISTORE,ITYP,COEF
C
   10     CONTINUE
          READ (IO4) ISTORE,ITYP,COEF
          IF (ISTORE.EQ.0) GOTO 20
C
          ITYPE = ABS(ITYP)
C
          IF (ITYPE.LT.7) THEN
            NUMB = NUMB+1
            IF (ITYP.LT.0) THEN
              NUMBEL = NUMBEL+1
            ENDIF
          ELSE
            NUMC = NUMC+1
            IF (ITYP.LT.0) THEN
              NUMCEL = NUMCEL+1
            ENDIF
          ENDIF
C
          GOTO 10
C
   20     CONTINUE
          NUMCT = NUMCT+NUMC
          NUMBT = NUMBT+NUMB
C
        ENDDO
      ENDDO
C
      REWIND IO4
C
      WRITE (IWRITE,3020) NUMCT,NUMCEL,NUMBT,NUMBEL
      PRINT 3020,NUMCT,NUMCEL,NUMBT,NUMBEL
C
      IF (NUMCT.EQ.0) THEN
        ICOUL = 0
      ELSE
        ICOUL = 1
      ENDIF
C
      IF (NUMBT.EQ.0) THEN
        IBREIT = 0
      ELSE
        IBREIT = 1
      ENDIF
C
      RETURN
C-----------------------------------------------------------------------
C
C  Error messages.
C
   30 CONTINUE
      WRITE (IWRITE,3000)
      WRITE (IPUNCH,3000)
      PRINT 3000
      STOP
C
   40 CONTINUE
      WRITE (IWRITE,3010)
      WRITE (IPUNCH,3010)
      PRINT 3010
      STOP
C-----------------------------------------------------------------------
 3000 FORMAT (/                                                         !
     +' STOPPING in READA - incorrect configuration labels on dump')
 3010 FORMAT (/' STOPPING in READA - incorrect MCP/MCBP dump')
 3020 FORMAT (/1X,I7,' MCP  (Coulomb) angular coefficients read'/1X,I7, !
     +' core (Coulomb) angular coefficients read'//1X,I7,               !
     +' MCBP (Breit)   angular coefficients read'/1X,I7,                !
     +' core (Breit)   angular coefficients read')
 3030 FORMAT (/' >>>> routine READA called : read angular coefficients')
      END
C
C                             *******************
C
      SUBROUTINE REORDR(NST)
C
C-----------------------------------------------------------------------
C
C  Routine to sort CSF into order of descending total J.
C  A linked list sorting method is used.
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  Argument variables
C
      INTEGER NST
C
C  Local variables
C
      INTEGER I,ICF,IFIRST
      INTEGER IPOS(MXNC),J,K,L
      INTEGER M,MCHOP(MXNW),MCUP(10)
      INTEGER MQ(MXNW),MQS(3,MXNW),MTJPO,N
      INTEGER NEXT(MXNC),NST1
C
C  Common variables
C
      INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF
      INTEGER NP(MXNW),NW
      COMMON / ORB04  / NW,NCF,NP,NAK,IQ
C
C  Common variables
C
      INTEGER ICHOP(MXNW,MXNC),IEXC
      INTEGER JCUP(10,MXNC),JQS(3,MXNW,MXNC)
      COMMON / ORB06  / JQS,JCUP,ICHOP,IEXC
C
C  Common variables
C
      INTEGER ISPAR(MXNC),ITJPO(MXNC)
      COMMON / ORB07  / ITJPO,ISPAR
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
C
C  Exit if only one member in list.
C
      IF (NST.EQ.NCF) RETURN
C
C  Set up linked list giving desired order of CSF.
C
      NEXT(NST) = 0
      IFIRST = NST
      NST1 = NST+1
      DO ICF = NST1,NCF
        M = IFIRST
        L = 0
   10   CONTINUE
        IF (ITJPO(ICF).LT.ITJPO(M)) GOTO 20
        IF (L.NE.0) GOTO 30
        NEXT(ICF) = IFIRST
        IFIRST = ICF
        GOTO 40
C
   20   CONTINUE
        L = M
        M = NEXT(L)
        IF (M.NE.0) GOTO 10
   30   CONTINUE
        NEXT(ICF) = NEXT(L)
        NEXT(L) = ICF
   40   CONTINUE
      ENDDO
C
C  Invert list to give list of positions of CSF.
C
      L = IFIRST
      DO I = NST,NCF
        IPOS(L) = I
        L = NEXT(L)
      ENDDO
C
C  Reorder CSF.
C
      DO I = NST,NCF
        L = IPOS(I)
        IF (L.EQ.I) GOTO 60
        DO J = 1,NW
          DO M = 1,3
            MQS(M,J) = JQS(M,J,I)
          ENDDO
          MQ(J) = IQ(J,I)
          MCHOP(J) = ICHOP(J,I)
        ENDDO
        MTJPO = ITJPO(I)
        DO J = 1,10
          MCUP(J) = JCUP(J,I)
        ENDDO
   50   CONTINUE
        K = L
        DO J = 1,NW
          DO M = 1,3
            N = MQS(M,J)
            MQS(M,J) = JQS(M,J,K)
            JQS(M,J,K) = N
          ENDDO
          N = MQ(J)
          MQ(J) = IQ(J,K)
          IQ(J,K) = N
          N = MCHOP(J)
          MCHOP(J) = ICHOP(J,K)
          ICHOP(J,K) = N
        ENDDO
        N = MTJPO
        MTJPO = ITJPO(K)
        ITJPO(K) = N
        DO J = 1,10
          N = MCUP(J)
          MCUP(J) = JCUP(J,K)
          JCUP(J,K) = N
        ENDDO
        L = IPOS(K)
        IPOS(K) = K
        IF (L.NE.I) GOTO 50
        DO J = 1,NW
          DO M = 1,3
            JQS(M,J,I) = MQS(M,J)
          ENDDO
          IQ(J,I) = MQ(J)
          ICHOP(J,I) = MCHOP(J)
        ENDDO
        ITJPO(I) = MTJPO
        DO J = 1,10
          JCUP(J,I) = MCUP(J)
        ENDDO
        IPOS(I) = I
   60   CONTINUE
      ENDDO
C
      END
C
C                             *******************
C
      FUNCTION RINT(I,J,K)
C
C-----------------------------------------------------------------------
C
C   The value of this function is the integral of the function
C
C       R**K  *  ( PI(R)*PJ(R) + QI(R)*QJ(R) )
C
C   For example, when  I = J  and  K = 1, this gives
C   the mean radius for orbital I.
C
C   Subroutines called : QUAD
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      DOUBLE PRECISION RINT
      INCLUDE 'grasp0.inc'
C
C  Parameter variables
C
      INTEGER N11
      PARAMETER (N11=MXNP+10)
C
C  Argument variables
C
      INTEGER I,J,K
C
C  Local variables
C
      DOUBLE PRECISION RESULT
      INTEGER I1,J1,K1,L
      INTEGER NGRID
C
C  Common variables
C
      DOUBLE PRECISION RGRID(MXNP)
      COMMON / GRID   / RGRID
C
C  Common variables
C
      INTEGER MPOIN(MXNW),MPOS(MXNW)
      COMMON / PATY   / MPOIN,MPOS
C
C  Common variables
C
      DOUBLE PRECISION TA(N11),TB(N11)
      COMMON / TATB   / TA,TB
C
C  Common variables
C
      DOUBLE PRECISION PF(MXNG),QF(MXNG)
      COMMON / WAVE   / PF,QF
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
C
C   Tabulate integrand as required for subroutine QUAD
C
      NGRID = MIN(MPOIN(I),MPOIN(J))
      I1 = MPOS(I)
      J1 = MPOS(J)
      K1 = K+1
      IF (ABS(K1).GT.1) GOTO 40
      IF (K1) 10,20,30
C
   10 CONTINUE
      DO L = 1,NGRID
        TA(L) = (PF(I1)*PF(J1)+QF(I1)*QF(J1))/RGRID(L)
        I1 = I1+1
        J1 = J1+1
      ENDDO
      GOTO 50
C
   20 CONTINUE
      DO L = 1,NGRID
        TA(L) = PF(I1)*PF(J1)+QF(I1)*QF(J1)
        I1 = I1+1
        J1 = J1+1
      ENDDO
      GOTO 50
C
   30 CONTINUE
      DO L = 1,NGRID
        TA(L) = RGRID(L)*(PF(I1)*PF(J1)+QF(I1)*QF(J1))
        I1 = I1+1
        J1 = J1+1
      ENDDO
      GOTO 50
C
   40 CONTINUE
      DO L = 1,NGRID
        TA(L) = (RGRID(L)**K1)*(PF(I1)*PF(J1)+QF(I1)*QF(J1))
        I1 = I1+1
        J1 = J1+1
      ENDDO
C
C   Call subroutine QUAD for integration
C
   50 CONTINUE
      CALL QUAD(NGRID,RESULT)
      RINT = RESULT
C
      END
C
C                             *******************
C
      FUNCTION RINTI(J,K)
C
C-----------------------------------------------------------------------
C
C   The value of this function is the one-electron integral
C   I(J,K) for orbitals J,K.
C   A central difference formula is used to approximate the
C   derivative.
C
C   Subroutine called : QUAD
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      DOUBLE PRECISION RINTI
      INCLUDE 'grasp0.inc'
C
C  Parameter variables
C
      DOUBLE PRECISION XXA
      PARAMETER (XXA=672.D0)
      DOUBLE PRECISION XXB
      PARAMETER (XXB=-168.D0)
      DOUBLE PRECISION XXC
      PARAMETER (XXC=32.D0)
      DOUBLE PRECISION XXD
      PARAMETER (XXD=-3.D0)
      DOUBLE PRECISION XXE
      PARAMETER (XXE=1.D0/840.D0)
      INTEGER N11
      PARAMETER (N11=MXNP+10)
C
C  Argument variables
C
      INTEGER J,K
C
C  Local variables
C
      DOUBLE PRECISION CA,CB,CC,CD
      DOUBLE PRECISION CE,PD(MXNP),PJ(MXNP)
      DOUBLE PRECISION PK(MXNP),QD(MXNP),QJ(MXNP)
      DOUBLE PRECISION QK(MXNP),RESULT,WA,WB
      INTEGER I,IJ,IK,M
      INTEGER MM,NGRID,NN
C
C  Common variables
C
      DOUBLE PRECISION HALF,ONE,TEN,TENTH
      DOUBLE PRECISION THREE,TWO,ZERO
      COMMON / CONS   / ZERO,HALF,TENTH,ONE,TWO,THREE,TEN
C
C  Common variables
C
      DOUBLE PRECISION ACCY,C,EPH,H
      DOUBLE PRECISION RNT,Z
      INTEGER N,NCPRIN,NW1
      COMMON / DEF01  / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN
C
C  Common variables
C
      DOUBLE PRECISION RGRID(MXNP)
      COMMON / GRID   / RGRID
C
C  Common variables
C
      INTEGER IPUNCH,IREAD,IWRITE
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
C
C  Common variables
C
      DOUBLE PRECISION ZZ(MXNP)
      COMMON / NPOT   / ZZ
C
C  Common variables
C
      INTEGER ITC(50)
      COMMON / OPT01  / ITC
C
C  Common variables
C
      CHARACTER*2 NH(MXNW)
      COMMON / ORB00  / NH
C
C  Common variables
C
      INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF
      INTEGER NP(MXNW),NW
      COMMON / ORB04  / NW,NCF,NP,NAK,IQ
C
C  Common variables
C
      INTEGER MPOIN(MXNW),MPOS(MXNW)
      COMMON / PATY   / MPOIN,MPOS
C
C  Common variables
C
      DOUBLE PRECISION TA(N11),TB(N11)
      COMMON / TATB   / TA,TB
C
C  Common variables
C
      DOUBLE PRECISION PF(MXNG),QF(MXNG)
      COMMON / WAVE   / PF,QF
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
C
C  Stop if orbitals J and K have different kappa values
C
      if(j.eq.0.or.k.eq.0)stop 'rinti j/k=0'
      IF (NAK(J).NE.NAK(K)) THEN
        WRITE (IWRITE,3000)
        WRITE (IPUNCH,3000)
        STOP
      ENDIF
C
C  Copy out orbital K
C
      IK = MPOS(K)
      NGRID = MPOIN(K)
      DO I = 1,NGRID
        PK(I) = PF(IK)
        QK(I) = QF(IK)
        IK = IK+1
      ENDDO
C
      IF (NGRID.LT.N) THEN
        DO I = NGRID+1,N
          PK(I) = ZERO
          QK(I) = ZERO
        ENDDO
      ENDIF
C
C  Copy out orbital J
C
      IJ = MPOS(J)
      NGRID = MPOIN(J)
      DO I = 1,NGRID
        PJ(I) = PF(IJ)
        QJ(I) = QF(IJ)
        IJ = IJ+1
      ENDDO
C
      IF (NGRID.LT.N) THEN
        DO I = NGRID+1,N
          PJ(I) = ZERO
          QJ(I) = ZERO
        ENDDO
      ENDIF
C
C  Calculate derivative
C  --------------------
C  Set derivative zero near origin
C  First M points
C
      M = 4
      DO I = 1,M
        PD(I) = ZERO
        QD(I) = ZERO
      ENDDO
C
C  Use central difference formula
C  for points M+1 to N-M
C
      CE = XXE*C/H
      CA = XXA*CE
      CB = XXB*CE
      CC = XXC*CE
      CD = XXD*CE
C
      MM = M+1
      NN = N-M
      DO I = MM,NN
        PD(I) = CA*(PK(I+1)-PK(I-1))+CB*(PK(I+2)-PK(I-2))+CC*(PK(I+3)-PK!
     +(I-3))+CD*(PK(I+4)-PK(I-4))
        QD(I) = CA*(QK(I+1)-QK(I-1))+CB*(QK(I+2)-QK(I-2))+CC*(QK(I+3)-QK!
     +(I-3))+CD*(QK(I+4)-QK(I-4))
      ENDDO
C
C  Form the integrand for QUAD
C  ---------------------------
C
      WA = C*C
      WA = WA+WA
      WB = C*NAK(K)
C
C  Set first M points of integrand to zero
C  QUAD will use a power series to estimate this contribution
C
      DO I = 1,M
        TA(I) = ZERO
      ENDDO
C
C     NN=MIN(NN,NGRID)
      DO I = MM,NN
        TA(I) = QJ(I)*(-(WA*RGRID(I)+ZZ(I))*QK(I)+WB*PK(I)+PD(I))-PJ(I)*!
     +(ZZ(I)*PK(I)-WB*QK(I)+QD(I))
      ENDDO
C
      CALL QUAD(NN,RESULT)
      RINTI = RESULT
C
      IF (ITC(26).EQ.1) THEN
        WRITE (IWRITE,3010) NP(J),NH(J),NP(K),NH(K),RINTI
      ENDIF
C
 3000 FORMAT (/                                                         !
     +' Attempt to calculate I(J,K) for orbitals with different kappas')
 3010 FORMAT (' I (',I2,A2,',',I2,A2,') = ',1P,E17.9)
      END
C
C                             *******************
C
      SUBROUTINE RKCO1(NPEEL,JLIST,NQ1,NQ2,IDQ,JA1,JB1,JA2,JB2)
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  Parameter variables
C
      INTEGER NPLX
      PARAMETER (NPLX=14)
C
C  Argument variables
C
      INTEGER IDQ,JA1,JA2,JB1
      INTEGER JB2,JLIST(NPLX),NPEEL
      INTEGER NQ1(MXNW),NQ2(MXNW)
C
C  Local variables
C
      INTEGER J,JWW,NDQ
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
      IDQ = 0
C
      JA1 = 0
      JB1 = 0
      JA2 = 0
      JB2 = 0
C
      DO JWW = 1,NPEEL
C
        J = JLIST(JWW)
        NDQ = NQ1(J)-NQ2(J)
C
        IF (ABS(NDQ).GT.2) THEN
          IDQ = 99
          RETURN
        ENDIF
C
        IF (NDQ.EQ.0) GOTO 10
C
        IF (NDQ.GT.0) THEN
C
          IF (NDQ.EQ.1) THEN
C
            IF (JA1.GT.0) THEN
              JB1 = JWW
            ELSE
              JA1 = JWW
            ENDIF
C
            IDQ = IDQ+1
C
          ELSE
C
            JA1 = JWW
            IDQ = IDQ+2
C
          ENDIF
C
        ELSE
C
          IF (NDQ.EQ.-1) THEN
C
            IF (JA2.GT.0) THEN
              JB2 = JWW
            ELSE
              JA2 = JWW
            ENDIF
C
            IDQ = IDQ+1
C
          ELSE
C
            JA2 = JWW
            IDQ = IDQ+2
C
          ENDIF
C
        ENDIF
C
   10   CONTINUE
      ENDDO
C
      END
C
C                             *******************
C
      SUBROUTINE RKCO2G(KWA,NPEEL,JLIST,NQ1,NQ2,JT1,JT2,IWRITE,IBUG2)
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  Parameter variables
C
      INTEGER NPLX
      PARAMETER (NPLX=14)
C
C  Argument variables
C
      INTEGER IBUG2,IWRITE,JLIST(NPLX),JT1
      INTEGER JT2,KWA,NPEEL
      INTEGER NQ1(MXNW),NQ2(MXNW)
C
C  Local variables
C
      INTEGER IB1,IB2,JA1,JA2
      INTEGER JB1,JB2,JT3,K1
      INTEGER KW
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
      DO KW = KWA,NPEEL
C
        K1 = JLIST(KW)
        IF (NQ1(K1)*NQ2(K1).EQ.0) GOTO 10
C
        JA1 = JT1
        JA2 = JT2
        JB1 = KW
        JB2 = KW
C
C  Interchange JA1 and JB1 if necessary.
C
        IF (JA1.GT.JB1) THEN
          JT3 = JB1
          JB1 = JA1
          JA1 = JT3
        ELSE
          IF (JA1.EQ.JB1) THEN
            IB1 = JLIST(JB1)
            IF (NQ1(IB1).LE.1) GOTO 10
          ENDIF
        ENDIF
C
C  Interchange JA2 and JB2 if necessary
C
        IF (JA2.GT.JB2) THEN
          JT3 = JB2
          JB2 = JA2
          JA2 = JT3
        ELSE
          IF (JA2.EQ.JB2) THEN
            IB2 = JLIST(JB2)
            IF (NQ2(IB2).LE.1) GOTO 10
          ENDIF
        ENDIF
C
        IF (IBUG2.EQ.1) WRITE (IWRITE,3000) JA1,JB1,JA2,JB2
        CALL CORG(JA1,JB1,JA2,JB2)
C
   10   CONTINUE
      ENDDO
C-----------------------------------------------------------------------
 3000 FORMAT (//10X,'  JA1 =',I4,4X,'  JB1 =',I4,4X,'  JA2 =',I4,       !
     +'  JB2 =',I4)
      END
C
C                             *******************
C
      SUBROUTINE RKCO3G(JT1,JT2,IWRITE,IBUG2,JJQ1,JJQ2,JLIS,JC1S,JC2S)
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  Parameter variables
C
      INTEGER NPLX
      PARAMETER (NPLX=14)
C
C  Argument variables
C
      INTEGER IBUG2,IWRITE,JC1S(NPLX)
      INTEGER JC2S(NPLX),JJQ1(3,MXNW)
      INTEGER JJQ2(3,MXNW),JLIS(NPLX),JT1
      INTEGER JT2
C
C  Local variables
C
      INTEGER I,I1,II,IJ
      INTEGER IJW,IM,JA1,JA2
      INTEGER JB1,JB2,JT3,KW
      INTEGER NPEELM
C
C  Common variables
C
      INTEGER JJC1(NPLX),JJC2(NPLX)
      COMMON / ANG10  / JJC1,JJC2
C
C  Common variables
C
      INTEGER JLIST(NPLX),KLIST(MXNW),NCORE,NPEEL
      COMMON / ANG13  / JLIST,KLIST,NPEEL,NCORE
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
      DO KW = 1,NCORE
C
        IJW = KLIST(KW)
        DO I = 1,NPEEL
          IJ = JLIST(I)
          IF (IJW.LT.IJ) GOTO 10
        ENDDO
        I = NPEEL+1
        GOTO 20
C
   10   CONTINUE
        IM = NPEEL-I+1
        DO II = 1,IM
          JLIST(NPEEL+2-II) = JLIST(NPEEL+1-II)
          IF (NPEEL.EQ.II) GOTO 20
          JJC1(NPEEL+1-II) = JJC1(NPEEL-II)
          JJC2(NPEEL+1-II) = JJC2(NPEEL-II)
        ENDDO
C
   20   CONTINUE
        IF (I.LT.3) THEN
          I1 = JLIST(1)
          JJC1(1) = JJQ1(3,I1)
          JJC2(1) = JJQ2(3,I1)
        ELSE
          JJC1(I-1) = JJC1(I-2)
          JJC2(I-1) = JJC2(I-2)
        ENDIF
C
        JLIST(I) = IJW
        JA1 = JT1
        IF (JT1.GE.I) JA1 = JA1 + 1
        JB1 = I
        JA2 = JT2
        IF (JT2.GE.I) JA2 = JA2 + 1
        JB2 = I
        IF (JA1.GT.JB1) THEN
          JT3 = JB1
          JB1 = JA1
          JA1 = JT3
        ENDIF
C
        IF (JA2.GT.JB2) THEN
          JT3 = JB2
          JB2 = JA2
          JA2 = JT3
        ENDIF
C
        NPEEL = NPEEL+1
        IF (IBUG2.EQ.1) THEN
          WRITE (IWRITE,3000) JA1,JB1,JA2,JB2,KW,KLIST(KW)
          WRITE (IWRITE,3010) (JLIST(I),I=1,NPEEL)
          NPEELM = NPEEL-1
          WRITE (IWRITE,3020) (JJC1(I),I=1,NPEELM)
          WRITE (IWRITE,3030) (JJC2(I),I=1,NPEELM)
        ENDIF
C
        CALL CORG(JA1,JB1,JA2,JB2)
        NPEEL = NPEEL-1
C
C  Reset the arrays JLIST, JJC1 and JJC2
C
        DO I = 1,NPEEL
          JLIST(I) = JLIS(I)
        ENDDO
        NPEELM = NPEEL-1
        DO I = 1,NPEELM
          JJC1(I) = JC1S(I)
          JJC2(I) = JC2S(I)
        ENDDO
C
      ENDDO
C-----------------------------------------------------------------------
 3000 FORMAT (//10X,'  JA1 =',I4,4X,'  JB1 =',I4,4X,'  JA2 =',I4,       !
     +'  JB2 =',I4,'  K2 =',I4,'  KW =',I4)
 3010 FORMAT (' JLIST : ',15I4)
 3020 FORMAT (' JJC1  : ',15I4)
 3030 FORMAT (' JJC2  : ',15I4)
      END
C
C                             *******************
C
      SUBROUTINE RKCOG(JA,JB)
C
C-----------------------------------------------------------------------
C
C  Configurations : JA, JB
C
C  Analyse the tables of quantum numbers set in the common blocks
C  ANG10, ANG11, ANG12, ANG13 to determine all possible sets of
C  interacting orbitals which give a non-vanishing 2-electron matrix
C  element, and initiate the calculation of coefficients.
C
C  The following conventions are in force -
C
C   1. labels 1,2 refer to L, R sides of matrix element respectively.
C
C   2. pointers:
C      JA1, JB1, JA2, JB2 point to the JLIST array of active orbitals.
C      IA1, IB1, IA2, IB2 point to the complete list of orbitals.
C
C  Subroutines called:  COR,CORD,SETUP,VIJOUT,RKCO1,RKCO2,RKCO3
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  Parameter variables
C
      INTEGER NPLX
      PARAMETER (NPLX=14)
C
C  Argument variables
C
      INTEGER JA,JB
C
C  Local variables
C
      INTEGER I,IDQ,IPCA,IT1
      INTEGER IT2,J,JA1,JA2
      INTEGER JB1,JB2,JC1S(NPLX)
      INTEGER JC2S(NPLX),JLIS(NPLX),JT1,JT2
      INTEGER K1,KLAST,KW1,KW2
      INTEGER KWA,NPEELM
C
C  Common variables
C
      INTEGER JJC1(NPLX),JJC2(NPLX)
      COMMON / ANG10  / JJC1,JJC2
C
C  Common variables
C
      INTEGER NQ1(MXNW),NQ2(MXNW)
      COMMON / ANG11  / NQ1,NQ2
C
C  Common variables
C
      INTEGER JJQ1(3,MXNW),JJQ2(3,MXNW)
      COMMON / ANG12  / JJQ1,JJQ2
C
C  Common variables
C
      INTEGER JLIST(NPLX),KLIST(MXNW),NCORE,NPEEL
      COMMON / ANG13  / JLIST,KLIST,NPEEL,NCORE
C
C  Common variables
C
      INTEGER IBUG1,IBUG2,IBUG3,IBUG4
      INTEGER IBUG5,IBUG6
      COMMON / DEBUG  / IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6
C
C  Common variables
C
      INTEGER IPUNCH,IREAD,IWRITE
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
C
C  Common variables
C
      INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF
      INTEGER NP(MXNW),NW
      COMMON / ORB04  / NW,NCF,NP,NAK,IQ
C
C  Common variables
C
      INTEGER ISPAR(MXNC),ITJPO(MXNC)
      COMMON / ORB07  / ITJPO,ISPAR
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
      IF (ITJPO(JA).NE.ITJPO(JB)) RETURN
      CALL SETUP(JA,JB,IWRITE,IBUG2)
      IF (IBUG2.EQ.1) CALL VIJOUT(JA,JB,IWRITE)
C
      IF (IBUG2.EQ.1) THEN
        WRITE (IWRITE,3000) NW,NCF,JA,JB
        WRITE (IWRITE,3010) (ITJPO(I),I=1,NCF)
        WRITE (IWRITE,3020) (ISPAR(I),I=1,NCF)
        DO I = 1,NW
          WRITE (IWRITE,3030) (IQ(I,J),J=1,NCF)
        ENDDO
        WRITE (IWRITE,3040) NPEEL,NCORE
        WRITE (IWRITE,3050) (JLIST(I),I=1,NPEEL)
        IF (NPEEL.GT.1) THEN
          NPEELM = NPEEL-1
          WRITE (IWRITE,3060) (JJC1(I),I=1,NPEELM)
          WRITE (IWRITE,3070) (JJC2(I),I=1,NPEELM)
        ENDIF
      ENDIF
C-----------------------------------------------------------------------
C
C   1.0 Analyse peel shell interactions
C
C   1.1 Analyse electron distribution in peel.
C      (The full procedure is needed only if the number of peel
C       orbitals NPEEL >= 2)
C
C-----------------------------------------------------------------------
      IF (NW.LT.1) GOTO 50
      IF (NPEEL.EQ.0) GOTO 40
      IF (NPEEL.EQ.1) GOTO 20
C-----------------------------------------------------------------------
C
C   Find differences in occupations, NDQ, for each peel orbital in turn
C   and use it to set up labels of active orbitals, maintaining the
C   convention JA1 <= JB1, JA2 <= JB2.
C
C-----------------------------------------------------------------------
      CALL RKCO1(NPEEL,JLIST,NQ1,NQ2,IDQ,JA1,JB1,JA2,JB2)
C-----------------------------------------------------------------------
C
C   1.2 Calculate coefficients for all possible sets of active shells.
C
C       There are 4 cases, depending on the value of IDQ, the sum of
C       the absolute differences NDQ -
C
C   1.2.1   IDQ > 4 - matrix element null
C
C-----------------------------------------------------------------------
      IF (IDQ.GT.4) RETURN
C-----------------------------------------------------------------------
C
C   1.2.2   IDQ = 4 - matrix element uniquely defined
C
C-----------------------------------------------------------------------
      IF (IDQ.EQ.4) THEN
        IF (JB1.EQ.0) JB1 = JA1
        IF (JB2.EQ.0) JB2 = JA2
        IF (IBUG2.EQ.1) WRITE (IWRITE,3090) JA1,JB1,JA2,JB2
        CALL CORG(JA1,JB1,JA2,JB2)
        RETURN
      ENDIF
C-----------------------------------------------------------------------
C
C   1.2.3   IDQ = 2 - one orbital fixed each side.
C                     Include all possible spectators.
C
C           IDQ = 0 - for a matrix element off-diagonal in coupling.
C                     You must sum over all pairs of orbitals excluding
C                     core-core.
C
C-----------------------------------------------------------------------
      IF (IDQ.EQ.2) THEN
        KLAST = 1
      ELSE
        IF (IDQ.NE.0) GOTO 50
        IF (JA.EQ.JB) GOTO 20
        KLAST = NPEEL
      ENDIF
C-----------------------------------------------------------------------
C
C   Store the arrays JLIST, JJC1 and JJC2.
C
C-----------------------------------------------------------------------
      DO I = 1,NPEEL
        JLIS(I) = JLIST(I)
      ENDDO
      NPEELM = NPEEL-1
      DO I = 1,NPEELM
        JC1S(I) = JJC1(I)
        JC2S(I) = JJC2(I)
      ENDDO
C-----------------------------------------------------------------------
      DO KWA = 1,KLAST
C
        IF (IDQ.EQ.0) THEN
          JA1 = KWA
          JA2 = KWA
        ENDIF
C
        JT1 = JA1
        JT2 = JA2
        IT1 = JLIST(JA1)
        IT2 = JLIST(JA2)
C
        CALL RKCO2G(KWA,NPEEL,JLIST,NQ1,NQ2,JT1,JT2,IWRITE,IBUG2)
C
        IF (IDQ.EQ.0 .AND. NCORE.EQ.0) GOTO 10
        IF (NCORE.EQ.0 .OR. NAK(IT1).NE.NAK(IT2)) RETURN
C-----------------------------------------------------------------------
C
C   This section calculates the terms arising from active electrons
C   that are in closed shells.
C
C-----------------------------------------------------------------------
        CALL RKCO3G(JT1,JT2,IWRITE,IBUG2,JJQ1,JJQ2,JLIS,JC1S,JC2S)
C-----------------------------------------------------------------------
   10   CONTINUE
      ENDDO
C-----------------------------------------------------------------------
      RETURN
C-----------------------------------------------------------------------
C
C   1.2.4   IDQ = 0 - diagonal case.
C                     Include all pairs with JA1 = JA2, JB1 = JB2.
C
C-----------------------------------------------------------------------
   20 CONTINUE
      DO KW1 = 1,NPEEL
        K1 = JLIST(KW1)
        JB1 = KW1
        DO KW2 = 1,KW1
          JA1 = KW2
          IF (JA1.EQ.JB1 .AND. NQ1(K1).LE.1) GOTO 30
          IF (IBUG2.EQ.1) WRITE (IWRITE,3090) JA1,JB1,JA1,JB1
          CALL CORG(JA1,JB1,JA1,JB1)
   30     CONTINUE
        ENDDO
      ENDDO
C-----------------------------------------------------------------------
C
C   2.0 The diagonal case. Deal with contributions from core orbitals.
C
C-----------------------------------------------------------------------
   40 CONTINUE
      IF (NCORE.EQ.0) RETURN
C-----------------------------------------------------------------------
      DO KW1 = 1,NCORE
        JB1 = KW1
C-----------------------------------------------------------------------
C
C   2.1 Calculate contribution from core/core terms.
C
C-----------------------------------------------------------------------
        IPCA = 2
        DO KW2 = 1,KW1
          JA1 = KW2
          IF (IBUG2.EQ.1) WRITE (IWRITE,3090) JA1,JB1,JA1,JB1
          CALL CORD(JA1,IPCA,JB1)
        ENDDO
C-----------------------------------------------------------------------
C
C   2.2 Calculate contribution from peel/core terms.
C
C-----------------------------------------------------------------------
        IF (NPEEL.GT.0) THEN
          IPCA = 1
          DO KW2 = 1,NPEEL
            JA1 = KW2
            IF (IBUG2.EQ.1) WRITE (IWRITE,3090) JA1,JB1,JA1,JB1
            CALL CORD(JA1,IPCA,JB1)
          ENDDO
        ENDIF
C-----------------------------------------------------------------------
      ENDDO
C-----------------------------------------------------------------------
      RETURN
C-----------------------------------------------------------------------
C
C   3.0 Diagnostic print - NW < 1
C
C-----------------------------------------------------------------------
   50 CONTINUE
      WRITE (IWRITE,3080)
      WRITE (IPUNCH,3080)
      STOP
C-----------------------------------------------------------------------
 3000 FORMAT (' RKCO called : NW NCF JA JB : ',4I4)
 3010 FORMAT (' RKCO called : ITJPO        : ',10I4)
 3020 FORMAT (' RKCO called : ISPAR        : ',10I4)
 3030 FORMAT (' RKCO called : IQ           : ',10I4)
 3040 FORMAT (' RKCO called : NPEEL,NCORE  : ',2I4)
 3050 FORMAT (' RKCO called : JLIST        : ',10I4)
 3060 FORMAT (' RKCO called : JJC1         : ',10I4)
 3070 FORMAT (' RKCO called : JJC2         : ',10I4)
 3080 FORMAT (' ERROR in RKCO')
 3090 FORMAT (//10X,'  JA1 =',I3,4X,'  JB1 =',I3,4X,'  JA2 =',I3,       !
     +'  JB2 =',I3/)
      END
C
C                             *******************
C
      FUNCTION RKINT(NGRAC,NGRID,RAC,RBD,K,IW)
C
C-----------------------------------------------------------------------
C
C   This routine evaluates the Breit interaction integrals.
C
C   If IW=0 then calculates U(R1,R2) integral
C
C   If IW=1,2 then calculateS R BAR (K; A C / B D ; W) with
C
C       W = WAC  if IC=1
C         = WBD  if IC=2
C
C  Subroutines called: QUAD,YBRA,YZK
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      DOUBLE PRECISION RKINT
      INCLUDE 'grasp0.inc'
C
C  Parameter variables
C
      DOUBLE PRECISION ONE
      PARAMETER (ONE=1.D0)
      INTEGER N11
      PARAMETER (N11=MXNP+10)
C
C  Argument variables
C
      DOUBLE PRECISION RAC(MXNP),RBD(MXNP)
      INTEGER IW,K,NGRAC,NGRID
C
C  Local variables
C
      DOUBLE PRECISION RESULT
      INTEGER I,KP
C
C  Common variables
C
      DOUBLE PRECISION BESSJ(2,2,MXNP),BESSN(2,2,MXNP)
      DOUBLE PRECISION WIJ(2)
      COMMON / BESS1  / WIJ,BESSJ,BESSN
C
C  Common variables
C
      DOUBLE PRECISION RGRID(MXNP)
      COMMON / GRID   / RGRID
C
C  Common variables
C
      DOUBLE PRECISION TA(N11),TB(N11)
      COMMON / TATB   / TA,TB
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
      IF (IW.EQ.0) THEN
C
C                             IW=0
C                             ----
        DO I = 1,NGRAC
          TA(I) = RGRID(I)*RAC(I)
        ENDDO
        CALL YZK(NGRAC,K)
        DO I = 1,NGRID
          TA(I) = RBD(I)*TB(I)
        ENDDO
        CALL QUAD(NGRID,RESULT)
C
      ELSE
C
C                             IW=1,2
C                             ------
        DO I = 1,NGRAC
          TA(I) = RAC(I)*(ONE+BESSJ(1,IW,I))
        ENDDO
        KP = K+1
        CALL YBRA(NGRAC,KP)
        DO I = 1,NGRID
          TA(I) = RBD(I)*(ONE+BESSN(1,IW,I))*TB(I)*RGRID(I)
        ENDDO
        CALL QUAD(NGRID,RESULT)
      ENDIF
C
      RKINT = RESULT
C
      END
C
C                             *******************
C
      SUBROUTINE RRITZ(NLAST)
C
C-----------------------------------------------------------------------
C
C   This subroutine forms a new L-spinor basis [c.f. Grant & Quiney
c   Phys.Rev.A62, 022508 (2000)] from the non-orthogonal zero-order 
c   basis generated by COULG, using Rayleigh-Ritz method - nrb 03/08.
c
c   The maximum basis size per kappa is hardwired via MXFCT as, for
c   DRMPS calculations, the max total number of orbitals (all kappa)
c   given by dimension MXNW will be unnecessarily large. Does not 
c   seem worth introducing another user set dimension parameter.
C
C   DATA
C   ----
C   NLAST index of last element used in PF and QF
C
C   RESULTS
C   -------
C   PF,QF the wave functions are tabulated in these common arrays
C
C
C   Subroutines called: QUAD, DSYGV (LAPACK), YZK
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
c      implicit real*8(a-h,o-z)          !makes life easier when testing
C
      INCLUDE 'grasp0.inc'
C
C  Parameter dimensions (local)
C
      INTEGER MXFCT,MXFCT2,LWORK
C
      PARAMETER (MXFCT=50)
      PARAMETER (MXFCT2=MXFCT+MXFCT)
      PARAMETER (LWORK=32*MXFCT2)
C
C  Parameter variables
C
      DOUBLE PRECISION XXA
      PARAMETER (XXA=672.D0)
      DOUBLE PRECISION XXB
      PARAMETER (XXB=-168.D0)
      DOUBLE PRECISION XXC
      PARAMETER (XXC=32.D0)
      DOUBLE PRECISION XXD
      PARAMETER (XXD=-3.D0)
      DOUBLE PRECISION XXE
      PARAMETER (XXE=1.D0/840.D0)
      INTEGER N11
      PARAMETER (N11=MXNP+10)
C
C  Argument variables
C
      INTEGER NLAST
C
C  Local variables
C
      DOUBLE PRECISION AMAT(MXFCT2,MXFCT2),BMAT(MXFCT2,MXFCT2)
      DOUBLE PRECISION DE(MXFCT2),WORK(LWORK),ZEFF(MXNP)
      DOUBLE PRECISION TP(MXFCT),TQ(MXFCT)
      DOUBLE PRECISION PK(MXNP),PJ(MXNP),QK(MXNP),QJ(MXNP),PD(MXNP)
      INTEGER IMAP(MXNW),IPAP(MXFCT)
C
      DOUBLE PRECISION ZJ,SCR,TC,TC2,RESULT,SUMP,SUMQ
      DOUBLE PRECISION CA,CB,CC,CD,CE
      INTEGER I,IJ,K,IK,J,M,N1,N2,M1,M2,NMAX,NMAX2,INFO
      INTEGER LL,LMIN,LMAX,KAPPA,NPMIN,KEY
      INTEGER NGRID,NN,MM,NPOINT,ISUM,NADD
C
      INTEGER NE
      LOGICAL LSPIN
C
C  Common variables
C
      DOUBLE PRECISION HALF,ONE,TEN,TENTH
      DOUBLE PRECISION THREE,TWO,ZERO
      COMMON / CONS   / ZERO,HALF,TENTH,ONE,TWO,THREE,TEN
C
C  Common variables
C
      DOUBLE PRECISION ACCY,C,EPH,H
      DOUBLE PRECISION RNT,Z
      INTEGER N,NCPRIN,NW1
      COMMON / DEF01  / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN
C
C  Common variables
C
      DOUBLE PRECISION PZ(MXNW),QZ(MXNW)
      COMMON / EXCO   / PZ,QZ
C
C  Common variables
C
      DOUBLE PRECISION RGRID(MXNP)
      COMMON / GRID   / RGRID
C
C  Common variables
C
      INTEGER IPUNCH,IREAD,IWRITE
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
C
C  Common variables
C
      DOUBLE PRECISION ZZ(MXNP)
      COMMON / NPOT   / ZZ
C
C  Common variables
C
      INTEGER ICUT(MXNW)
      COMMON /NRBCUT/ICUT
C
C  Common variables
C
      DOUBLE PRECISION FX
      INTEGER ISTATX,NPMIN0
      COMMON /NRBINF/FX,ISTATX,NPMIN0
C
C  Common variables
C
      DOUBLE PRECISION E(MXNW)
      COMMON / ORB01  / E
C
C  Common variables
C
      DOUBLE PRECISION CXP(MXNW)
      COMMON / ORB03  / CXP
C
C  Common variables
C
      INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF
      INTEGER NP(MXNW),NW
      COMMON / ORB04  / NW,NCF,NP,NAK,IQ
C
C  Common variables
C
      INTEGER MPOIN(MXNW),MPOS(MXNW)
      COMMON / PATY   / MPOIN,MPOS
C
C  Common variables
C
      DOUBLE PRECISION CUTOFF
      COMMON / PATZ   / CUTOFF
C
C  Common variables
C
      DOUBLE PRECISION TA(N11),TB(N11)
      COMMON / TATB   / TA,TB
C
C  Common variables
C
      DOUBLE PRECISION PF(MXNG),QF(MXNG)
      COMMON / WAVE   / PF,QF
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
c
      WRITE(IWRITE,3010)
c
c Set initial Coulomb screening.
c
      NE=0
      DO I=NW,1,-1
        IF(NE.EQ.0)KEY=I                        !outermost orbital index
        NE=NE+IQ(I,1)
      ENDDO
      NE=NE-1
      SCR=NE
      ZJ=Z-SCR
c
c Find l-range, i.e. kappas to solve for, that contain l-spinors
c assume both kappas required for valid l.gt.0
c
      LMIN=999
      LMAX=0
      DO I=1,NW
        SCR=CXP(I)
        LSPIN=SCR.LT.-TENTH
        IF(LSPIN)THEN
          KAPPA=NAK(I)
          LL=KAPPA
          IF(KAPPA.LT.0)LL=-LL-1
          LMIN=MIN(LMIN,LL)
          LMAX=MAX(LMAX,LL)
        ENDIF
      ENDDO
C
      IF(LMIN.GT.LMAX)RETURN                     !as no valid states
C
      LL=LMIN
      KAPPA=LL
      IF(KAPPA.EQ.0)KAPPA=-1
c
c Entry point for new kappa
c
   1  CONTINUE
c
c default npmin starts with lowest princ. qu. no. that is l-spinor,
c but will start lower if npmin0 is initialized lower on input Record 11
c
      NPMIN=MAX(NPMIN0,LL+1)       !incase npmin0 set too low for this l
c
c First, set-up a map of where the required orbitals lie.
c Also, see if buffer space was set large enough to store new basis.
c
      NMAX=0
      DO I=1,NW
        IF(NAK(I).EQ.KAPPA)THEN
          SCR=CXP(I)
          LSPIN=SCR.LT.-TENTH
          IF(LSPIN)NPMIN=MIN(NPMIN,NP(I))
          IF(NP(I).GE.NPMIN)THEN                   !We want this orbital
            IF(ICUT(I).EQ.0)THEN                   !Index of real extent
              IK=MPOIN(I)                          !Unbuffered
            ELSE
              IK=ICUT(I)                           !Buffered
            ENDIF
            DO N1=1,NMAX
              J=IMAP(N1)
              IF(IK.GT.MPOIN(J))THEN               !Extent beyond buffer
                WRITE(IWRITE,1000)J,I,FX
                WRITE(*,*)'***SR.RRITZ WARNING: ORBITAL TRUNCATED'
              ENDIF            
            ENDDO
            NMAX=NMAX+1
            IMAP(NMAX)=I
          ENDIF
        ENDIF
      ENDDO
C
      IF(NMAX.EQ.0)GO TO 900          !as this kappa has no valid states
C
      IF(NMAX.GT.MXFCT)THEN
        WRITE(IWRITE,*)'**RRITZ DIMENSION MXFCT TOO SMALL, INCREASE TO:'
     X                 ,NMAX
        STOP '**RRITZ DIMENSION MXFCT TOO SMALL'
      ENDIF
C
C
C*******************************************************
C
C SET-UP GALERKIN EQUATION: A*X=E*B*X
C
C*******************************************************
C
      NMAX2=NMAX+NMAX
C
      DO N1=1,NMAX2                                  !INITIALIZE LOWER T
        DO M1=N1,NMAX2
          AMAT(M1,N1)=ZERO
          BMAT(M1,N1)=ZERO
        ENDDO
      ENDDO
C
C***************************
C ADD-IN POTENTIAL TERMS
C***************************
C
C This zeff=-r*pot, so zeff=-zj for pure coulomb (zj.gt.0).
C
      IF(ISTATX.EQ.0)THEN
C
C Use coulomb potential for quasi one-electron problem.
C
        DO I=1,N
          ZEFF(I)=-ZJ
        ENDDO
C
      ELSE
C
C Use static potential, plus any finite nucleus contrib.
C Use occupation nos from first config, omitting the outermost electron.
C
        DO I = 1,N
          TA(I) = ZERO
        ENDDO
C
        DO J = 1,NW
          ISUM=IQ(J,1)
          IF(J.EQ.KEY)ISUM=ISUM-1
          IF(ISUM.GT.0)THEN
            IJ = MPOS(J)
            NGRID = MPOIN(J)
            DO I = 1,NGRID
              TA(I) = TA(I)+ISUM*(PF(IJ)*PF(IJ)+QF(IJ)*QF(IJ))
              IJ = IJ+1
            ENDDO
          ENDIF
        ENDDO
C
        DO I = 1,N
          TA(I) = TA(I)*RGRID(I)
        ENDDO
C
        CALL YZK(N,0)
C
        DO I = 1,N
          ZEFF(I) = TB(I)-ZZ(I)
        ENDDO
C
      ENDIF
C
C Loop over "+ & -" components
C*****************************
C
      DO N1=1,NMAX
        N2=NMAX+N1
C
        K=IMAP(N1)
C
C  Copy out orbital K
C
        IK = MPOS(K)
        NGRID = MPOIN(K)
        DO I = 1,NGRID
          PK(I) = PF(IK)
          QK(I) = QF(IK)
          IK = IK+1
        ENDDO
C
        IF (NGRID.LT.N) THEN
          DO I = NGRID+1,N
            PK(I) = ZERO
            QK(I) = ZERO
          ENDDO
        ENDIF
C
C Loop over "+ & -" components
C*****************************
C
        DO M1=N1,NMAX                                 !(N.B. M.GE.N)
          M2=NMAX+M1
C
          J=IMAP(M1)
C
C  Copy out orbital J
C
          IJ = MPOS(J)
          NGRID = MPOIN(J)
          DO I = 1,NGRID
            PJ(I) = PF(IJ)
            QJ(I) = QF(IJ)
            IJ = IJ+1
          ENDDO
C
          IF (NGRID.LT.N) THEN
            DO I = NGRID+1,N
              PJ(I) = ZERO
              QJ(I) = ZERO
            ENDDO
          ENDIF
C
C  Form the ++ integrand for QUAD
C
          DO I=1,N
            TA(I)=PK(I)*PJ(I)*ZEFF(I)
          ENDDO
C
          CALL QUAD(N,RESULT)
C
C Add contribution to ++
C
          AMAT(M1,N1)=AMAT(M1,N1)+RESULT
C
C  Form the -- integrand for QUAD
C
          DO I=1,N
            TA(I)=QK(I)*QJ(I)*ZEFF(I)
          ENDDO
C
          CALL QUAD(N,RESULT)
C
C Add contribution to --
C
          AMAT(M2,N2)=AMAT(M2,N2)+RESULT
C
        ENDDO
C
      ENDDO
cc
c      write(71,*)'SPEED OF LIGHT USED: C=',c
cc
c      write(71,*)'**************************'
c      write(71,*)'**** POTENTIAL MATRIX ****'
c      write(71,*)'**************************'
c      do n1=1,nmax2
c        write(71,*)'*** ',n1
c        write(71,1001)(amat(i,n1)/(2*zj),i=1,nmax)
c        write(71,1001)(amat(i,n1)/(2*zj),i=nmax+1,nmax2)
cc        do i=1,nmax2
cc          amat(i,n1)=zero
cc        enddo
c      enddo
C
C ***********************
C ADD-IN KINETIC TERMS
C ***********************
C
      TC = C*KAPPA
C
C Loop over "+" component
C************************
C
      DO N1=1,NMAX
        N2=NMAX+N1
C
        K=IMAP(N1)
C
C  Copy out orbital K
C
        IK = MPOS(K)
        NGRID = MPOIN(K)
        DO I = 1,NGRID
          PK(I) = PF(IK)
          IK = IK+1
        ENDDO
C
        IF (NGRID.LT.N) THEN
          DO I = NGRID+1,N
            PK(I) = ZERO
          ENDDO
        ENDIF
C
C  Calculate derivative
C  --------------------
C
C  Set derivative zero near origin, for first M points
C
        M = 4
        DO I = 1,M
          PD(I) = ZERO
        ENDDO
C
C  Use central difference formula for points M+1 to N-M
C
        CE = XXE*C/H
        CA = XXA*CE
        CB = XXB*CE
        CC = XXC*CE
        CD = XXD*CE
C
        MM = M+1
        NN = N-M
        DO I = MM,NN
          PD(I) = CA*(PK(I+1)-PK(I-1))+CB*(PK(I+2)-PK(I-2))+CC*(PK(I+3)
     +           -PK(I-3))+CD*(PK(I+4)-PK(I-4))
        ENDDO
C
C Loop over "-" component
C************************
C
        DO M1=1,NMAX
          M2=NMAX+M1
C
          J=IMAP(M1)
C
C  Copy out orbital J
C
          IJ = MPOS(J)
          NGRID = MPOIN(J)
          DO I = 1,NGRID
            QJ(I) = QF(IJ)
            IJ = IJ+1
          ENDDO
C
          IF (NGRID.LT.N) THEN
            DO I = NGRID+1,N
              QJ(I) = ZERO
            ENDDO
          ENDIF
C
C  Form the integrand for QUAD
C  ---------------------------
C
C  Set first M points of integrand to zero
C  QUAD will use a power series to estimate this contribution
C
          DO I = 1,M
            TA(I) = ZERO
          ENDDO
C
          DO I = MM,NN
            TA(I) = QJ(I)*(TC*PK(I)+PD(I))
          ENDDO
C
          CALL QUAD(NN,RESULT)
C
C Add contribution to -+
C
          AMAT(M2,N1)=AMAT(M2,N1)+RESULT
C
        ENDDO
C
      ENDDO
cc
c      write(71,*)'************************'
c      write(71,*)'**** KINETIC MATRIX ****'
c      write(71,*)'************************'
c      do n1=1,nmax2
c        write(71,*)'*** ',n1
c        write(71,1001)(amat(i,n1)/(2*zj),i=1,nmax)
c        write(71,1001)(amat(i,n1)/(2*zj),i=nmax+1,nmax2)
cc        do i=1,nmax2
cc          amat(i,n1)=zero
cc        enddo
c      enddo
C
C
C*********************
C ADD-IN GRAM MATRICES
C*********************
C
C (uses either E or EPS, where E=C*C+EPS)
C
      TC=C*C
      TC2=TC+TC
      NPOINT=0
C
C DIAGONAL M=N
C ------------
C
      DO N1=1,NMAX
        N2=NMAX+N1
C
        K=IMAP(N1)
        NGRID = MPOIN(K)
        NPOINT=MAX(NPOINT,NGRID)                  !for future ref.
C
C  Form the ++ integrand for QUAD
C
        IK = MPOS(K)
        DO I = 1,NGRID
          TA(I) = PF(IK)*PF(IK)*RGRID(I)
          IK = IK+1
        ENDDO
C
        CALL QUAD(NGRID,RESULT)
C
C Add contribution to ++
C
        AMAT(N1,N1)=AMAT(N1,N1)                   !+TC*RESULT !for E
C
        BMAT(N1,N1)=BMAT(N1,N1)+RESULT
C
C  Form the -- integrand for QUAD
C
        IK = MPOS(K)
        DO I = 1,NGRID
          TA(I) = QF(IK)*QF(IK)*RGRID(I)
          IK = IK+1
        ENDDO
C
        CALL QUAD(NGRID,RESULT)
C
C Add contribution to --
C
        AMAT(N2,N2)=AMAT(N2,N2)-TC2*RESULT        !+TC*RESULT !for E
C
        BMAT(N2,N2)=BMAT(N2,N2)+RESULT
C
      ENDDO
C
C SUB-DIAGONAL M=N-1
C ------------------
C
      DO N1=2,NMAX
        N2=NMAX+N1
C
        M1=N1-1
        M2=NMAX+M1
C
        K=IMAP(N1)
        J=IMAP(M1)
        NGRID = MIN(MPOIN(K),MPOIN(J))
C
C  Form the ++ integrand for QUAD
C
        IK = MPOS(K)
        IJ = MPOS(J)
        DO I = 1,NGRID
          TA(I) = PF(IK)*PF(IJ)*RGRID(I)
          IK = IK+1
          IJ = IJ+1
        ENDDO
C
        CALL QUAD(NGRID,RESULT)
C
C Add contribution to ++
C
        AMAT(N1,M1)=AMAT(N1,M1)                   !+TC*RESULT !for E

        BMAT(N1,M1)=BMAT(N1,M1)+RESULT
C
C  Form the -- integrand for QUAD
C
        IK = MPOS(K)
        IJ = MPOS(J)
        DO I = 1,NGRID
          TA(I) = QF(IK)*QF(IJ)*RGRID(I)
          IK = IK+1
          IJ = IJ+1
        ENDDO
C
        CALL QUAD(NGRID,RESULT)
C
C Add contribution to --
C
        AMAT(N2,M2)=AMAT(N2,M2)-TC2*RESULT        !+TC*RESULT !for E
C
        BMAT(N2,M2)=BMAT(N2,M2)+RESULT
C
      ENDDO
cc
c      write(71,*)'*********************'
c      write(71,*)'**** GRAM MATRIX ****'
c      write(71,*)'*********************'
c      do n1=1,nmax2
c        write(71,*)'*** ',n1
c        write(71,1001)(bmat(i,n1),i=1,nmax)
c        write(71,1001)(bmat(i,n1),i=nmax+1,nmax2)
cc        do i=1,nmax2
cc          amat(i,n1)=zero
cc          bmat(i,n1)=zero
cc        enddo
c      enddo
C
C
C*******************************************************
C
C NOW SOLVE GENRALIZED EIGEN-PROBLEM (A*X=E*B*X)
C
C*******************************************************
C
      CALL DSYGV(1,'V','L',NMAX2,AMAT,MXFCT2,BMAT,MXFCT2,DE
     X          ,WORK,LWORK,INFO)
C
      IF(INFO.NE.0)THEN
        WRITE(*,*)'*** INFO=',INFO
        WRITE(IWRITE,*)'*** SR.RRITZ: DSYGV FAILED WITH INFO=',INFO
        STOP '*** SR.RRITZ: DSYGV FAILED'
      ENDIF
C
      DO N1=1,NMAX
        IF(DE(N1).GT.-2*TC)THEN          !+TC
          WRITE(IWRITE,*)'***SR.RRITZ: ERROR: POSITRON ENERGY EXCEEDS',
     X                   ' -C**2 A.U. FOR BASIS ORBITAL',IMAP(N1)
          STOP 'ERROR: POSITRON ENERGY EXCEEDS -C**2 A.U.'
        ENDIF
      ENDDO
c
cc      WRITE(*,*)' '
cc      WRITE(*,*)'POSITRON E-VALUES +C**2 (A.U.):'
cc      WRITE(*,*)'------------------------------'
c      WRITE(71,*)' '
c      WRITE(71,*)'POSITRON E-VALUES +C**2 (A.U.):'
c      WRITE(71,*)'------------------------------'
c      DO N1=1,NMAX
cc        WRITE(*,1011)N1,DE(N1)+TC+TC
c        WRITE(71,1011)N1,DE(N1)+TC+TC   !-TC  !CONVGE ON ZERO FROM BELOW
c        WRITE(71,1001)(AMAT(I,N1),I=1,NMAX)
c        WRITE(71,1001)(AMAT(I,N1),I=NMAX+1,NMAX2)
c      ENDDO
cc
c      WRITE(*,*)' '
c      WRITE(*,*)'ELECTRON E-VALUES -C**2 (A.U.):'
c      WRITE(*,*)'------------------------------'
c      WRITE(71,*)' '
c      WRITE(71,*)'ELECTRON E-VALUES -C**2 (A.U.):'
c      WRITE(71,*)'------------------------------'
c      DO N1=NMAX+1,NMAX2
c        M1=N1-NMAX
c        WRITE(*,1011)M1,DE(N1)  !-TC
c        WRITE(71,1011)M1,DE(N1) !-TC !SO BOUND CONVGE ON ZERO FROM BELOW
c        WRITE(71,1001)(AMAT(I,N1),I=1,NMAX)
c        WRITE(71,1001)(AMAT(I,N1),I=NMAX+1,NMAX2)
c      ENDDO
cc
c 1001 FORMAT(10(F8.4))
c 1011 FORMAT(I4,1PD22.12)
C
C*************************************************************
C
C NOW FORM NEW BASIS: (P',Q')=(P,Q)*X (ELECTRON STATES ONLY)
C
C NOTE: THE TAIL CANNOT BE EXTENDED BECAUSE OF PF,QF SET-UP. 
C SO, BUFFER SPACE WAS SET BACK IN COULG, THEN COLLAPSED HERE.
C NOTE: THE LOOPING IS "INEFFICIENT" (OVER "ROWS" PF,QF) SO
C AS TO AVOID OVERWRITING, ELSE WE NEED TO DUPLICATE PF,QF.
C
C*************************************************************
C
C
C First, update Energy term (Epsilon)
C
      DO N1=1,NMAX
        N2=NMAX+N1
        K=IMAP(N1)
        E(K)=DE(N2)                              !-TC   !IF DE=E=EPS+C*C
      ENDDO
C
C Next, form new basis functions.
C
      DO I=1,NPOINT
C
C Load this radial point for all functions
C
        DO N1=1,NMAX
          J=IMAP(N1)
          IF(I.LE.MPOIN(J))THEN
            IJ=MPOS(J)+I-1
            IPAP(N1)=IJ
            TP(N1)=PF(IJ)
            TQ(N1)=QF(IJ)
          ELSE
            TP(N1)=ZERO
            TQ(N1)=ZERO
          ENDIF
        ENDDO
C
C Now form new basis at this point, for all functions
C
        DO N1=1,NMAX
          J=IMAP(N1)
          IF(I.LE.MPOIN(J))THEN
            N2=NMAX+N1
C
            SUMP=ZERO
            SUMQ=ZERO
            DO M1=1,NMAX
              M2=NMAX+M1
              SUMP=SUMP+TP(M1)*AMAT(M1,N2)
              SUMQ=SUMQ+TQ(M1)*AMAT(M2,N2)
            ENDDO
C
            IJ=IPAP(N1)
            PF(IJ)=SUMP
            QF(IJ)=SUMQ
          ENDIF
        ENDDO
C
      ENDDO
C
C Ditto for threshold
C
      DO N1=1,NMAX
        J=IMAP(N1)
        TP(N1)=PZ(J)
        TQ(N1)=QZ(J)
      ENDDO
C
      DO N1=1,NMAX
        N2=NMAX+N1
C
        SUMP=ZERO
        SUMQ=ZERO
        DO M1=1,NMAX
          M2=NMAX+M1
          SUMP=SUMP+TP(M1)*AMAT(M1,N2)
          SUMQ=SUMQ+TQ(M1)*AMAT(M2,N2)
        ENDDO
C
        J=IMAP(N1)
        PZ(J)=SUMP
        QZ(J)=SUMQ
      ENDDO
C
C Re-index for any unused buffer space
C
      DO N1=1,NMAX
        J=IMAP(N1)
        IF(ICUT(J).GT.0)THEN                            !Was buffered
C
          IJ=MPOS(J)+ICUT(J)-1
          DO I=ICUT(J),MPOIN(J)          !Search from original cut-off
            IF (ABS(PF(IJ)).LE.CUTOFF) GOTO 60
            IJ=IJ+1
          ENDDO
C
          ICUT(J) = MPOIN(J)
C      write(*,*)'***SR.RRITZ: WAVEFUNCTION TRUNCATED, INCREASE BUFFER'
          GOTO 70
C
   60     CONTINUE
C
          NPOINT = I
          IF (MOD(NPOINT,2).EQ.1) THEN
            NADD = 8
          ELSE
            NADD = 7
          ENDIF
          IF (NPOINT+NADD.GT.MPOIN(J)) NADD = MPOIN(J) - NPOINT
          ICUT(J) = NPOINT+NADD                           !New cut-off
C
   70     CONTINUE
C
        ENDIF
      ENDDO
C
C-------------------
C NEXT KAPPA
C-------------------
C
  900 IF(KAPPA.GT.0)THEN
        KAPPA=-KAPPA-1
        GO TO 1
      ELSE
        LL=LL+1
        KAPPA=LL
        IF(LL.LE.LMAX)GO TO 1
      ENDIF
C
C Now collapse back any unused buffer space
C
       ISUM=0
       DO J=2,NW
         IF(ICUT(J-1).GT.0)ISUM=ISUM+MPOIN(J-1)-ICUT(J-1)
         IJ=MPOS(J)
         DO I=1,MPOIN(J)
           PF(IJ-ISUM)=PF(IJ)
           QF(IJ-ISUM)=QF(IJ)
           IJ=IJ+1
         ENDDO
         MPOS(J)=MPOS(J)-ISUM
       ENDDO
       IF(ICUT(NW).GT.0)ISUM=ISUM+MPOIN(NW)-ICUT(NW)
C
       DO J=1,NW
         IF(ICUT(J).GT.0)MPOIN(J)=ICUT(J)
       ENDDO
C
       NLAST=NLAST-ISUM
C
      RETURN
C
 1000 FORMAT(//'***SR.RRITZ WARNING: NOT ENOUGH BUFFER SPACE SET ASIDE',
     X         ' FOR ORBITAL',I3,' TO ACCOMMODATE ORBITAL',
     X         I3,' WHEN FORMING NEW BASIS.'/'***INCREASE FX ON RECORD',
     X         ' 11 FROM',F5.1)
 3010 FORMAT (/' >>>> routine RRITZ called : form final L-spinor basis')
C
      END
C
C                             *******************
C
      SUBROUTINE SCF(ERAL,MX,HIACC)
C
C-----------------------------------------------------------------------
C
C  This subroutine controls the main sequence of the
C  calculation to produce a complete set of self-consistent
C  wave functions.
C
C        ERAL: maximum discrepancy between estimated and
C              calculated wave functions
C          MX: error indicator
C
C  Subroutines called : QUARTZ , LAGR , YPOT , XPOT , EIGENV ,
C                       HPOT   , SOLV0 , RINT
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  External functions
C
      EXTERNAL EIGENV,RINT
      DOUBLE PRECISION EIGENV,RINT
C
C  Parameter variables
C
      DOUBLE PRECISION PEIGHT
      PARAMETER (PEIGHT=.8D0)
      DOUBLE PRECISION PNINE
      PARAMETER (PNINE=.9D0)
      DOUBLE PRECISION EPS10
      PARAMETER (EPS10=1.D-10)
      DOUBLE PRECISION EPS2
      PARAMETER (EPS2=1.D-2)
C
C  Argument variables
C
      DOUBLE PRECISION ERAL
      INTEGER MX
      LOGICAL HIACC
C
C  Local variables
C
      DOUBLE PRECISION AG,ASMT(10),ER(MXNW)
      DOUBLE PRECISION ESMT(10),VN,WA,WB
      DOUBLE PRECISION WC,WD,XCA,XCP
      DOUBLE PRECISION XCQ,XINC,ZFAC,ZMX
      DOUBLE PRECISION ZST
      INTEGER I,IJ,IMX,IPW
      INTEGER IPWL,IPY,ITCA,ITCB
      INTEGER ITCC,ITCD,ITR,J
      INTEGER JL,MF,NFIRST,NGRID
      INTEGER NLAST,NN,NPOINT
C
C  Common variables
C
      DOUBLE PRECISION HALF,ONE,TEN,TENTH
      DOUBLE PRECISION THREE,TWO,ZERO
      COMMON / CONS   / ZERO,HALF,TENTH,ONE,TWO,THREE,TEN
C
C  Common variables
C
      DOUBLE PRECISION XCAX
      COMMON / CONVG  / XCAX
C
C  Common variables
C
      DOUBLE PRECISION ACCY,C,EPH,H
      DOUBLE PRECISION RNT,Z
      INTEGER N,NCPRIN,NW1
      COMMON / DEF01  / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN
C
C  Common variables
C
      DOUBLE PRECISION PZ(MXNW),QZ(MXNW)
      COMMON / EXCO   / PZ,QZ
C
C  Common variables
C
      INTEGER JFIX(MXNW)
      COMMON / FIXD   / JFIX
C
C  Common variables
C
      INTEGER IPUNCH,IREAD,IWRITE
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
C
C  Common variables
C
      DOUBLE PRECISION P(MXNP),PC(MXNP),Q(MXNP)
      DOUBLE PRECISION QC(MXNP)
      COMMON / INT2   / P,Q,PC,QC
C
C  Common variables
C
      INTEGER ITC(50)
      COMMON / OPT01  / ITC
C
C  Common variables
C
      CHARACTER*2 NH(MXNW)
      COMMON / ORB00  / NH
C
C  Common variables
C
      DOUBLE PRECISION E(MXNW)
      COMMON / ORB01  / E
C
C  Common variables
C
      DOUBLE PRECISION GAMA(MXNW),XAM(MXNW)
      COMMON / ORB02  / GAMA,XAM
C
C  Common variables
C
      INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF
      INTEGER NP(MXNW),NW
      COMMON / ORB04  / NW,NCF,NP,NAK,IQ
C
C  Common variables
C
      INTEGER MPOIN(MXNW),MPOS(MXNW)
      COMMON / PATY   / MPOIN,MPOS
C
C  Common variables
C
      DOUBLE PRECISION PF(MXNG),QF(MXNG)
      COMMON / WAVE   / PF,QF
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
      MX = 0
      ITR = 4*NW
      J = 0
      XINC = XCAX*TENTH
C
      WRITE (IWRITE,3010)
C
C  Insert artificial values into the array  ER, so that
C  the first operation will consist of one stage of iteration
C  for each function in their natural order
C
      DO I = 1,NW
        ER(I) = ZERO
      ENDDO
C
      WA = DBLE(NW)
      DO I = 1,NW
        IF (JFIX(I).EQ.0) ER(I) = 1000.D0*WA
        WA = WA-ONE
      ENDDO
C
C  JL is the serial number of the function treated in the
C  previous iteration.  In the first iteration it is zero.
C
C  Determine  WA, the largest discrepancy, and J, which
C  specifies which function shows this largest value.
C
   10 CONTINUE
      WA = -ONE
      JL = J
C
      DO I = 1,NW
        WB = ABS(ER(I))
        IF (WB.GT.WA) THEN
          WA = WB
          J = I
        ENDIF
      ENDDO
C
C  Normal exit if required accuracy has been achieved
C  --------------------------------------------------
C
      IF (WA.LE.ERAL) RETURN
C
C  ITR counts iterations downwards from the specified maximum
C
      ITR = ITR-1
      IF (ITR.LT.0) GOTO 110
C
C  Store atomic number in ZST.
C  IPY indicates which stage the automatic recovery process has reached.
C        IPY=0   normal computation of wave function
C        IPY=1   after initial failure, atomic number is
C                being increased
C        IPY=2   solution has been found with artificially
C                increased atomic number, which is now
C                being reduced.
C  This reduction of the atomic number in the third stage is
C  achieved in  10  stages, which are counted in IPW, stepping
C  down from  10  to zero.
C
      ZST = Z
      ZMX = Z
      IPW = 10
      IPY = 0
      IPWL = 10
      XCA = XCAX
      ZFAC = ONE
C
C   Adjustment of off-diagonal parameters.
C
      CALL LAGR(J)
C
C   XCA is the factor multiplying exchange terms
C   Z   is the effective atomic number
C
C  Tabulate the direct and exchange potentials
C  -------------------------------------------
C
   20 CONTINUE
      CALL YPOT(J,VN,ZFAC)
      CALL XPOT(J,XCA,XCP,XCQ)
C
C
      IF (XCA.LT.EPS10 .OR. E(J).LE.ZERO) THEN
C
C  Compute estimate of eigenvalue, if no other estimate is
C  available, or if exchange terms are zero
C
        WA = EIGENV(J)
C
      ELSE
C
C  Use eigenvalue from previous iteration, if any.
C
        WA = E(J)
      ENDIF
C
C  If estimate is not positive, use  E = 0.1
C
      IF (WA.LE.ZERO) THEN
        WA = TENTH
      ENDIF
C
C  Use estimate of PZ from previous iteration
C
      AG = PZ(J)
C
C  If in final stage of recovery from previous failure,
C  extrapolate estimates of  E  and  PZ  from previous
C  two iterations
C
      IF (IPY.EQ.2 .AND. IPW.GT.1) THEN
        AG = ASMT(IPW)+ASMT(IPW)-ASMT(IPW-1)
        WA = ESMT(IPW)+ESMT(IPW)-ESMT(IPW-1)
      ENDIF
C
C  Solve Dirac radial equations
C  ----------------------------
C
      IF (ITC(4).EQ.1) CALL HPOT(J,XCA)
C
      CALL SOLV0(J,VN,XCA,XCP,XCQ,AG,WA,MF,HIACC,NPOINT)
C
C  Failure  9  indicates table too short
C  extend by four steps
C
      IF (MF.EQ.9) THEN
C
        NLAST = MPOS(NW)+MPOIN(NW)-1
        IF (NLAST+4.GT.MXNG) GOTO 120
C
        IF (J.LT.NW) THEN
          NFIRST = MPOS(J+1)
          DO NN = NLAST,NFIRST,-1
            PF(NN+4) = PF(NN)
            QF(NN+4) = QF(NN)
          ENDDO
          DO NN = J+1,NW
            MPOS(NN) = MPOS(NN)+4
          ENDDO
        ENDIF
C
        NLAST = MPOS(J)+MPOIN(J)-1
        DO NN = NLAST+1,NLAST+4
          PF(NN) = ZERO
          QF(NN) = ZERO
        ENDDO
        MPOIN(J) = MPOIN(J)+4
        IF (MPOIN(J).GT.N) N = MPOIN(J)
        IF (N.GT.MXNP) GOTO 130
C
C  ....  and try again
C
        GOTO 20
C
      ENDIF
C
C  Successful iteration
C  --------------------
C
      IF (MF.EQ.0) THEN
        NGRID = MPOIN(J)
C
C  Find largest difference between calculated and estimated functions
C
        WC = ZERO
        IJ = MPOS(J)
C
        DO I = 1,NGRID
          WA = P(I)-PF(IJ)
          WB = ABS(WA)+ABS(Q(I)-QF(IJ))
          IF (WB.GT.WC) THEN
            WC = WB
            WD = WA
            IMX = I
          ENDIF
          IJ = IJ+1
        ENDDO
C
C  Avoid adjustment of mixing coefficient  XAM  unless previous
C  iteration involved the same function
C
        IF (JL.NE.J .OR. IPY.EQ.1 .OR. IPWL.NE.IPW) GOTO 100
C
C  Increase XAM if new correction has opposite sign to
C  previous one, and more than half the magnitude
C
        IF (WC-ABS(ER(J))*HALF) 100,100,30
   30   CONTINUE
        IF (WD*ER(J)) 40,70,70
   40   CONTINUE
        IF (XAM(J)-PEIGHT) 60,60,50
C
C  Do not increase XAM beyond  0.9
C
   50   CONTINUE
        XAM(J) = PNINE
        GOTO 100
C
   60   CONTINUE
        XAM(J) = XAM(J)+TENTH
        GOTO 100
C
C  Decrease XAM by 0.1 if new correction has same sign as
C  previous one, and more than half the magnitude
C
   70   CONTINUE
        IF (XAM(J)-TENTH) 80,80,90
C
C  Do not decrease XAM below zero
C
   80   CONTINUE
        XAM(J) = ZERO
        GOTO 100
C
   90   CONTINUE
        XAM(J) = XAM(J)-TENTH
C
C  Print one line record of iteration
C  ----------------------------------
C
  100   CONTINUE
        ER(J) = SIGN(WC,WD)
        WB = RNT*EPH**(IMX-1)
        WRITE (IWRITE,3000) J,NP(J),NH(J),E(J),Z,XAM(J),XCA,WB,ER(J),NPO!
     +INT
C
        IF (XAM(J).LT.EPS10) THEN
          IJ = MPOS(J)
          DO I = 1,NGRID
            PF(IJ) = P(I)
            QF(IJ) = Q(I)
            IJ = IJ+1
          ENDDO
C
        ELSE
C
C  Tabulate new estimate as combination of old and computed functions
C  ------------------------------------------------------------------
C
          WB = XAM(J)
          WC = ONE-WB
          IJ = MPOS(J)
          DO I = 1,NGRID
            PF(IJ) = WC*P(I)+WB*PF(IJ)
            QF(IJ) = WC*Q(I)+WB*QF(IJ)
            IJ = IJ+1
          ENDDO
C
C  Re-normalise the result
C  -----------------------
C
          WA = ONE/SQRT(RINT(J,J,0))
          IJ = MPOS(J)
          DO I = 1,NGRID
            PF(IJ) = PF(IJ)*WA
            QF(IJ) = QF(IJ)*WA
            IJ = IJ+1
          ENDDO
C
        ENDIF
C
C  On final success, reset Z to true value and try another iteration
C
        IF (IPY.EQ.0 .OR. (IPY.EQ.2.AND.IPW.EQ.10)) THEN
          Z = ZST
          GOTO 10
C
        ENDIF
C
C  If this completes stage 1 of the recovery process,
C  begin stage 2, counting upwards from zero in IPW
C  -------------
C
        IPWL = IPW
        IF (IPY.EQ.1) THEN
          IPY = 2
          ZMX = Z
          IPW = 0
        ENDIF
C
C  Store values of  E  and  PZ for subsequent extrapolation
C
        ASMT(IPW+1) = PZ(J)
        ESMT(IPW+1) = E(J)
        ITR = ITR-1
C
C  Repeat this step if change was significant
C
        IF (ABS(ER(J)).GT.EPS2) GOTO 20
C
C  ... otherwise reduce  Z  and repeat
C
        IPW = IPW+1
        XCA = XCA+XINC
        Z = ZST+(ZMX-ZST)*(10-IPW)/10.0D0
        ZFAC = Z/ZST
        GOTO 20
C
      ENDIF
C
C  In case of failure, repeat computation with extra printing
C  ------------------
C  Repeat computation with extra printing if option 13 is set
C
      IF (ITC(13).EQ.1) THEN
        ITCA = ITC(19)
        ITCB = ITC(18)
        ITCC = ITC(17)
        ITCD = ITC(15)
        ITC(19) = 1
        ITC(18) = 1
        ITC(17) = 1
        ITC(15) = 1
        IF (ITC(4).EQ.1) CALL HPOT(J,XCA)
        CALL SOLV0(J,VN,XCA,XCP,XCQ,AG,WA,MF,HIACC,NPOINT)
        ITC(19) = ITCA
        ITC(18) = ITCB
        ITC(17) = ITCC
        ITC(15) = ITCD
      ENDIF
C
C  Begin recovery by setting exchange terms to zero
C
      IF (IPY.EQ.0) THEN
        IPY = 1
        XCA = ZERO
        JL = J
        GOTO 20
      ENDIF
C
C  If failure with IPY=1 increase Z until convergence
C
      IF (IPY.EQ.1) THEN
        Z = Z+TENTH
        ZFAC = Z/ZST
        IF (Z.GT.ZST+5.D0) THEN
          MF = 5
        ELSE
          GOTO 20
        ENDIF
      ENDIF
C
C  If failure with IPY=2 abandon calculation
C
      WRITE (IWRITE,3040) NP(J),NH(J)
C
      IF (MF.EQ.-2) THEN
        WRITE (IWRITE,3050)
        CALL QUARTZ(0)
        STOP
      ENDIF
C
      IF (MF.EQ.-1) THEN
        WRITE (IWRITE,3060)
        CALL QUARTZ(0)
        STOP
      ENDIF
C
      IF (MF.EQ.1) THEN
        WRITE (IWRITE,3070)
        CALL QUARTZ(0)
        STOP
      ENDIF
C
      IF (MF.EQ.2) THEN
        WRITE (IWRITE,3080)
        CALL QUARTZ(0)
        STOP
      ENDIF
C
      IF (MF.EQ.3) THEN
        WRITE (IWRITE,3090)
        CALL QUARTZ(0)
        STOP
      ENDIF
C
      IF (MF.EQ.4) THEN
        WRITE (IWRITE,3100)
        CALL QUARTZ(0)
        STOP
      ENDIF
C
      IF (MF.EQ.5) THEN
        WRITE (IWRITE,3110)
        CALL QUARTZ(0)
        STOP
      ENDIF
C-----------------------------------------------------------------------
C   error messages
C-----------------------------------------------------------------------
  110 CONTINUE
      MX = 1
      WRITE (IWRITE,3020)
      IF (ITC(12).EQ.0) RETURN
      CALL QUARTZ(0)
      STOP
C
  120 CONTINUE
      WRITE (IWRITE,3030) NP(J),NH(J),NLAST,MXNG
      CALL QUARTZ(0)
      STOP
C
  130 CONTINUE
      WRITE (IWRITE,3120)
      CALL QUARTZ(0)
      STOP
C
 3000 FORMAT (1X,I2,1X,I2,A2,1P,E17.9,1X,0P,F7.2,F5.1,1P,E10.1,2E10.2,I4!
     +)
 3010 FORMAT (/' >>>> routine SCF called'//12X,'eigenvalue',7X,'Z',5X,  !
     +'mix',4X,'XCA',6X,'RMAX',6X,'DMAX   NPOINT'/)
 3020 FORMAT (/' iteration limit exceeded in SCF')
 3030 FORMAT (/' STOPPING in SCF for orbitaL ',I2,A2/                   !
     +' insufficient grid points'/                                      !
     +' trying to extend the table to NLAST = ',I7,                     !
     +' plus 4 which exceeds the dimension set by MXNG = ',I7)
 3040 FORMAT (' failure in SCF process for ',I2,A2)
 3050 FORMAT (' wrong number of zeros')
 3060 FORMAT (' number of iterations exceeded')
 3070 FORMAT (' solution cannot be normalised')
 3080 FORMAT (' normalised solution has wrong sign')
 3090 FORMAT (' no positive eigenvalue')
 3100 FORMAT (' matching point is too far out')
 3110 FORMAT (' Z increased beyond reasonable limit')
 3120 FORMAT (/' STOPPING in SCF - insufficient grid points')
      END
C
C                             *******************
C
      SUBROUTINE SCORB(NLAST,J,ZA,RA,HA,NA,P1,Q1)
C
C-----------------------------------------------------------------------
C
C  This routine takes the wavefunction read from dump and
C      1. rescales with Z if necessary
C      2. interpolates to new grid if necessary
C
C   Routines called : QUAD,ZEFR
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  Parameter variables
C
      DOUBLE PRECISION EPS10
      PARAMETER (EPS10=1.D-10)
      DOUBLE PRECISION SIX
      PARAMETER (SIX=6.D0)
      DOUBLE PRECISION TWF
      PARAMETER (TWF=24.D0)
      INTEGER N11
      PARAMETER (N11=MXNP+10)
C
C  Argument variables
C
      DOUBLE PRECISION HA,P1,Q1,RA
      DOUBLE PRECISION ZA
      INTEGER J,NA,NLAST
C
C  Local variables
C
      DOUBLE PRECISION AP,AQ,BN,COP
      DOUBLE PRECISION COQ,EP,EPA,EPB
      DOUBLE PRECISION FACQ,FK,FKS,FNR
      DOUBLE PRECISION GA,HB,HR,R
      DOUBLE PRECISION RB,S,T,W
      DOUBLE PRECISION WP,WQ,ZB,ZF
      DOUBLE PRECISION ZX
      INTEGER I,IJ,K,L
      INTEGER NADD,NB,NGRID,NN
      INTEGER NPOINT,nx
C
C  Common variables
C
      DOUBLE PRECISION HALF,ONE,TEN,TENTH
      DOUBLE PRECISION THREE,TWO,ZERO
      COMMON / CONS   / ZERO,HALF,TENTH,ONE,TWO,THREE,TEN
C
C  Common variables
C
      DOUBLE PRECISION ACCY,C,EPH,H
      DOUBLE PRECISION RNT,Z
      INTEGER N,NCPRIN,NW1
      COMMON / DEF01  / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN
C
C  Common variables
C
      DOUBLE PRECISION PZ(MXNW),QZ(MXNW)
      COMMON / EXCO   / PZ,QZ
C
C  Common variables
C
      INTEGER IPUNCH,IREAD,IWRITE
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
C
C  Common variables
C
      DOUBLE PRECISION P(MXNP),PC(MXNP),Q(MXNP)
      DOUBLE PRECISION QC(MXNP)
      COMMON / INT2   / P,Q,PC,QC
C
C  Common variables
C
      integer icut(mxnw)
      common /nrbcut/icut
C
C  Common variables
C
      double precision fx
      integer istatx,npmin0
      common /nrbinf/fx,istatx,npmin0
C
C  Common variables
C
      INTEGER ITC(50)
      COMMON / OPT01  / ITC
C
C  Common variables
C
      CHARACTER*2 NH(MXNW)
      COMMON / ORB00  / NH
C
C  Common variables
C
      DOUBLE PRECISION GAMA(MXNW),XAM(MXNW)
      COMMON / ORB02  / GAMA,XAM
C
C  Common variables
C
      INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF
      INTEGER NP(MXNW),NW
      COMMON / ORB04  / NW,NCF,NP,NAK,IQ
C
C  Common variables
C
      INTEGER MPOIN(MXNW),MPOS(MXNW)
      COMMON / PATY   / MPOIN,MPOS
C
C  Common variables
C
      DOUBLE PRECISION CUTOFF
      COMMON / PATZ   / CUTOFF
C
C  Common variables
C
      DOUBLE PRECISION TA(N11),TB(N11)
      COMMON / TATB   / TA,TB
C
C  Common variables
C
      DOUBLE PRECISION PF(MXNG),QF(MXNG)
      COMMON / WAVE   / PF,QF
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
      FACQ = ONE
      S = ONE
C
      ZB = Z
      RB = RNT
      HB = H
      NB = N
C
      IF (ABS(ZA-ZB).LT.EPS10) GOTO 10
      IF (ITC(21).EQ.1) GOTO 10
C
C  Z values differ - need to rescale with Z
C
      EPA = EXP(HA)
      R = RA*RA
      EP = EPA*EPA
      DO I = 1,NA
        TA(I) = R*(P(I)*P(I)+Q(I)*Q(I))
        R = R*EP
      ENDDO
C
      H = HA
      CALL QUAD(NA,W)
      H = HB
C
      CALL ZEFR(J,W,ZX)
      K = NAK(J)
      NN = NP(J)
      FK = DBLE(K)
      FKS = FK*FK
      ZF = ZB-ZA+ZX
      FNR = DBLE(NN-ABS(K))
      COP = ZF/C
      COP = COP*COP
      COQ = SQRT(FKS-COP)+FNR
      COP = COQ*COQ+COP
      BN = SQRT(COP)
      COP = COQ*(COP+COP+COP-FKS)-BN*FK
      COQ = BN*ZF
      R = COP/(COQ+COQ)
      S = W/R
      FACQ = ZF/ZX
      GOTO 20
C
   10 CONTINUE
      WP = ONE
      WQ = ONE
      NGRID = NA
      IF (ABS(RA-RB)+ABS(HA-HB).LT.EPS10) GOTO 70
C
C  Grids differ - need to interpolate.
C                 uses central difference formula.
C
C
   20 CONTINUE
      GA = GAMA(J)
      EPB = EPH
      WP = S**GA
      WQ = WP*FACQ
      AP = P(1)*WP
      AQ = Q(1)*WQ
      R = RB/RA
      T = LOG(R*S)/HA
      HR = HB/HA
C
      DO I = 1,NB
C
        L = INT(T+ONE)
        IF (L.GT.1) GOTO 30
        COP = R**GA
        PC(I) = AP*COP
        QC(I) = AQ*COP
        R = R*EPB
        GOTO 40
C
   30   CONTINUE
        IF (L.GT.NA) GOTO 50
        IF (L.LT.3) L = 3
        IF (L.GT.NA-2) L = NA - 2
        W = T+ONE-DBLE(L)
        PC(I) = (W+ONE)*(W-ONE)*(W*((W-TWO)*P(L-2)+(W+TWO)*P(L+2))+SIX*(!
     +W+TWO)*(W-TWO)*P(L))/TWF-W*(W+TWO)*(W-TWO)*((W-ONE)*P(L-1)+(W+ONE)!
     +*P(L+1))/SIX
        QC(I) = FACQ*((W+ONE)*(W-ONE)*(W*((W-TWO)*Q(L-2)+(W+TWO)*Q(L+2))!
     ++SIX*(W+TWO)*(W-TWO)*Q(L))/TWF-W*(W+TWO)*(W-TWO)*((W-ONE)*Q(L-1)+(!
     +W+ONE)*Q(L+1))/SIX)
   40   CONTINUE
        T = T+HR
C
      ENDDO
C
      NGRID = NB
      GOTO 60
C
   50 CONTINUE
      NGRID = I-1
      IF (MOD(NGRID,2).EQ.0) THEN
        NGRID = NGRID+1
        PC(NGRID) = ZERO
        QC(NGRID) = ZERO
      ENDIF
C
   60 CONTINUE
      R = RB
      DO I = 1,NGRID
        TA(I) = R*(PC(I)*PC(I)+QC(I)*QC(I))
        R = R*EPB
      ENDDO
      CALL QUAD(NGRID,W)
      W = ONE/SQRT(W)
      DO I = 1,NGRID
        P(I) = PC(I)*W
        Q(I) = QC(I)*W
      ENDDO
C-----------------------------------------------------------------------
   70 CONTINUE
C
C  Determine cutoff point for the wave-function
C
      DO I = NGRID,1,-1
        IF (ABS(P(I)).GT.CUTOFF) GOTO 80
      ENDDO
      WRITE (IWRITE,3010) NP(J),NH(J)
      WRITE (IPUNCH,3010) NP(J),NH(J)
      STOP
C
   80 CONTINUE
      NPOINT = I
c
c add buffer space for subsequent formation of new basis in rritz;
c extend it radially by a factor fx.
c
      if(np(j).ge.npmin0)then
        icut(j)=npoint                                 !store real end
        nx=log(fx)/h
        nx=nx+mod(nx,2)
      else
        nx=0
      endif
C
      IF (MOD(NPOINT,2).EQ.0) NPOINT = NPOINT + 1
      NADD = 4
c
      nadd=nadd+nx
c
      IF (NPOINT+NADD.GT.N) NADD = N - NPOINT
C
      IF (NADD.GT.0) THEN
        DO I = NPOINT+1,NPOINT+NADD
          P(I) = ZERO
          Q(I) = ZERO
        ENDDO
        NGRID = NPOINT+NADD
      ELSE
        NGRID = NPOINT
      ENDIF
C
      IF (NLAST+NGRID.GT.MXNG) THEN
        WRITE (IWRITE,3000) NLAST + NGRID,MXNG
        WRITE (IPUNCH,3000) NLAST + NGRID,MXNG
        STOP
      ENDIF
C
      IJ = NLAST+1
      DO I = 1,NGRID
        PF(IJ) = P(I)
        QF(IJ) = Q(I)
        IJ = IJ+1
      ENDDO
      PZ(J) = P1*WP
      QZ(J) = Q1*WQ
      MPOS(J) = NLAST+1
      MPOIN(J) = NGRID
      NLAST = NLAST+NGRID
C
 3000 FORMAT (/' Dimension ERROR in routine SCORB'/                     !
     +' Program is STOPPING'/' You must increase MXNG to at least ',I9, !
     +' from the present value of ',I9)
 3010 FORMAT (/' Program is STOPPING'/' orbital ',I2,A2,                !
     +' appears to be zero everywhere')
      END
C
C                             *******************
C
      SUBROUTINE SETJ(IS,JS,KS,NS,KJ23)
C
C-----------------------------------------------------------------------
C
C  Sets the tables required by the recoupling coefficient package.
C  NJSYM. (See P.G.Burke, C.P.C.(1970), Vol.1,P.241)
C
C  This routine loads the common block /ANG00/ with parameters
C  for the first call of NJSYM involving direct integrals.
C  Subsequent exchange calls of NJSYM must be
C  preceeded by a call of MODJ23 to restore these arrays to their
C  correct initial state.
C
C  No subroutines called.
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  Parameter variables
C
      INTEGER MANGM
      PARAMETER (MANGM=60)
      INTEGER MTRIAD
      PARAMETER (MTRIAD=20)
      INTEGER NPLX
      PARAMETER (NPLX=14)
C
C  Argument variables
C
      INTEGER IS(2,2),JS(2,2),KJ23,KS(2,2)
      INTEGER NS
C
C  Local variables
C
      INTEGER I,II,IJ,IJ1
      INTEGER IJ2,J,NS1,NS2
      INTEGER NS3
C
C  Common variables
C
      INTEGER J1(MANGM),J2(MTRIAD,3)
      INTEGER J3(MTRIAD,3),MMOM,NMOM
      LOGICAL FREE(MANGM)
      COMMON / ANG00  / MMOM,NMOM,J1,J2,J3,FREE
C
C  Common variables
C
      INTEGER JBQ1(3,MXNW),JBQ2(3,MXNW)
      INTEGER JTQ1(3),JTQ2(3)
      COMMON / ANG08  / JBQ1,JBQ2,JTQ1,JTQ2
C
C  Common variables
C
      INTEGER J2S(MTRIAD,3),J3S(MTRIAD,3)
      COMMON / ANG09  / J2S,J3S
C
C  Common variables
C
      INTEGER JJC1(NPLX),JJC2(NPLX)
      COMMON / ANG10  / JJC1,JJC2
C
C  Common variables
C
      INTEGER JJQ1(3,MXNW),JJQ2(3,MXNW)
      COMMON / ANG12  / JJQ1,JJQ2
C
C  Common variables
C
      INTEGER JLIST(NPLX),KLIST(MXNW),NCORE,NPEEL
      COMMON / ANG13  / JLIST,KLIST,NPEEL,NCORE
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
C
C    1.0  Set J1 array
C
C-----------------------------------------------------------------------
      II = 0
      DO IJ = 1,NS
        I = JLIST(IJ)
        II = II+1
        J1(II) = JBQ1(3,I)
      ENDDO
      IF (NS.EQ.1) GOTO 10
      NS1 = NS-1
      DO I = 1,NS1
        II = II+1
        J1(II) = JJC1(I)
      ENDDO
      DO I = 1,NS1
        II = II+1
        J1(II) = JJC2(I)
      ENDDO
   10 CONTINUE
      DO I = 1,2
        II = II+1
        IJ = IS(I,1)
        J1(II) = JJQ1(3,IJ)
        IF (I.EQ.1 .AND. IS(1,1).EQ.IS(2,1)) J1(II) = JTQ1(3)
        J1(II+4) = KS(I,1)
      ENDDO
      DO I = 1,2
        II = II+1
        IJ = IS(I,2)
        J1(II) = JJQ2(3,IJ)
        IF (I.EQ.1 .AND. IS(1,2).EQ.IS(2,2)) J1(II) = JTQ2(3)
        J1(II+4) = KS(I,2)
      ENDDO
C-----------------------------------------------------------------------
C
C    2.0  Set J2,J3 arrays if not already available
C
C-----------------------------------------------------------------------
      NS2 = MAX(4,NS+2)
      IF (KJ23.GT.0) GOTO 60
C
      DO I = 4,NS2
        J2(I,1) = NS+I-4
        J2(I,2) = I-2
        J2(I,3) = NS+I-3
        J3(I,1) = J2(I,1)+NS-1
        J3(I,2) = I-2
        J3(I,3) = J2(I,3)+NS-1
      ENDDO
      J2(4,1) = 1
      J3(4,1) = 1
C-----------------------------------------------------------------------
C
C   At this stage, the entries in rows corresponding to active shells
C   are set incorrectly.
C
C    3.0  Set rows 1 thro' 3
C
C-----------------------------------------------------------------------
      NS3 = 3*NS
      J2(1,1) = NS3+5
      J2(1,2) = NS3+7
      J2(1,3) = NS3+3
      J2(2,1) = JS(1,1)
      J2(2,2) = NS3+3
      J2(2,3) = NS3-1
      J2(3,1) = JS(2,1)
      J2(3,2) = NS3+4
      J2(3,3) = NS3
C
      J3(1,1) = NS3+7
      J3(1,2) = NS3+4
      J3(1,3) = NS3+6
      J3(2,1) = JS(1,2)
      J3(2,2) = NS3+5
      J3(2,3) = NS3+1
      J3(3,1) = JS(2,2)
      J3(3,2) = NS3+6
      J3(3,3) = NS3+2
C-----------------------------------------------------------------------
C
C    4.0  Set remaining resultants
C
C-----------------------------------------------------------------------
      IJ1 = JS(1,1)
      IJ2 = JS(2,1)
      IF (IJ2.GT.1) J2(IJ2+2,2) = J2(3,3)
      IF (IJ2.EQ.1) J2(4,1) = J2(3,3)
      IF (IJ1.NE.IJ2) GOTO 20
      J2(3,1) = J2(2,3)
      GOTO 30
C
   20 CONTINUE
      IF (IJ1.GT.1) J2(IJ1+2,2) = J2(2,3)
      IF (IJ1.EQ.1) J2(4,1) = J2(2,3)
C
   30 CONTINUE
      IJ1 = JS(1,2)
      IJ2 = JS(2,2)
      IF (IJ2.GT.1) J3(IJ2+2,2) = J3(3,3)
      IF (IJ2.EQ.1) J3(4,1) = J3(3,3)
      IF (IJ1.NE.IJ2) GOTO 40
      J3(3,1) = J3(2,3)
      GOTO 50
C
   40 CONTINUE
      IF (IJ1.GT.1) J3(IJ1+2,2) = J3(2,3)
      IF (IJ1.EQ.1) J3(4,1) = J3(2,3)
C-----------------------------------------------------------------------
C
C    All arrays now set. Put up flag KJ23.
C
C-----------------------------------------------------------------------
   50 CONTINUE
      KJ23 = 1
      MMOM = NS3+7
      NMOM = NS+3
C-----------------------------------------------------------------------
C
C    5.0  Save J2,J3 and return
C
C-----------------------------------------------------------------------
      DO J = 1,3
        DO I = 1,NS2
          J2S(I,J) = J2(I,J)
          J3S(I,J) = J3(I,J)
        ENDDO
      ENDDO
      RETURN
C-----------------------------------------------------------------------
C
C    6.0  Reset J2,J3 from buffers if KJ23 has been set
C
C-----------------------------------------------------------------------
   60 CONTINUE
      DO J = 1,3
        DO I = 1,NS2
          J2(I,J) = J2S(I,J)
          J3(I,J) = J3S(I,J)
        ENDDO
      ENDDO
C-----------------------------------------------------------------------
      END
C
C                             *******************
C
      SUBROUTINE SETUP(JA,JB,IWRITE,IBUG2)
C
C-----------------------------------------------------------------------
C
C  This generates the arrays defining the quantum numbers of the states
C  involved in the matrix element linking CSFs labelled by JA,JB.
C
C  No subroutines called.
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  Parameter variables
C
      INTEGER NPLX
      PARAMETER (NPLX=14)
C
C  Argument variables
C
      INTEGER IBUG2,IWRITE,JA,JB
C
C  Local variables
C
      INTEGER I,J,JCNT,JCNTOP
      INTEGER JW1,JW2,JWW,K
C
C  Common variables
C
      INTEGER JJC1(NPLX),JJC2(NPLX)
      COMMON / ANG10  / JJC1,JJC2
C
C  Common variables
C
      INTEGER NQ1(MXNW),NQ2(MXNW)
      COMMON / ANG11  / NQ1,NQ2
C
C  Common variables
C
      INTEGER JJQ1(3,MXNW),JJQ2(3,MXNW)
      COMMON / ANG12  / JJQ1,JJQ2
C
C  Common variables
C
      INTEGER JLIST(NPLX),KLIST(MXNW),NCORE,NPEEL
      COMMON / ANG13  / JLIST,KLIST,NPEEL,NCORE
C
C  Common variables
C
      INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF
      INTEGER NP(MXNW),NW
      COMMON / ORB04  / NW,NCF,NP,NAK,IQ
C
C  Common variables
C
      INTEGER ICHOP(MXNW,MXNC),IEXC
      INTEGER JCUP(10,MXNC),JQS(3,MXNW,MXNC)
      COMMON / ORB06  / JQS,JCUP,ICHOP,IEXC
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
      IF (IBUG2.EQ.1) THEN
        DO J = 1,NCF
          WRITE (IWRITE,3000) (JCUP(I,J),I=1,10)
        ENDDO
        DO J = 1,NCF
          WRITE (IWRITE,3010) (ICHOP(I,J),I=1,NW)
        ENDDO
      ENDIF
C-----------------------------------------------------------------------
C
C  List parameters defining all shells in both configurations
C  whether participating or not.
C
C-----------------------------------------------------------------------
      DO J = 1,NW
        NQ1(J) = IQ(J,JA)
        NQ2(J) = IQ(J,JB)
      ENDDO
C-----------------------------------------------------------------------
      DO K = 1,3
        DO J = 1,NW
          JJQ1(K,J) = JQS(K,J,JA)
          JJQ2(K,J) = JQS(K,J,JB)
        ENDDO
      ENDDO
C-----------------------------------------------------------------------
C
C  Define coupling schemes
C
C  Set JLIST array to define those shells which are open in
C  either configuration, and KLIST array to locate the rest.
C  Exclude shells which are empty in both configurations.
C
C-----------------------------------------------------------------------
      NPEEL = 0
      NCORE = 0
      DO J = 1,NW
C
        IF (ICHOP(J,JA).NE.-1 .OR. ICHOP(J,JB).NE.-1) THEN
          IF (ICHOP(J,JA).EQ.1 .AND. ICHOP(J,JB).EQ.1) THEN
            NCORE = NCORE+1
            KLIST(NCORE) = J
          ELSE
            NPEEL = NPEEL+1
C
C  Note that in some cases an extra peel orbital is added to
C  the true peel orbitals. Therefore the dimension check is
C  against NPLX-1.
C
            IF (NPEEL.GT.NPLX-1) THEN
              WRITE (IWRITE,3030) JA,JB,NPLX
              STOP
            ENDIF
            JLIST(NPEEL) = J
          ENDIF
        ENDIF
C
      ENDDO
C-----------------------------------------------------------------------
C
C  Return if not more than one shell is open
C
C-----------------------------------------------------------------------
      IF (NPEEL.LE.1) RETURN
C-----------------------------------------------------------------------
C
C  Set arrays of coupling angular momenta interpolating
C  closed shells where necessary.
C
C  Left hand side first ...
C
C-----------------------------------------------------------------------
      JCNT = 1
      JCNTOP = 0
      JW1 = JLIST(1)
      JW2 = JLIST(2)
      IF (ICHOP(JW1,JA).EQ.0) THEN
        JCNTOP = 1
        IF (ICHOP(JW2,JA).EQ.0) THEN
          JJC1(1) = JCUP(JCNT,JA)
          JCNT = JCNT+1
        ELSE
          JJC1(1) = JQS(3,JW1,JA)
        ENDIF
      ELSE
        JJC1(1) = JQS(3,JW2,JA)
        IF (ICHOP(JW2,JA).EQ.0) JCNTOP = 1
      ENDIF
C-----------------------------------------------------------------------
      IF (NPEEL.GE.3) THEN
        DO J = 3,NPEEL
          JWW = JLIST(J)
          IF (ICHOP(JWW,JA).EQ.0) THEN
            IF (JCNTOP.EQ.0) THEN
              JJC1(J-1) = JQS(3,JWW,JA)
            ELSE
              JJC1(J-1) = JCUP(JCNT,JA)
              JCNT = JCNT+1
            ENDIF
            JCNTOP = JCNTOP+1
          ELSE
            JJC1(J-1) = JJC1(J-2)
          ENDIF
        ENDDO
      ENDIF
C-----------------------------------------------------------------------
      IF (IBUG2.EQ.1) THEN
        WRITE (IWRITE,3020) JCNT,JCNTOP
        IF (JCNT.GT.1) WRITE (IWRITE,3000) (JCUP(J,JA),J=1,JCNT-1)
      ENDIF
C-----------------------------------------------------------------------
C
C  ... and repeat for right hand side
C
C-----------------------------------------------------------------------
      JCNT = 1
      JCNTOP = 0
      JW1 = JLIST(1)
      JW2 = JLIST(2)
      IF (ICHOP(JW1,JB).EQ.0) THEN
        JCNTOP = 1
        IF (ICHOP(JW2,JB).EQ.0) THEN
          JJC2(1) = JCUP(JCNT,JB)
          JCNT = JCNT+1
        ELSE
          JJC2(1) = JQS(3,JW1,JB)
        ENDIF
      ELSE
        JJC2(1) = JQS(3,JW2,JB)
        IF (ICHOP(JW2,JB).EQ.0) JCNTOP = 1
      ENDIF
C-----------------------------------------------------------------------
      IF (NPEEL.GE.3) THEN
        DO J = 3,NPEEL
          JWW = JLIST(J)
          IF (ICHOP(JWW,JB).EQ.0) THEN
            IF (JCNTOP.EQ.0) THEN
              JJC2(J-1) = JQS(3,JWW,JB)
            ELSE
              JJC2(J-1) = JCUP(JCNT,JB)
              JCNT = JCNT+1
            ENDIF
            JCNTOP = JCNTOP+1
          ELSE
            JJC2(J-1) = JJC2(J-2)
          ENDIF
        ENDDO
      ENDIF
C-----------------------------------------------------------------------
      IF (IBUG2.EQ.1) THEN
        WRITE (IWRITE,3020) JCNT,JCNTOP
        IF (JCNT.GT.1) WRITE (IWRITE,3000) (JCUP(J,JB),J=1,JCNT-1)
      ENDIF
C-----------------------------------------------------------------------
 3000 FORMAT (' SETUP called JCUP        : ',10I4)
 3010 FORMAT (' SETUP called ICHOP       : ',10I4)
 3020 FORMAT (' SETUP called JCNT JCNTOP : ',2I4)
 3030 FORMAT (/' ERROR in routine SETUP'/                               !
     +' Too many peel shells for configurations : ',2I4/                !
     +' The present version is limited to NPLX =',I4/                   !
     +' You must change the parameter NPLX.')
      END
C
C                             *******************
C
      FUNCTION SKINT(NGRAC,NGRBD,NGRID,RAC,RBD,K,IW)
C
C-----------------------------------------------------------------------
C
C  This routine evaluates the Breit interaction integrals.
C
C  It calculates the integral S (K; A C / B D :W)
C
C           where W = WAC if IW=1
C                   = WBD if IW=2
C
C  Subroutine called:  QUAD,YBRA
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      DOUBLE PRECISION SKINT
      INCLUDE 'grasp0.inc'
C
C  Parameter variables
C
      DOUBLE PRECISION ONE
      PARAMETER (ONE=1.D0)
      INTEGER N11
      PARAMETER (N11=MXNP+10)
C
C  Argument variables
C
      DOUBLE PRECISION RAC(MXNP),RBD(MXNP)
      INTEGER IW,K,NGRAC,NGRBD
      INTEGER NGRID
C
C  Local variables
C
      DOUBLE PRECISION TKEEP(MXNP),VALU,W
      INTEGER I,KP2
C
C  Common variables
C
      DOUBLE PRECISION BESSJ(2,2,MXNP),BESSN(2,2,MXNP)
      DOUBLE PRECISION WIJ(2)
      COMMON / BESS1  / WIJ,BESSJ,BESSN
C
C  Common variables
C
      DOUBLE PRECISION RGRID(MXNP)
      COMMON / GRID   / RGRID
C
C  Common variables
C
      DOUBLE PRECISION TA(N11),TB(N11)
      COMMON / TATB   / TA,TB
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
      W = WIJ(IW)
      DO I = 1,NGRAC
        TA(I) = RAC(I)
      ENDDO
      CALL YBRA(NGRAC,K)
      DO I = 1,NGRAC
        TKEEP(I) = TB(I)
        TA(I) = -TA(I)*BESSJ(1,IW,I)
      ENDDO
      CALL YBRA(NGRAC,K)
C
C  The following subtraction is CRITICAL and must be accurate to
C  order W**2 to obtain correct results.
C  (See comments in long write up)
C
      DO I = 1,NGRID
        TA(I) = ((ONE+BESSN(2,IW,I))*TB(I)-TKEEP(I)*BESSN(2,IW,I))*RBD(I!
     +)/RGRID(I)
      ENDDO
      CALL QUAD(NGRID,VALU)
      SKINT = (((K+K+1)/W)**2)*VALU
C
      DO I = 1,NGRBD
        TA(I) = RBD(I)*(ONE+BESSJ(2,IW,I))
      ENDDO
      KP2 = K+2
      CALL YBRA(NGRBD,KP2)
      DO I = 1,NGRID
        TA(I) = RAC(I)*(ONE+BESSN(1,IW,I))*TB(I)*RGRID(I)**3
      ENDDO
      CALL QUAD(NGRID,VALU)
CPN
CPN  Fixed bug here
CPN
      SKINT = SKINT-VALU*W*W/((K+K+3)*(K+K-1))
C
      END
C
C                             *******************
C
      SUBROUTINE SKRCG(IS,KAPS,KS,KD1,KD2,KE1,KE2)
C
C-----------------------------------------------------------------------
C
C  Determines the range of the tensor rank K for coulomb integral.
C
C  No subroutines called.
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
C
C  Argument variables
C
      INTEGER IS(4),KAPS(4),KD1,KD2
      INTEGER KE1,KE2,KS(4)
C
C  Local variables
C
      INTEGER ISD1,ISD2,ISE1,ISE2
      INTEGER KD1A,KD1B,KD2A,KD2B
      INTEGER KE1A,KE1B,KE2A,KE2B
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
      KD2 = 0
      KE2 = 0
C
C  Direct terms -  KD1=minimum K , KD2=number of terms
C
      ISD1 = 1
      IF (KAPS(1)*KAPS(3).LT.0) ISD1 = -1
      ISD2 = 1
      IF (KAPS(2)*KAPS(4).LT.0) ISD2 = -1
      KD1A = ABS(KS(1)-KS(3))
      IF (ISD1.LT.0) KD1A = KD1A + 2
      KD1B = ABS(KS(2)-KS(4))
      IF (ISD2.LT.0) KD1B = KD1B + 2
      IF (MOD((KD1A-KD1B)/2,2).NE.0) GOTO 10
      KD2A = KS(1)+KS(3)-2
      IF (ISD1.GT.0) KD2A = KD2A - 2
      KD2B = KS(2)+KS(4)-2
      IF (ISD2.GT.0) KD2B = KD2B - 2
      KD1 = MAX(KD1A,KD1B)/2
      KD2 = MIN(KD2A,KD2B)/2
      KD2 = (KD2-KD1)/2+1
C
C  Exchange terms -  KE1=minimum K , KE2=number of terms
C
   10 CONTINUE
      IF (IS(1).EQ.IS(2) .OR. IS(3).EQ.IS(4)) RETURN
      ISE1 = 1
      IF (KAPS(1)*KAPS(4).LT.0) ISE1 = -1
      ISE2 = 1
      IF (KAPS(2)*KAPS(3).LT.0) ISE2 = -1
      KE1A = ABS(KS(1)-KS(4))
      IF (ISE1.LT.0) KE1A = KE1A + 2
      KE1B = ABS(KS(2)-KS(3))
      IF (ISE2.LT.0) KE1B = KE1B + 2
      IF (MOD((KE1A-KE1B)/2,2).NE.0) RETURN
      KE2A = KS(1)+KS(4)-2
      IF (ISE1.GT.0) KE2A = KE2A - 2
      KE2B = KS(2)+KS(3)-2
      IF (ISE2.GT.0) KE2B = KE2B - 2
      KE1 = MAX(KE1A,KE1B)/2
      KE2 = MIN(KE2A,KE2B)/2
      KE2 = (KE2-KE1)/2+1
C
      END
C
C                             *******************
C
      FUNCTION SLATER(IA,IB,IC,ID,K)
C
C-----------------------------------------------------------------------
C
C   The value of this function is the Slater integral
C   as normally defined in terms of the four sets of
C   quantum numbers  A,B,C,D.
C
C   Subroutines called : YZK, QUAD
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      DOUBLE PRECISION SLATER
      INCLUDE 'grasp0.inc'
C
C  Parameter variables
C
      INTEGER N11
      PARAMETER (N11=MXNP+10)
C
C  Argument variables
C
      INTEGER IA,IB,IC,ID
      INTEGER K
C
C  Local variables
C
      DOUBLE PRECISION RESULT
      INTEGER I,IIA,IIB,IIC
      INTEGER IID,NGRID
C
C  Common variables
C
      DOUBLE PRECISION RGRID(MXNP)
      COMMON / GRID   / RGRID
C
C  Common variables
C
      INTEGER IPUNCH,IREAD,IWRITE
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
C
C  Common variables
C
      INTEGER ITC(50)
      COMMON / OPT01  / ITC
C
C  Common variables
C
      CHARACTER*2 NH(MXNW)
      COMMON / ORB00  / NH
C
C  Common variables
C
      INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF
      INTEGER NP(MXNW),NW
      COMMON / ORB04  / NW,NCF,NP,NAK,IQ
C
C  Common variables
C
      INTEGER MPOIN(MXNW),MPOS(MXNW)
      COMMON / PATY   / MPOIN,MPOS
C
C  Common variables
C
      DOUBLE PRECISION TA(N11),TB(N11)
      COMMON / TATB   / TA,TB
C
C  Common variables
C
      DOUBLE PRECISION PF(MXNG),QF(MXNG)
      COMMON / WAVE   / PF,QF
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
C
C   Tabulate integrand for computation of YK(R)
C
      NGRID = MIN(MPOIN(IB),MPOIN(ID))
      IIB = MPOS(IB)
      IID = MPOS(ID)
      DO I = 1,NGRID
        TA(I) = RGRID(I)*(PF(IIB)*PF(IID)+QF(IIB)*QF(IID))
        IIB = IIB+1
        IID = IID+1
      ENDDO
C
C   tabulate YK(R)
C
      CALL YZK(NGRID,K)
C
C   multiply by second term, and obtain result by integration
C
      NGRID = MIN(MPOIN(IA),MPOIN(IC))
      IIA = MPOS(IA)
      IIC = MPOS(IC)
      DO I = 1,NGRID
        TA(I) = (PF(IIA)*PF(IIC)+QF(IIA)*QF(IIC))*TB(I)
        IIA = IIA+1
        IIC = IIC+1
      ENDDO
C
      CALL QUAD(NGRID,RESULT)
      SLATER = RESULT
C
      IF (ITC(26).EQ.1) THEN
        WRITE (IWRITE,3000) NP(IA),NH(IA),NP(IB),NH(IB),NP(IC),NH(IC),NP!
     +(ID),NH(ID),K,SLATER
      ENDIF
C
 3000 FORMAT (' R (',I2,A2,',',I2,A2,',',I2,A2,',',I2,A2,';',I2,') = ',1!
     +P,E17.9)
      END
C
C                             *******************
C
      SUBROUTINE SNRC(IS,KAPS,KS,ID1,ID2,NE1,NE2,IBRD,IBRE)
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
C
C  Argument variables
C
      INTEGER IBRD,IBRE,ID1,ID2
      INTEGER IS(4),KAPS(4),KS(4),NE1
      INTEGER NE2
C
C  Local variables
C
      INTEGER IAC,IAD,ID1A,ID2A
      INTEGER NE1A,NE2A
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
      ID2 = 0
      NE2 = 0
C
      IAC = 1
      IF ((KAPS(1)*KAPS(3)).LT.0) IAC = -1
C
      IAD = 1
      IF ((KAPS(2)*KAPS(4)).LT.0) IAD = -1
C
      ID1 = ABS(KS(1)-KS(3))/2-1
      IF (IAC.EQ.-1) ID1 = ID1 + 1
      IF (ID1.EQ.-1) ID1 = 1
      ID1A = ABS(KS(2)-KS(4))/2-1
      IF (IAD.EQ.-1) ID1A = ID1A + 1
      IF (ID1A.EQ.-1) ID1A = 1
C
      IF (MOD(ID1-ID1A,2).EQ.0) GOTO 10
C
      IBRD = -1
      GOTO 20
C
   10 CONTINUE
      ID2 = ABS(KS(1)+KS(3))/2
      IF (IAC.EQ.-1) ID2 = ID2 + 1
      ID2A = ABS(KS(2)+KS(4))/2
      IF (IAD.EQ.-1) ID2A = ID2A + 1
      ID1 = MAX(ID1,ID1A)
      ID2 = MIN(ID2,ID2A)
      ID2 = (ID2-ID1)/2+1
      IBRD = 1
      IF (IS(1).EQ.IS(3) .AND. IS(2).NE.IS(4)) IBRD = 2
      IF (IS(1).NE.IS(3) .AND. IS(2).EQ.IS(4)) IBRD = 2
      IF (IS(1).EQ.IS(3) .AND. IS(2).EQ.IS(4)) IBRD = 3
C
   20 CONTINUE
      IF (IS(1).NE.IS(2) .AND. IS(3).NE.IS(4)) GOTO 30
      IBRE = -1
      RETURN
C
   30 CONTINUE
      IAC = 1
      IF ((KAPS(1)*KAPS(4)).LT.0) IAC = -1
      IAD = 1
      IF ((KAPS(2)*KAPS(3)).LT.0) IAD = -1
C
      NE1 = ABS(KS(1)-KS(4))/2-1
      IF (IAC.EQ.-1) NE1 = NE1 + 1
      IF (NE1.EQ.-1) NE1 = 1
      NE1A = ABS(KS(2)-KS(3))/2-1
      IF (IAD.EQ.-1) NE1A = NE1A + 1
      IF (NE1A.EQ.-1) NE1A = 1
C
      IF (MOD(NE1-NE1A,2).EQ.0) GOTO 40
C
      IBRE = -1
      RETURN
C
   40 CONTINUE
      NE2 = ABS(KS(1)+KS(4))/2
      IF (IAC.EQ.-1) NE2 = NE2 + 1
      NE2A = ABS(KS(2)+KS(3))/2
      IF (IAD.EQ.-1) NE2A = NE2A + 1
      NE1 = MAX(NE1,NE1A)
      NE2 = MIN(NE2,NE2A)
      NE2 = (NE2-NE1)/2+1
      IBRE = 1
      IF (IS(1).EQ.IS(4) .AND. IS(2).NE.IS(3)) IBRE = 2
      IF (IS(1).NE.IS(4) .AND. IS(2).EQ.IS(3)) IBRE = 2
      IF (IS(1).EQ.IS(3) .AND. IS(2).EQ.IS(4)) IBRE = 4
C
      END
C
C                             *******************
C
      SUBROUTINE SOLV0(JORB,VN,XCF,ALX,ALY,AST,EST,MX,HIACC,NPOINT)
C
C-----------------------------------------------------------------------
C
C   **** New version of SOLV ****
C
C  This subroutine solves a single pair of Dirac radial equations.
C  The direct potentials are tabulated in YP and YQ.
C  The exchange potentials are tabulated in XTP and XTQ.
C
C  DATA
C
C  JORB  serial number of wave function
C  VN    coefficient of R in expansion of direct potential
C  XCF   scale factor multiplying exchange term
C  ALX   leading coefficient in series expansion of exchange (P)
C  ALY   leading coefficient in series expansion of exchange (Q)
C  AST   estimate of A.
C  EST   estimate of eigenvalue  E.
C  HIACC a logical variable which is set .TRUE. if higher order
C        terms are to be included in the deferred correction, to
C        give an error which varies as O(H**6).
C
C  RESULTS
C
C  MX       should be zero. A non-zero value indicates failure.
C  E(JORB)  the eigenvalue
C  NPOINT   number of points in wave-function
C
C  The wave functions will be tabulated in arrays P and Q.
C  Coefficients in series expansions are stored in PZ(JORB), QZ(JORB).
C
C  Subroutines called : PRWF, SOLV1, OUT, IN, QUAD
C
C-----------------------------------------------------------------------
C
C     maximum number of iterations is set here
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  Parameter variables
C
      DOUBLE PRECISION CSOLV1
      PARAMETER (CSOLV1=0.3D0)
      DOUBLE PRECISION CSOLV2
      PARAMETER (CSOLV2=1.D2)
      DOUBLE PRECISION X1
      PARAMETER (X1=1.D0/12.D0)
      DOUBLE PRECISION X2
      PARAMETER (X2=-.25D0)
      DOUBLE PRECISION X3
      PARAMETER (X3=-1.D0/120.D0)
      DOUBLE PRECISION X4
      PARAMETER (X4=0.125D0)
      DOUBLE PRECISION X5
      PARAMETER (X5=-1.D0/3.D0)
      INTEGER N11
      PARAMETER (N11=MXNP+10)
      INTEGER NFMAX
      PARAMETER (NFMAX=25)
C
C  Argument variables
C
      DOUBLE PRECISION ALX,ALY,AST,EST
      DOUBLE PRECISION VN,XCF
      INTEGER JORB,MX,NPOINT
      LOGICAL HIACC
C
C  Local variables
C
      DOUBLE PRECISION ACL,DLA,DLE,ECL
      DOUBLE PRECISION FKJ,HH,QCJP,QEJP
      DOUBLE PRECISION QJP,QZE,WA,WAC
      DOUBLE PRECISION WB,WBC,WC,WCA
      DOUBLE PRECISION WCB,WD,WEA,WEB
      DOUBLE PRECISION WXA,WXB,WXY
      DOUBLE PRECISION XTPT(MXNP),XTQT(MXNP),YPT(MXNP)
      DOUBLE PRECISION YQT(MXNP)
      INTEGER I,IJ,JP,JPX
      INTEGER KJ,M,MAE,MAU
      INTEGER MF,NGRID,NODE,NODES
      INTEGER NTF
C
C  Common variables
C
      DOUBLE PRECISION HALF,ONE,TEN,TENTH
      DOUBLE PRECISION THREE,TWO,ZERO
      COMMON / CONS   / ZERO,HALF,TENTH,ONE,TWO,THREE,TEN
C
C  Common variables
C
      DOUBLE PRECISION ACCY,C,EPH,H
      DOUBLE PRECISION RNT,Z
      INTEGER N,NCPRIN,NW1
      COMMON / DEF01  / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN
C
C  Common variables
C
      DOUBLE PRECISION PZ(MXNW),QZ(MXNW)
      COMMON / EXCO   / PZ,QZ
C
C  Common variables
C
      DOUBLE PRECISION RGRID(MXNP)
      COMMON / GRID   / RGRID
C
C  Common variables
C
      INTEGER IPUNCH,IREAD,IWRITE
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
C
C  Common variables
C
      DOUBLE PRECISION P(MXNP),PC(MXNP),Q(MXNP)
      DOUBLE PRECISION QC(MXNP)
      COMMON / INT2   / P,Q,PC,QC
C
C  Common variables
C
      DOUBLE PRECISION XF(MXNP),XG(MXNP),XR(MXNP)
      DOUBLE PRECISION XS(MXNP),XU(MXNP),XV(MXNP)
      COMMON / INT3   / XU,XV,XR,XS,XF,XG
C
C  Common variables
C
      INTEGER ITC(50)
      COMMON / OPT01  / ITC
C
C  Common variables
C
      CHARACTER*2 NH(MXNW)
      COMMON / ORB00  / NH
C
C  Common variables
C
      DOUBLE PRECISION E(MXNW)
      COMMON / ORB01  / E
C
C  Common variables
C
      INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF
      INTEGER NP(MXNW),NW
      COMMON / ORB04  / NW,NCF,NP,NAK,IQ
C
C  Common variables
C
      INTEGER MPOIN(MXNW),MPOS(MXNW)
      COMMON / PATY   / MPOIN,MPOS
C
C  Common variables
C
      DOUBLE PRECISION XTP(MXNP),XTQ(MXNP),YP(MXNP)
      DOUBLE PRECISION YQ(MXNP)
      COMMON / POTE   / YP,YQ,XTP,XTQ
C
C  Common variables
C
      DOUBLE PRECISION TA(N11),TB(N11)
      COMMON / TATB   / TA,TB
C
C  Common variables
C
      DOUBLE PRECISION PF(MXNG),QF(MXNG)
      COMMON / WAVE   / PF,QF
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
C
C  Use SOLV1 for the non-exchange case
C  -----------------------------------
C
      IF (XCF.LE.ZERO) THEN
        CALL SOLV1(JORB,VN,XCF,AST,EST,MX,HIACC,XTPT,XTQT,YPT,YQT,NPOINT!
     +)
        GOTO 100
      ENDIF
C
      NGRID = MPOIN(JORB)
      IF (ITC(19).EQ.1) WRITE (IWRITE,3020) NP(JORB),NH(JORB),VN,XCF,ALX!
     +,ALY,AST,EST,Z,NGRID
C
      NPOINT = NGRID
      KJ = NAK(JORB)
      FKJ = DBLE(KJ)
C
C  NODES is the number of zeros required in P(R)
C
      IF (KJ.LT.0) THEN
        NODES = NP(JORB)+KJ
      ELSE
        NODES = NP(JORB)-KJ-1
      ENDIF
C
      MAU = 0
C
C  Begin from given estimates of  A  and  E
C
      ACL = AST
      ECL = EST
C
C  Count iterations in  NTF
C
      NTF = NFMAX+1
C
      HH = -H*HALF
      WA = -FKJ*HH
      WAC = ONE+WA
      WBC = ONE-WA
C
C  Tabulate modified direct potentials
C  ===================================
C  Clear exchange potential arrays
C
      WD = HH/C
      DO I = 1,NGRID
        XTPT(I) = ZERO
        XTQT(I) = ZERO
        YPT(I) = WD*YP(I)
        YQT(I) = WD*YQ(I)
      ENDDO
C
C  Set the P and Q arrays to zero for I>NGRID
C
      IF (NGRID+2.LE.MXNP) THEN
        DO I = NGRID+1,NGRID+2
          P(I) = ZERO
          Q(I) = ZERO
        ENDDO
      ELSE
        WRITE (IWRITE,3040) NGRID,MXNP
        WRITE (IPUNCH,3040) NGRID,MXNP
        STOP
      ENDIF
C
      IJ = MPOS(JORB)
      DO I = 1,NGRID
        P(I) = PF(IJ)
        Q(I) = QF(IJ)
        IJ = IJ+1
      ENDDO
C
C  Tabulate modified exchange terms, including difference corrections
C  ================================
C
      IF (.NOT.HIACC) THEN
C
C  The orbitals are still changing considerably, so use the
C  standard formula for the deferred correction.
C
        DO I = 4,NGRID+1
          XTPT(I-2) = HH*(XTP(I-1)+XTP(I-2))+X1*(P(I-3)-P(I))+X2*(P(I-2)!
     +-P(I-1))
          XTQT(I-2) = HH*(XTQ(I-1)+XTQ(I-2))+X1*(Q(I-3)-Q(I))+X2*(Q(I-2)!
     +-Q(I-1))
        ENDDO
C
      ELSE
C
C  When the orbitals are not changing significantly add the
C  corrections to give an error of O(H**6).
C
        DO I = 5,NGRID+1
          XTPT(I-2) = HH*(XTP(I-1)+XTP(I-2))+X3*(P(I-4)-P(I+1))+X4*(P(I-!
     +3)-P(I))+X5*(P(I-2)-P(I-1))
          XTQT(I-2) = HH*(XTQ(I-1)+XTQ(I-2))+X3*(Q(I-4)-Q(I+1))+X4*(Q(I-!
     +3)-Q(I))+X5*(Q(I-2)-Q(I-1))
        ENDDO
      ENDIF
C
C  Begin iterations
C  ----------------
C  If number of iterations exceeds NFMAX, return with failure  -1
C
   10 CONTINUE
      NTF = NTF-1
      IF (NTF.EQ.0) THEN
        MX = -1
        GOTO 100
      ENDIF
C
C  Copy exchange terms into working space
C
      NGRID = MPOIN(JORB)
      DO I = 1,NGRID
        XU(I) = XTPT(I)
        XV(I) = XTQT(I)
      ENDDO
C
C  Tabulate functions  XF(R)  and  XG(R)
C
      WC = HH*ECL/C
      WB = -H*C-WC
      JP = NGRID-2
      DO I = 1,NGRID
        XF(I) = RGRID(I)*WB+YPT(I)
        XG(I) = RGRID(I)*WC-YQT(I)
      ENDDO
C
C  Choose new estimate of A, if negative
C
      IF (ACL.LE.ZERO) ACL = CSOLV2*ABS(FKJ)
C
C  Print estimates of A and E, if option 19 is set
C
      IF (ITC(19).EQ.1) WRITE (IWRITE,3010) NP(JORB),NH(JORB),ACL,ECL
C
C  Outward integration
C
      CALL OUT(NODES,JORB,VN,ACL,QZE,ALX,ALY,ECL,0,JP,M,MAU,MAE)
C
      IF (M.EQ.2) THEN
        MX = 9
        GOTO 100
      ENDIF
C
      MAU = MAE
      QJP = Q(JP)
C
C  Inward integration - determines endpoint of integration
C  Return with failure 9 if inward integration fails
C
      MF = 0
      CALL IN(JORB,JP,MF,WAC,WBC)
C
      IF (MF.LT.0) THEN
        MX = 9
        GOTO 100
      ENDIF
C
C  Store results of trial integration
C  Note that MF is the last point - use this value for NGRID
C
      NGRID = MF
      DO I = 1,NGRID
        PC(I) = P(I)
        QC(I) = Q(I)
      ENDDO
C
C  Evaluate discrepancy between outward and inward integrations
C  and exit if accurate solution is obtained
C
      DO I = 1,NGRID
        TA(I) = (P(I)*PC(I)+Q(I)*QC(I))*RGRID(I)
      ENDDO
      WXA = Q(JP)-QJP
      CALL QUAD(NGRID,WXB)
      IF (ITC(17).EQ.1) WRITE (IWRITE,3030) NP(JORB),NH(JORB),QJP,Q(JP),!
     +WXA,WXB
C
      WA = ABS(WXA*C)+ABS(WXB-ONE)
      IF (WA.LT.ACCY) GOTO 60
C
C  Set exchange terms to zero
C
      DO I = 1,NGRID
        XU(I) = ZERO
        XV(I) = ZERO
      ENDDO
C
C  Outward and inward integration for homogeneous equations
C
      CALL OUT(NODES,JORB,VN,ACL,WA,ZERO,ZERO,ECL,JP,JP,M,MAE,MAE)
      QCJP = Q(JP)
      CALL IN(JORB,JP,MF,WAC,WBC)
C
      DO I = 1,NGRID
        TA(I) = (P(I)*PC(I)+Q(I)*QC(I))*RGRID(I)
      ENDDO
      WCA = Q(JP)-QCJP
      CALL QUAD(NGRID,WCB)
      IF (ITC(17).EQ.1) WRITE (IWRITE,3030) NP(JORB),NH(JORB),QCJP,Q(JP)!
     +,WCA,WCB
C
C  Compute multiple of complementary function required
C  to give correctly normalised solution
C
      DO I = 1,NGRID
        TA(I) = RGRID(I)*(P(I)*P(I)+Q(I)*Q(I))
      ENDDO
      CALL QUAD(NGRID,WXY)
      WB = WCB*WCB-WXY*(WXB-ONE)
C
C  Return with failure 1 if impossible to normalise solution
C
      IF (WB.LE.ZERO) THEN
        MX = 1
        GOTO 100
      ENDIF
C
      WB = SQRT(WB)
      IF (WCB.LE.ZERO) WB = -WB
      WA = -(WCB-WB)/WXY
C
C  Return with failure 2 if normalised solution has wrong sign
C
      IF (WA+ONE.LE.ZERO) THEN
        MX = 2
        GOTO 100
      ENDIF
C
C  Add required multiple of complementary functions to trial solution
C
      ACL = ACL*(ONE+WA)
      DO I = 1,NGRID
        PC(I) = PC(I)+WA*P(I)
        QC(I) = QC(I)+WA*Q(I)
      ENDDO
      WXA = WXA+WA*WCA
      IF (ITC(17).EQ.1) WRITE (IWRITE,3000) NP(JORB),NH(JORB),WA,WXA,WB,!
     +ACL,WXY
C
C   Tabulate right hand side for variation equations
C
      WA = HH/C
      DO I = 1,NGRID
        XU(I) = QC(I)*WA*RGRID(I)
        XV(I) = -PC(I)*WA*RGRID(I)
      ENDDO
      DO I = 2,NGRID
        XU(I-1) = XU(I)+XU(I-1)
        XV(I-1) = XV(I)+XV(I-1)
      ENDDO
      WB = QZE/C
      WC = -ACL/C
C
C  Outward and inward integration for variation equations
C
      CALL OUT(NODES,JORB,VN,ZERO,WA,WB,WC,ECL,JP,JP,M,MAE,MAE)
      QEJP = Q(JP)
      CALL IN(JORB,JP,MF,WAC,WBC)
C
      DO I = 1,NGRID
        TA(I) = (P(I)*PC(I)+Q(I)*QC(I))*RGRID(I)
      ENDDO
      WEA = Q(JP)-QEJP
      CALL QUAD(NGRID,WEB)
      IF (ITC(17).EQ.1) WRITE (IWRITE,3030) NP(JORB),NH(JORB),QEJP,Q(JP)!
     +,WEA,WEB
C
C  Compute corrections to parameters A and E
C
      DLA = WEB*WXA/(WEA*WCB-WEB*WCA)
      DLE = -WCB*DLA/WEB
C
C  Reduce correction to A if too large
C
   20 CONTINUE
      IF (ABS(DLA).LT.CSOLV1) GOTO 30
      DLA = DLA*HALF
      GOTO 20
C
   30 CONTINUE
      ACL = ACL*(ONE+DLA)
C
C  Reduce correction to E if too large
C
   40 CONTINUE
      IF (ABS(DLE/ECL).LT.CSOLV1) GOTO 50
      DLE = DLE*HALF
      GOTO 40
C
   50 CONTINUE
      ECL = ECL+DLE
C
C  Repeat cycle with new estimates of A and E
C
      GOTO 10
C
C  Normal exit from SOLV
C  ---------------------
C
   60 CONTINUE
C
C  Normalise the solution
C
      WB = ONE/SQRT(WXB)
      DO I = 1,NGRID
        P(I) = P(I)*WB
        Q(I) = Q(I)*WB
      ENDDO
C
C  Print table of solution if option 16 requested
C
      IF (ITC(16).EQ.1) CALL PRWF(JORB)
C
C  Count number of zeros in table of P(R)
C
      NODE = 0
      JPX = JP+4
      DO I = 3,JPX
        IF (P(I-1)*P(I-2)) 80,70,90
   70   CONTINUE
        IF (P(I)*P(I-2)) 80,90,90
   80   CONTINUE
        NODE = NODE+1
   90   CONTINUE
      ENDDO
C
C  Failure number -2 if wrong number of zeros
C
      IF (NODE.NE.NODES) THEN
        MX = -2
        GOTO 100
      ENDIF
C
C  Normal return, storing results
C
      E(JORB) = ECL
      PZ(JORB) = ACL
      QZ(JORB) = QZE
      MX = 0
      NPOINT = NGRID
C
      IF (NGRID.LT.MPOIN(JORB)) THEN
        DO I = NGRID+1,MPOIN(JORB)
          P(I) = ZERO
          Q(I) = ZERO
        ENDDO
      ENDIF
C
  100 CONTINUE
      IF (ITC(19).EQ.1) THEN
        IF (MX.EQ.-2) WRITE (IWRITE,3060) NP(JORB),NH(JORB)
        IF (MX.EQ.-1) WRITE (IWRITE,3070) NP(JORB),NH(JORB)
        IF (MX.EQ.1) WRITE (IWRITE,3080) NP(JORB),NH(JORB)
        IF (MX.EQ.2) WRITE (IWRITE,3090) NP(JORB),NH(JORB)
        IF (MX.EQ.3) WRITE (IWRITE,3100) NP(JORB),NH(JORB)
        IF (MX.EQ.4) WRITE (IWRITE,3110) NP(JORB),NH(JORB)
        IF (MX.EQ.9) WRITE (IWRITE,3120) NP(JORB),NH(JORB)
        IF (MX.EQ.0) WRITE (IWRITE,3050) NP(JORB),NH(JORB)
      ENDIF
C
 3000 FORMAT ('  SOLV17  ',I2,A2,2X,1P,4E12.4/'                ',4E12.4)
 3010 FORMAT ('  SOLV19  ',I2,A2,2X,1P,4E12.4/'                ',4E12.4)
 3020 FORMAT ('  SOLV19  ',I2,A2,2X,1P,4E12.4/'                ',3E12.4,!
     +I5)
 3030 FORMAT (' MATCH17  ',I2,A2,2X,1P,4E12.4/'                ',4E12.4)
 3040 FORMAT (/                                                         !
     +' STOPPING in SOLV0 due to a dimension ERROR for the grid points'/!
     +' The number required is ',I4,' plus 2 which exceeds MXNP = ',I4)
 3050 FORMAT ('  SOLV19  ',I2,A2,' success')
 3060 FORMAT ('  SOLV19  ',I2,A2,' failure : wrong number of zeros')
 3070 FORMAT ('  SOLV19  ',I2,A2,                                       !
     +' failure : number of iterations exceeded')
 3080 FORMAT ('  SOLV19  ',I2,A2,                                       !
     +' failure : solution cannot be normalised')
 3090 FORMAT ('  SOLV19  ',I2,A2,                                       !
     +' failure : normalised solution has wrong sign')
 3100 FORMAT ('  SOLV19  ',I2,A2,' failure : no positive eigenvalue')
 3110 FORMAT ('  SOLV19  ',I2,A2,                                       !
     +' failure : matching point is too far out')
 3120 FORMAT ('  SOLV19  ',I2,A2,' failure : insufficient grid points')
      END
C
C                             *******************
C
      SUBROUTINE SOLV1(JORB,VN,XCF,AST,EST,MX,HIACC,XTPT,XTQT,YPT,YQT,NP!
     +OINT)
C
C-----------------------------------------------------------------------
C
C  **** New version of SOLV ****
C  **** No exchange case    ****
C
C  This subroutine solves a single pair of Dirac radial equations.
C  The direct potentials are tabulated in YP and YQ.
C  The exchange potentials are tabulated in XTP and XTQ.
C
C  DATA
C
C  JORB  serial number of wave function
C  VN    coefficient of R in expansion of direct potential
C  XCF   scale factor multiplying exchange term
C  AST   estimate of A.
C  EST   estimate of eigenvalue  E.
C  HIACC a logical variable which is set .TRUE. if higher order
C        terms are to be included in the deferred correction, to
C        give an error which varies as O(H**6).
C
C  RESULTS
C
C  MX       should be zero. A non-zero value indicates failure.
C  E(JORB)  the eigenvalue
C  NPOINT   number of points in wave-function
C
C  The wave functions will be tabulated in arrays P and Q.
C  Coefficients in series expansions are stored in PZ(JORB), QZ(JORB).
C
C  Subroutines called : PRWF, OUT, IN, QUAD
C
C-----------------------------------------------------------------------
C
C  maximum number of iterations is set here
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  Parameter variables
C
      DOUBLE PRECISION CSOLV1
      PARAMETER (CSOLV1=0.3D0)
      DOUBLE PRECISION CSOLV2
      PARAMETER (CSOLV2=1.D2)
      DOUBLE PRECISION X1
      PARAMETER (X1=1.D0/12.D0)
      DOUBLE PRECISION X2
      PARAMETER (X2=-.25D0)
      DOUBLE PRECISION X3
      PARAMETER (X3=-1.D0/120.D0)
      DOUBLE PRECISION X4
      PARAMETER (X4=0.125D0)
      DOUBLE PRECISION X5
      PARAMETER (X5=-1.D0/3.D0)
      DOUBLE PRECISION EPS5
      PARAMETER (EPS5=1.D-5)
      INTEGER N11
      PARAMETER (N11=MXNP+10)
      INTEGER NFMAX
      PARAMETER (NFMAX=25)
C
C  Argument variables
C
      DOUBLE PRECISION AST,EST,VN,XCF
      DOUBLE PRECISION XTPT(MXNP),XTQT(MXNP),YPT(MXNP)
      DOUBLE PRECISION YQT(MXNP)
      INTEGER JORB,MX,NPOINT
      LOGICAL HIACC
C
C  Local variables
C
      DOUBLE PRECISION ACL,DLE,ECL,EHG
      DOUBLE PRECISION ELW,FKJ,HH,QJP
      DOUBLE PRECISION QZE,WA,WAC,WB
      DOUBLE PRECISION WBC,WC,WD,WXA
      DOUBLE PRECISION WXB
      INTEGER I,IJ,JP,JPX
      INTEGER KJ,M,MAE,MF
      INTEGER NGRID,NODE,NODES,NTF
C
C  Common variables
C
      DOUBLE PRECISION HALF,ONE,TEN,TENTH
      DOUBLE PRECISION THREE,TWO,ZERO
      COMMON / CONS   / ZERO,HALF,TENTH,ONE,TWO,THREE,TEN
C
C  Common variables
C
      DOUBLE PRECISION ACCY,C,EPH,H
      DOUBLE PRECISION RNT,Z
      INTEGER N,NCPRIN,NW1
      COMMON / DEF01  / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN
C
C  Common variables
C
      DOUBLE PRECISION PZ(MXNW),QZ(MXNW)
      COMMON / EXCO   / PZ,QZ
C
C  Common variables
C
      DOUBLE PRECISION RGRID(MXNP)
      COMMON / GRID   / RGRID
C
C  Common variables
C
      INTEGER IPUNCH,IREAD,IWRITE
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
C
C  Common variables
C
      DOUBLE PRECISION P(MXNP),PC(MXNP),Q(MXNP)
      DOUBLE PRECISION QC(MXNP)
      COMMON / INT2   / P,Q,PC,QC
C
C  Common variables
C
      DOUBLE PRECISION XF(MXNP),XG(MXNP),XR(MXNP)
      DOUBLE PRECISION XS(MXNP),XU(MXNP),XV(MXNP)
      COMMON / INT3   / XU,XV,XR,XS,XF,XG
C
C  Common variables
C
      INTEGER ITC(50)
      COMMON / OPT01  / ITC
C
C  Common variables
C
      CHARACTER*2 NH(MXNW)
      COMMON / ORB00  / NH
C
C  Common variables
C
      DOUBLE PRECISION E(MXNW)
      COMMON / ORB01  / E
C
C  Common variables
C
      INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF
      INTEGER NP(MXNW),NW
      COMMON / ORB04  / NW,NCF,NP,NAK,IQ
C
C  Common variables
C
      INTEGER MPOIN(MXNW),MPOS(MXNW)
      COMMON / PATY   / MPOIN,MPOS
C
C  Common variables
C
      DOUBLE PRECISION XTP(MXNP),XTQ(MXNP),YP(MXNP)
      DOUBLE PRECISION YQ(MXNP)
      COMMON / POTE   / YP,YQ,XTP,XTQ
C
C  Common variables
C
      DOUBLE PRECISION TA(N11),TB(N11)
      COMMON / TATB   / TA,TB
C
C  Common variables
C
      DOUBLE PRECISION PF(MXNG),QF(MXNG)
      COMMON / WAVE   / PF,QF
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
      NGRID = MPOIN(JORB)
      IF (ITC(19).EQ.1) WRITE (IWRITE,3020) NP(JORB),NH(JORB),VN,XCF,AST!
     +,EST,Z,NGRID
C
      NPOINT = NGRID
      KJ = NAK(JORB)
      FKJ = DBLE(KJ)
C
C  NODES is the number of zeros required in P(R)
C
      IF (KJ.LT.0) THEN
        NODES = NP(JORB)+KJ
      ELSE
        NODES = NP(JORB)-KJ-1
      ENDIF
C
C  Begin from given estimates of A and E
C
      ACL = AST
      ECL = EST
C
C  Count iterations in NTF
C
      NTF = NFMAX+1
C
      ELW = -ONE
      EHG = -ONE
C
      HH = -H*HALF
      WA = -FKJ*HH
      WAC = ONE+WA
      WBC = ONE-WA
C
C  Tabulate modified direct potentials
C  ===================================
C  Clear exchange potential arrays
C
      WD = HH/C
      DO I = 1,NGRID
        XTPT(I) = ZERO
        XTQT(I) = ZERO
        YPT(I) = WD*YP(I)
        YQT(I) = WD*YQ(I)
      ENDDO
C
C  Include difference corrections   for XCF=0
C  ==============================
C
      IF (XCF.EQ.ZERO) THEN
C
C  Set the P and Q arrays to zero for I.GT.NGRID
C
        IF (NGRID+2.LE.MXNP) THEN
          DO I = NGRID+1,NGRID+2
            P(I) = ZERO
            Q(I) = ZERO
          ENDDO
        ELSE
          WRITE (IWRITE,3040) NGRID,MXNP
          WRITE (IPUNCH,3040) NGRID,MXNP
          STOP
        ENDIF
C
        IJ = MPOS(JORB)
        DO I = 1,NGRID
          P(I) = PF(IJ)
          Q(I) = QF(IJ)
          IJ = IJ+1
        ENDDO
C
C  Tabulate modified exchange terms, including difference corrections
C  ================================
C
        IF (.NOT.HIACC) THEN
C
C  The orbitals are still changing considerably, so use the
C  standard formula for the deferred correction.
C
          DO I = 4,NGRID+1
            XTPT(I-2) = HH*(XTP(I-1)+XTP(I-2))+X1*(P(I-3)-P(I))+X2*(P(I-!
     +2)-P(I-1))
            XTQT(I-2) = HH*(XTQ(I-1)+XTQ(I-2))+X1*(Q(I-3)-Q(I))+X2*(Q(I-!
     +2)-Q(I-1))
          ENDDO
C
        ELSE
C
C  When the orbitals are not changing significantly add the
C  corrections to give an error of O(h**6).
C
          DO I = 5,NGRID+1
            XTPT(I-2) = HH*(XTP(I-1)+XTP(I-2))+X3*(P(I-4)-P(I+1))+X4*(P(!
     +I-3)-P(I))+X5*(P(I-2)-P(I-1))
            XTQT(I-2) = HH*(XTQ(I-1)+XTQ(I-2))+X3*(Q(I-4)-Q(I+1))+X4*(Q(!
     +I-3)-Q(I))+X5*(Q(I-2)-Q(I-1))
          ENDDO
C
        ENDIF
C
      ENDIF
C
C  Begin iterations
C  ----------------
C  If number of iterations exceeds NFMAX, return with failure -1
C
   10 CONTINUE
      NTF = NTF-1
      IF (NTF.EQ.0) THEN
        MX = -1
        RETURN
      ENDIF
C
C  Copy exchange terms into working space
C
      NGRID = MPOIN(JORB)
      DO I = 1,NGRID
        XU(I) = XTPT(I)
        XV(I) = XTQT(I)
      ENDDO
C
C  Tabulate functions XF(R) and XG(R)
C
      WC = HH*ECL/C
      WB = -H*C-WC
      JP = NGRID-2
      DO I = 1,NGRID
        XF(I) = RGRID(I)*WB+YPT(I)
        XG(I) = RGRID(I)*WC-YQT(I)
      ENDDO
C
C  Choose new estimate of A, if negative
C
      IF (ACL.LE.ZERO) ACL = CSOLV2*ABS(FKJ)
C
C  Print estimates of A and E, if option 19 is set
C
      IF (ITC(19).EQ.1) WRITE (IWRITE,3010) NP(JORB),NH(JORB),ACL,ECL
C
C  Outward integration
C
      CALL OUT(NODES,JORB,VN,ACL,QZE,ZERO,ZERO,ECL,0,JP,M,0,MAE)
C
C  Test for failure
C
      IF (M.LT.0) THEN
C
C  Store low eigenvalue estimate
C
        ELW = ECL
        IF (EHG+HALF.LE.ZERO) THEN
C
C  If no high estimate available, use double the low estimate
C
          ECL = ECL+ECL
C
        ELSE
C
C  Bisection if two estimates available
C
          ECL = HALF*(ELW+EHG)
        ENDIF
C
        GOTO 10
C
      ELSE
        IF (M.GT.0) THEN
C
C  Store high estimate
C
          EHG = ECL
C
C  Failure number 3 if no positive eigenvalue
C
          IF (ECL.LT.EPS5) THEN
            MX = 3
            RETURN
C
          ELSE
            IF (ELW+HALF.LE.ZERO) THEN
C
C  If no low estimate available, use zero
C
              ECL = ZERO
C
            ELSE
C
C  Bisection if two estimates available
C
              ECL = HALF*(ELW+EHG)
            ENDIF
C
          ENDIF
C
          GOTO 10
C
        ENDIF
C
      ENDIF
C
C  Inward integration - determines endpoint of integration
C  ------------------
C  Return with failure 9 if inward integration fails
C
      QJP = Q(JP)
      MF = 0
      CALL IN(JORB,JP,MF,WAC,WBC)
      IF (MF.LT.0) THEN
        MX = 9
        RETURN
      ENDIF
C
C  Note that MF is the last point - use this value for NGRID
C
      NGRID = MF
      DO I = 1,NGRID
        TA(I) = (P(I)*P(I)+Q(I)*Q(I))*RGRID(I)
      ENDDO
      WXA = Q(JP)-QJP
      CALL QUAD(NGRID,WXB)
      IF (ITC(17).EQ.1) WRITE (IWRITE,3030) NP(JORB),NH(JORB),QJP,Q(JP),!
     +WXA,WXB
C
C  Accept if sufficiently good fit
C
      WA = ABS(WXA*C)+ABS(WXB-ONE)
      IF (WA.GT.ACCY) THEN
C
C  Repeat cycle with corrected values of A and E
C
        DLE = C*P(JP)*WXA/WXB
        ACL = ACL/SQRT(WXB)
        IF (ITC(18).EQ.1) WRITE (IWRITE,3000) NP(JORB),NH(JORB),DLE
C
C  Reduce correction to E if too large
C
   20   CONTINUE
        IF (ABS(DLE/ECL).LT.CSOLV1) GOTO 30
        DLE = DLE*HALF
        GOTO 20
C
   30   CONTINUE
        IF (DLE.GT.ZERO) ELW = ECL
        IF (DLE.LT.ZERO) EHG = ECL
        ECL = ECL+DLE
C
C  Repeat cycle with new estimates of A and E
C
        GOTO 10
C
      ENDIF
C
C  Normal exit from SOLV
C  ---------------------
C
C  Normalise the solution
C
      WB = ONE/SQRT(WXB)
      DO I = 1,NGRID
        P(I) = P(I)*WB
        Q(I) = Q(I)*WB
      ENDDO
C
C  Print table of solution if option 16 requested
C
      IF (ITC(16).EQ.1) CALL PRWF(JORB)
C
C  Count number of zeros in table of P(R)
C
      NODE = 0
      JPX = JP+4
      DO I = 3,JPX
        IF (P(I-1)*P(I-2)) 50,40,60
   40   CONTINUE
        IF (P(I)*P(I-2)) 50,60,60
   50   CONTINUE
        NODE = NODE+1
   60   CONTINUE
      ENDDO
C
C    FAILURE NUMBER  -2  IF WRONG NUMBER OF ZEROS
C
      IF (NODE.NE.NODES) THEN
        MX = -2
        RETURN
C
      ENDIF
C
C    NORMAL RETURN, STORING RESULTS
C
      E(JORB) = ECL
      PZ(JORB) = ACL
      QZ(JORB) = QZE
      MX = 0
      NPOINT = NGRID
C
      IF (NGRID.LT.MPOIN(JORB)) THEN
        DO I = NGRID+1,MPOIN(JORB)
          P(I) = ZERO
          Q(I) = ZERO
        ENDDO
      ENDIF
C
 3000 FORMAT (' *SOLV18  ',I2,A2,2X,1P,4E12.4/'                ',4E12.4)
 3010 FORMAT (' *SOLV19  ',I2,A2,2X,1P,4E12.4/'                ',4E12.4)
 3020 FORMAT (' *SOLV19  ',I2,A2,2X,1P,2E12.4,24X/'                ',3E1!
     +2.4,I5)
 3030 FORMAT (' MATCH17  ',I2,A2,2X,1P,4E12.4/'                ',4E12.4)
 3040 FORMAT (/                                                         !
     +' STOPPING in SOLV1 due to a dimension error for the grid points'/!
     +' The number required is ',I4,' plus 2 which exceeds MXNP = ',I4)
      END
C
C                             *******************
C
      SUBROUTINE SPEAKG(IMARK,ITYPE,IIA,IIB,IIC,IID,K,COEF)
C
C-----------------------------------------------------------------------
C
C  Output MCP/MCBP coefficients to file on stream NOUT1 if NOUT1 > 0.
C  Also print these if IBUG1=1.
C
C   ITYPE=1 to 6 .... Breit integrals
C
C   ITYPE=7  one-electron integrals
C   ITYPE=8  direct Slater integrals
C   ITYPE=9  exchange Slater integrals
C
C  If ITYPE<0 then the integral is part of the core contribution
C    i.e. only stored for the first CSF and must be included for others.
C
C  If IMARK=1 then integral belongs to core/peel or core/core.
C
C       SPEAKG
C           RAT1
C
C   Common block ANG02:
C     Elements used but never set: all
C   Common block ANG04:
C     Elements used but never set: JA JB NWA
C   Common block DEBUG:
C     Elements used but never set: IBUG1
C     Elements never used, never set: IBUG2 IBUG3 IBUG4 IBUG5 IBUG6
C   Common block INFORM:
C     Elements used but never set: IWRITE IPUNCH
C     Elements never used, never set: IREAD
C   Common block ORB00:
C     Elements used but never set: all
C   Common block ORB04:
C     Elements used but never set: NP
C     Elements never used, never set: NW NCF NAK IQ
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  Parameter variables
C
      DOUBLE PRECISION EPS10
      PARAMETER (EPS10=1.D-10)
C
C  Argument variables
C
      DOUBLE PRECISION COEF
      INTEGER IIA,IIB,IIC,IID
      INTEGER IMARK,ITYPE,K
C
C  Local variables
C
      INTEGER IA,IB,IC,ID
      INTEGER IRAT(4),ISTORE,ITY,MODE
      INTEGER XA,XB,XC,XD
C
C  Common variables
C
      INTEGER NOUT1
      COMMON / ANG02  / NOUT1
C
C  Common variables
C
      INTEGER ITOT(9),JTOT(9),KTOT(9)
      COMMON / ANG03  / ITOT,JTOT,KTOT
C
C  Common variables
C
      INTEGER IME,JA,JB,NWA
      COMMON / ANG04  / IME,JA,JB,NWA
C
C  Common variables
C
      INTEGER IBUG1,IBUG2,IBUG3,IBUG4
      INTEGER IBUG5,IBUG6
      COMMON / DEBUG  / IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6
C
C  Common variables
C
      INTEGER IPUNCH,IREAD,IWRITE
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
C
C  Common variables
C
      CHARACTER*2 NH(MXNW)
      COMMON / ORB00  / NH
C
C  Common variables
C
      INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF
      INTEGER NP(MXNW),NW
      COMMON / ORB04  / NW,NCF,NP,NAK,IQ
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
      IF (ABS(COEF).LT.EPS10) RETURN
C
      IA = IIA
      IB = IIB
      IC = IIC
      ID = IID
C
      IF (ITYPE.LT.0) THEN
        ITY = ABS(ITYPE)
        JTOT(ITY) = JTOT(ITY)+1
      ELSE
        ITOT(ITYPE) = ITOT(ITYPE)+1
      ENDIF
C-----------------------------------------------------------------------
C
C   Breit angular coefficients
C
      IF (ABS(ITYPE).LE.6) THEN
C
        ISTORE = (((K*NWA+IA)*NWA+IB)*NWA+IC)*NWA+ID
        IF (NOUT1.GT.0) WRITE (NOUT1) ISTORE,ITYPE,COEF
C
        IF (IBUG1.EQ.1) THEN
C
          WRITE (IWRITE,3000) JA,JB,NP(IA),NH(IA),NP(IB),NH(IB),NP(IC),N!
     +H(IC),NP(ID),NH(ID),K,COEF,ISTORE,ITYPE
          IME = IME+1
C
          CALL RAT1(COEF,IRAT)
C
          XA = IRAT(1)
          XB = IRAT(2)
          XC = IRAT(3)
          XD = IRAT(4)
C
          IF (XD.EQ.1) THEN
            IF (XC.EQ.1) THEN
              IF (XB.EQ.1) THEN
                MODE = 1
              ELSE
                MODE = 2
              ENDIF
            ELSE
              IF (XB.EQ.1) THEN
                IF (XA.EQ.1) THEN
                  MODE = 7
                ELSE
                  MODE = 3
                ENDIF
              ELSE
                MODE = 5
              ENDIF
            ENDIF
          ELSE
            IF (XB.EQ.1) THEN
              IF (XA.EQ.1) THEN
                MODE = 8
              ELSE
                MODE = 6
              ENDIF
            ELSE
              MODE = 4
            ENDIF
          ENDIF
C
          IF (MODE.EQ.1) THEN
            WRITE (IPUNCH,3020) ITYPE,JA,JB,K,NP(IA),NH(IA),NP(IB),NH(IB!
     +),NP(IC),NH(IC),NP(ID),NH(ID),XA
            RETURN
          ENDIF
C
          IF (MODE.EQ.2) THEN
            WRITE (IPUNCH,3030) ITYPE,JA,JB,K,NP(IA),NH(IA),NP(IB),NH(IB!
     +),NP(IC),NH(IC),NP(ID),NH(ID),XA,XB
            RETURN
          ENDIF
C
          IF (MODE.EQ.3) THEN
            WRITE (IPUNCH,3040) ITYPE,JA,JB,K,NP(IA),NH(IA),NP(IB),NH(IB!
     +),NP(IC),NH(IC),NP(ID),NH(ID),XA,XC
            RETURN
          ENDIF
C
          IF (MODE.EQ.4) THEN
            WRITE (IPUNCH,3050) ITYPE,JA,JB,K,NP(IA),NH(IA),NP(IB),NH(IB!
     +),NP(IC),NH(IC),NP(ID),NH(ID),XA,XB,XC,XD
            RETURN
          ENDIF
C
          IF (MODE.EQ.5) THEN
            WRITE (IPUNCH,3060) ITYPE,JA,JB,K,NP(IA),NH(IA),NP(IB),NH(IB!
     +),NP(IC),NH(IC),NP(ID),NH(ID),XA,XB,XC
            RETURN
          ENDIF
C
          IF (MODE.EQ.6) THEN
            WRITE (IPUNCH,3070) ITYPE,JA,JB,K,NP(IA),NH(IA),NP(IB),NH(IB!
     +),NP(IC),NH(IC),NP(ID),NH(ID),XA,XC,XD
            RETURN
          ENDIF
C
          IF (MODE.EQ.7) THEN
            WRITE (IPUNCH,3080) ITYPE,JA,JB,K,NP(IA),NH(IA),NP(IB),NH(IB!
     +),NP(IC),NH(IC),NP(ID),NH(ID),XC
            RETURN
          ENDIF
C
          IF (MODE.EQ.8) THEN
            WRITE (IPUNCH,3090) ITYPE,JA,JB,K,NP(IA),NH(IA),NP(IB),NH(IB!
     +),NP(IC),NH(IC),NP(ID),NH(ID),XC,XD
            RETURN
          ENDIF
C
        ENDIF
C
        RETURN
C
      ENDIF
C-----------------------------------------------------------------------
C
C   Coulomb angular coefficients
C
      IF (ABS(ITYPE).EQ.7) THEN
        ISTORE = IC*NWA+ID
        IF (IMARK.EQ.1) THEN
          ISTORE = -ISTORE
          KTOT(7) = KTOT(7)+1
        ENDIF
        IF (IBUG1.EQ.1) WRITE (IWRITE,3010) JA,JB,NP(IC),NH(IC),NP(ID),N!
     +H(ID),COEF,ISTORE,ITYPE
      ELSE
        ISTORE = (((K*NWA+IA)*NWA+IB)*NWA+IC)*NWA+ID
        IF (IMARK.EQ.1) THEN
          ISTORE = -ISTORE
          IF (ABS(ITYPE).EQ.8) KTOT(8) = KTOT(8) + 1
          IF (ABS(ITYPE).EQ.9) KTOT(9) = KTOT(9) + 1
        ENDIF
        IF (IBUG1.EQ.1) WRITE (IWRITE,3000) JA,JB,NP(IA),NH(IA),NP(IB),N!
     +H(IB),NP(IC),NH(IC),NP(ID),NH(ID),K,COEF,ISTORE,ITYPE
      ENDIF
C
      IF (NOUT1.GT.0) WRITE (NOUT1) ISTORE,ITYPE,COEF
C
      IF (IBUG1.EQ.1) THEN
        IME = IME+1
C
C   ITY = 0   I integral
C       = 1   F integral
C       = 2   G integral
C       = 3   R integral
C
        IF (ABS(ITYPE).EQ.7) THEN
          ITY = 0
        ELSE
          IF (IA.EQ.IC .AND. IB.EQ.ID) THEN
            ITY = 1
          ELSE
            IF (IA.EQ.ID .AND. IB.EQ.IC) THEN
              ITY = 2
            ELSE
              IF (IA.EQ.IB .AND. IC.EQ.ID) THEN
                ITY = 2
                IB = IC
              ELSE
                ITY = 3
              ENDIF
            ENDIF
          ENDIF
        ENDIF
C
        CALL RAT1(COEF,IRAT)
C
        XA = IRAT(1)
        XB = IRAT(2)
        XC = IRAT(3)
        XD = IRAT(4)
C
        IF (XD.EQ.1) THEN
          IF (XC.EQ.1) THEN
            IF (XB.EQ.1) THEN
              MODE = 1
            ELSE
              MODE = 2
            ENDIF
          ELSE
            IF (XB.EQ.1) THEN
              IF (XA.EQ.1) THEN
                MODE = 7
              ELSE
                MODE = 3
              ENDIF
            ELSE
              MODE = 5
            ENDIF
          ENDIF
        ELSE
          IF (XB.EQ.1) THEN
            IF (XA.EQ.1) THEN
              MODE = 8
            ELSE
              MODE = 6
            ENDIF
          ELSE
            MODE = 4
          ENDIF
        ENDIF
C
        IF (ITY.EQ.3) THEN
C
          IF (MODE.EQ.1) THEN
            WRITE (IPUNCH,3100) ITYPE,JA,JB,K,NP(IA),NH(IA),NP(IB),NH(IB!
     +),NP(IC),NH(IC),NP(ID),NH(ID),XA
            RETURN
          ENDIF
C
          IF (MODE.EQ.2) THEN
            WRITE (IPUNCH,3110) ITYPE,JA,JB,K,NP(IA),NH(IA),NP(IB),NH(IB!
     +),NP(IC),NH(IC),NP(ID),NH(ID),XA,XB
            RETURN
          ENDIF
C
          IF (MODE.EQ.3) THEN
            WRITE (IPUNCH,3120) ITYPE,JA,JB,K,NP(IA),NH(IA),NP(IB),NH(IB!
     +),NP(IC),NH(IC),NP(ID),NH(ID),XA,XC
            RETURN
          ENDIF
C
          IF (MODE.EQ.4) THEN
            WRITE (IPUNCH,3130) ITYPE,JA,JB,K,NP(IA),NH(IA),NP(IB),NH(IB!
     +),NP(IC),NH(IC),NP(ID),NH(ID),XA,XB,XC,XD
            RETURN
          ENDIF
C
          IF (MODE.EQ.5) THEN
            WRITE (IPUNCH,3140) ITYPE,JA,JB,K,NP(IA),NH(IA),NP(IB),NH(IB!
     +),NP(IC),NH(IC),NP(ID),NH(ID),XA,XB,XC
            RETURN
          ENDIF
C
          IF (MODE.EQ.6) THEN
            WRITE (IPUNCH,3150) ITYPE,JA,JB,K,NP(IA),NH(IA),NP(IB),NH(IB!
     +),NP(IC),NH(IC),NP(ID),NH(ID),XA,XC,XD
            RETURN
          ENDIF
C
          IF (MODE.EQ.7) THEN
            WRITE (IPUNCH,3160) ITYPE,JA,JB,K,NP(IA),NH(IA),NP(IB),NH(IB!
     +),NP(IC),NH(IC),NP(ID),NH(ID),XC
            RETURN
          ENDIF
C
          IF (MODE.EQ.8) THEN
            WRITE (IPUNCH,3170) ITYPE,JA,JB,K,NP(IA),NH(IA),NP(IB),NH(IB!
     +),NP(IC),NH(IC),NP(ID),NH(ID),XC,XD
            RETURN
          ENDIF
C
        ENDIF
C
        IF (ITY.EQ.2) THEN
C
          IF (MODE.EQ.1) THEN
            WRITE (IPUNCH,3180) ITYPE,JA,JB,K,NP(IA),NH(IA),NP(IB),NH(IB!
     +),XA
            RETURN
          ENDIF
C
          IF (MODE.EQ.2) THEN
            WRITE (IPUNCH,3190) ITYPE,JA,JB,K,NP(IA),NH(IA),NP(IB),NH(IB!
     +),XA,XB
            RETURN
          ENDIF
C
          IF (MODE.EQ.3) THEN
            WRITE (IPUNCH,3200) ITYPE,JA,JB,K,NP(IA),NH(IA),NP(IB),NH(IB!
     +),XA,XC
            RETURN
          ENDIF
C
          IF (MODE.EQ.4) THEN
            WRITE (IPUNCH,3210) ITYPE,JA,JB,K,NP(IA),NH(IA),NP(IB),NH(IB!
     +),XA,XB,XC,XD
            RETURN
          ENDIF
C
          IF (MODE.EQ.5) THEN
            WRITE (IPUNCH,3220) ITYPE,JA,JB,K,NP(IA),NH(IA),NP(IB),NH(IB!
     +),XA,XB,XC
            RETURN
          ENDIF
C
          IF (MODE.EQ.6) THEN
            WRITE (IPUNCH,3230) ITYPE,JA,JB,K,NP(IA),NH(IA),NP(IB),NH(IB!
     +),XA,XC,XD
            RETURN
          ENDIF
C
          IF (MODE.EQ.7) THEN
            WRITE (IPUNCH,3240) ITYPE,JA,JB,K,NP(IA),NH(IA),NP(IB),NH(IB!
     +),XC
            RETURN
          ENDIF
C
          IF (MODE.EQ.8) THEN
            WRITE (IPUNCH,3250) ITYPE,JA,JB,K,NP(IA),NH(IA),NP(IB),NH(IB!
     +),XC,XD
            RETURN
          ENDIF
C
        ENDIF
C
        IF (ITY.EQ.1) THEN
C
          IF (MODE.EQ.1) THEN
            WRITE (IPUNCH,3260) ITYPE,JA,JB,K,NP(IA),NH(IA),NP(IB),NH(IB!
     +),XA
            RETURN
          ENDIF
C
          IF (MODE.EQ.2) THEN
            WRITE (IPUNCH,3270) ITYPE,JA,JB,K,NP(IA),NH(IA),NP(IB),NH(IB!
     +),XA,XB
            RETURN
          ENDIF
C
          IF (MODE.EQ.3) THEN
            WRITE (IPUNCH,3280) ITYPE,JA,JB,K,NP(IA),NH(IA),NP(IB),NH(IB!
     +),XA,XC
            RETURN
          ENDIF
C
          IF (MODE.EQ.4) THEN
            WRITE (IPUNCH,3290) ITYPE,JA,JB,K,NP(IA),NH(IA),NP(IB),NH(IB!
     +),XA,XB,XC,XD
            RETURN
          ENDIF
C
          IF (MODE.EQ.5) THEN
            WRITE (IPUNCH,3300) ITYPE,JA,JB,K,NP(IA),NH(IA),NP(IB),NH(IB!
     +),XA,XB,XC
            RETURN
          ENDIF
C
          IF (MODE.EQ.6) THEN
            WRITE (IPUNCH,3310) ITYPE,JA,JB,K,NP(IA),NH(IA),NP(IB),NH(IB!
     +),XA,XC,XD
            RETURN
          ENDIF
C
          IF (MODE.EQ.7) THEN
            WRITE (IPUNCH,3320) ITYPE,JA,JB,K,NP(IA),NH(IA),NP(IB),NH(IB!
     +),XC
            RETURN
          ENDIF
C
          IF (MODE.EQ.8) THEN
            WRITE (IPUNCH,3330) ITYPE,JA,JB,K,NP(IA),NH(IA),NP(IB),NH(IB!
     +),XC,XD
            RETURN
          ENDIF
C
        ENDIF
C
        IF (ITY.EQ.0) THEN
C
          IF (MODE.EQ.1) THEN
            WRITE (IPUNCH,3340) ITYPE,JA,JB,NP(IC),NH(IC),NP(ID),NH(ID),!
     +XA
            RETURN
          ENDIF
C
          IF (MODE.EQ.2) THEN
            WRITE (IPUNCH,3350) ITYPE,JA,JB,NP(IC),NH(IC),NP(ID),NH(ID),!
     +XA,XB
            RETURN
          ENDIF
C
          IF (MODE.EQ.3) THEN
            WRITE (IPUNCH,3360) ITYPE,JA,JB,NP(IC),NH(IC),NP(ID),NH(ID),!
     +XA,XC
            RETURN
          ENDIF
C
          IF (MODE.EQ.4) THEN
            WRITE (IPUNCH,3370) ITYPE,JA,JB,NP(IC),NH(IC),NP(ID),NH(ID),!
     +XA,XB,XC,XD
            RETURN
          ENDIF
C
          IF (MODE.EQ.5) THEN
            WRITE (IPUNCH,3380) ITYPE,JA,JB,NP(IC),NH(IC),NP(ID),NH(ID),!
     +XA,XB,XC
            RETURN
          ENDIF
C
          IF (MODE.EQ.6) THEN
            WRITE (IPUNCH,3390) ITYPE,JA,JB,NP(IC),NH(IC),NP(ID),NH(ID),!
     +XA,XC,XD
            RETURN
          ENDIF
C
          IF (MODE.EQ.7) THEN
            WRITE (IPUNCH,3400) ITYPE,JA,JB,NP(IC),NH(IC),NP(ID),NH(ID),!
     +XC
            RETURN
          ENDIF
C
          IF (MODE.EQ.8) THEN
            WRITE (IPUNCH,3410) ITYPE,JA,JB,NP(IC),NH(IC),NP(ID),NH(ID),!
     +XC,XD
            RETURN
          ENDIF
C
        ENDIF
C
      ENDIF
C-----------------------------------------------------------------------
 3000 FORMAT (1X,2I4,2X,4(I2,A2,1X),1X,I2,2X,1P,E16.9,2X,I9,2X,I2)
 3010 FORMAT (1X,2I4,2X,2(1X,'**',2X),2(I2,A2,1X),5X,1P,E16.9,2X,I9,2X,I!
     +2)
 3020 FORMAT (1X,I2,2I4,' X(',I2,';',3(I2,A2,','),I2,A2,')  ',I7)
 3030 FORMAT (1X,I2,2I4,' X(',I2,';',3(I2,A2,','),I2,A2,')  ',I7,'/',I7)
 3040 FORMAT (1X,I2,2I4,' X(',I2,';',3(I2,A2,','),I2,A2,')  ',I7,' ',7X,!
     +' * S (',I7,' ',7X,')')
 3050 FORMAT (1X,I2,2I4,' X(',I2,';',3(I2,A2,','),I2,A2,')  ',I7,'/',I7,!
     +' * S (',I7,'/',I7,')')
 3060 FORMAT (1X,I2,2I4,' X(',I2,';',3(I2,A2,','),I2,A2,')  ',I7,'/',I7,!
     +' * S (',I7,' ',7X,')')
 3070 FORMAT (1X,I2,2I4,' X(',I2,';',3(I2,A2,','),I2,A2,')  ',I7,' ',7X,!
     +' * S (',I7,'/',I7,')')
 3080 FORMAT (1X,I2,2I4,' X(',I2,';',3(I2,A2,','),I2,A2,')  ',7X,' ',7X,!
     +'   S (',I7,' ',7X,')')
 3090 FORMAT (1X,I2,2I4,' X(',I2,';',3(I2,A2,','),I2,A2,')  ',7X,' ',7X,!
     +'   S (',I7,'/',I7,')')
 3100 FORMAT (1X,I2,2I4,' R(',I2,';',3(I2,A2,','),I2,A2,')  ',I7)
 3110 FORMAT (1X,I2,2I4,' R(',I2,';',3(I2,A2,','),I2,A2,')  ',I7,'/',I7)
 3120 FORMAT (1X,I2,2I4,' R(',I2,';',3(I2,A2,','),I2,A2,')  ',I7,' ',7X,!
     +' * S (',I7,' ',7X,')')
 3130 FORMAT (1X,I2,2I4,' R(',I2,';',3(I2,A2,','),I2,A2,')  ',I7,'/',I7,!
     +' * S (',I7,'/',I7,')')
 3140 FORMAT (1X,I2,2I4,' R(',I2,';',3(I2,A2,','),I2,A2,')  ',I7,'/',I7,!
     +' * S (',I7,' ',7X,')')
 3150 FORMAT (1X,I2,2I4,' R(',I2,';',3(I2,A2,','),I2,A2,')  ',I7,' ',7X,!
     +' * S (',I7,'/',I7,')')
 3160 FORMAT (1X,I2,2I4,' R(',I2,';',3(I2,A2,','),I2,A2,')  ',7X,' ',7X,!
     +'   S (',I7,' ',7X,')')
 3170 FORMAT (1X,I2,2I4,' R(',I2,';',3(I2,A2,','),I2,A2,')  ',7X,' ',7X,!
     +'   S (',I7,'/',I7,')')
 3180 FORMAT (1X,I2,2I4,' G(',I2,';',I2,A2,',',I2,A2,')',10X,'  ',I7)
 3190 FORMAT (1X,I2,2I4,' G(',I2,';',I2,A2,',',I2,A2,')',10X,'  ',I7,'/'!
     +,I7)
 3200 FORMAT (1X,I2,2I4,' G(',I2,';',I2,A2,',',I2,A2,')',10X,'  ',I7,' '!
     +,7X,' * S (',I7,' ',7X,')')
 3210 FORMAT (1X,I2,2I4,' G(',I2,';',I2,A2,',',I2,A2,')',10X,'  ',I7,'/'!
     +,I7,' * S (',I7,'/',I7,')')
 3220 FORMAT (1X,I2,2I4,' G(',I2,';',I2,A2,',',I2,A2,')',10X,'  ',I7,'/'!
     +,I7,' * S (',I7,' ',7X,')')
 3230 FORMAT (1X,I2,2I4,' G(',I2,';',I2,A2,',',I2,A2,')',10X,'  ',I7,' '!
     +,7X,' * S (',I7,'/',I7,')')
 3240 FORMAT (1X,I2,2I4,' G(',I2,';',I2,A2,',',I2,A2,')',10X,'  ',7X,' '!
     +,7X,'   S (',I7,' ',7X,')')
 3250 FORMAT (1X,I2,2I4,' G(',I2,';',I2,A2,',',I2,A2,')',10X,'  ',7X,' '!
     +,7X,'   S (',I7,'/',I7,')')
 3260 FORMAT (1X,I2,2I4,' F(',I2,';',I2,A2,',',I2,A2,')',10X,'  ',I7)
 3270 FORMAT (1X,I2,2I4,' F(',I2,';',I2,A2,',',I2,A2,')',10X,'  ',I7,'/'!
     +,I7)
 3280 FORMAT (1X,I2,2I4,' F(',I2,';',I2,A2,',',I2,A2,')',10X,'  ',I7,' '!
     +,7X,' * S (',I7,' ',7X,')')
 3290 FORMAT (1X,I2,2I4,' F(',I2,';',I2,A2,',',I2,A2,')',10X,'  ',I7,'/'!
     +,I7,' * S (',I7,'/',I7,')')
 3300 FORMAT (1X,I2,2I4,' F(',I2,';',I2,A2,',',I2,A2,')',10X,'  ',I7,'/'!
     +,I7,' * S (',I7,' ',7X,')')
 3310 FORMAT (1X,I2,2I4,' F(',I2,';',I2,A2,',',I2,A2,')',10X,'  ',I7,' '!
     +,7X,' * S (',I7,'/',I7,')')
 3320 FORMAT (1X,I2,2I4,' F(',I2,';',I2,A2,',',I2,A2,')',10X,'  ',7X,' '!
     +,7X,'   S (',I7,' ',7X,')')
 3330 FORMAT (1X,I2,2I4,' F(',I2,';',I2,A2,',',I2,A2,')',10X,'  ',7X,' '!
     +,7X,'   S (',I7,'/',I7,')')
 3340 FORMAT (1X,I2,2I4,' I(  ;',I2,A2,',',I2,A2,')',10X,'  ',I7)
 3350 FORMAT (1X,I2,2I4,' I(  ;',I2,A2,',',I2,A2,')',10X,'  ',I7,'/',I7)
 3360 FORMAT (1X,I2,2I4,' I(  ;',I2,A2,',',I2,A2,')',10X,'  ',I7,' ',7X,!
     +' * S (',I7,' ',7X,')')
 3370 FORMAT (1X,I2,2I4,' I(  ;',I2,A2,',',I2,A2,')',10X,'  ',I7,'/',I7,!
     +' * S (',I7,'/',I7,')')
 3380 FORMAT (1X,I2,2I4,' I(  ;',I2,A2,',',I2,A2,')',10X,'  ',I7,'/',I7,!
     +' * S (',I7,' ',7X,')')
 3390 FORMAT (1X,I2,2I4,' I(  ;',I2,A2,',',I2,A2,')',10X,'  ',I7,' ',7X,!
     +' * S (',I7,'/',I7,')')
 3400 FORMAT (1X,I2,2I4,' I(  ;',I2,A2,',',I2,A2,')',10X,'  ',7X,' ',7X,!
     +'   S (',I7,' ',7X,')')
 3410 FORMAT (1X,I2,2I4,' I(  ;',I2,A2,',',I2,A2,')',10X,'  ',7X,' ',7X,!
     +'   S (',I7,'/',I7,')')
      END
C
C                             *******************
C
      SUBROUTINE SPME(I,J,HCOUL,HBAB,HMAG,IMOD)
C
C-----------------------------------------------------------------------
C
C  This routine calculates the reduced matrix elements for pair I,J in
C  either Coulomb/Babuskin gauge or for magnetic case.
C
C  These are defined in the Brink and Satchler sense - i.e. compatible
C  with Nick Pyper et al's MCT paper but not with Ian Grant's radiative
C  transitions paper.
C
C  Subroutines called: CLRX,QUAD
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  External functions
C
      EXTERNAL CLRX
      DOUBLE PRECISION CLRX
C
C  Parameter variables
C
      DOUBLE PRECISION EPS10
      PARAMETER (EPS10=1.D-10)
      INTEGER N11
      PARAMETER (N11=MXNP+10)
C
C  Argument variables
C
      DOUBLE PRECISION HBAB,HCOUL,HMAG
      INTEGER I,IMOD,J
C
C  Local variables
C
      DOUBLE PRECISION CIMLM,CIMLP,CIP,CIPLM
      DOUBLE PRECISION CIPLP,CJL,CLM,CLP
      DOUBLE PRECISION DFKI,DFKJ,FL,FLP
      DOUBLE PRECISION FORM,HGAUGE,TJJ,VALUE
      INTEGER I1,II,IPJ,J1
      INTEGER NAKI,NAKJ,NGRID
C
C  Common variables
C
      DOUBLE PRECISION BJ(6,MXNP),DUM(2),TC(MXNP)
      DOUBLE PRECISION TD(MXNP)
      COMMON / BESS1  / DUM,BJ,TC,TD
C
C  Common variables
C
      DOUBLE PRECISION HALF,ONE,TEN,TENTH
      DOUBLE PRECISION THREE,TWO,ZERO
      COMMON / CONS   / ZERO,HALF,TENTH,ONE,TWO,THREE,TEN
C
C  Common variables
C
      DOUBLE PRECISION RGRID(MXNP)
      COMMON / GRID   / RGRID
C
C  Common variables
C
      INTEGER IPUNCH,IREAD,IWRITE
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
C
C  Common variables
C
      DOUBLE PRECISION ENLEV(MXNC),GAUGE1,GAUGE2
      COMMON / LEVM   / ENLEV,GAUGE1,GAUGE2
C
C  Common variables
C
      INTEGER LTC(20)
      COMMON / OPT04  / LTC
C
C  Common variables
C
      CHARACTER*2 NH(MXNW)
      COMMON / ORB00  / NH
C
C  Common variables
C
      INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF
      INTEGER NP(MXNW),NW
      COMMON / ORB04  / NW,NCF,NP,NAK,IQ
C
C  Common variables
C
      INTEGER NKJ(MXNW),NKL(MXNW)
      COMMON / ORB05  / NKL,NKJ
C
C  Common variables
C
      INTEGER KK,LK
      COMMON / OSC2   / LK,KK
C
C  Common variables
C
      INTEGER MPOIN(MXNW),MPOS(MXNW)
      COMMON / PATY   / MPOIN,MPOS
C
C  Common variables
C
      DOUBLE PRECISION TA(N11),TB(N11)
      COMMON / TATB   / TA,TB
C
C  Common variables
C
      DOUBLE PRECISION PF(MXNG),QF(MXNG)
      COMMON / WAVE   / PF,QF
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
C
C  evaluate outside factor
C
      TJJ = NKJ(J)
      NAKI = NAK(I)
      NAKJ = NAK(J)
      FORM = SQRT(TJJ+ONE)*CLRX(NAKI,LK,NAKJ)
      IPJ = (NKJ(I)-1)/2
      IF (MOD(IPJ,2).NE.0) FORM = -FORM
C
      NGRID = MIN(MPOIN(I),MPOIN(J))
C
      FL = LK
      FLP = FL+ONE
      DFKI = NAK(I)
      DFKJ = NAK(J)
C
      IF (KK.EQ.0) THEN
C
C  electric case
C  -------------
C
        HGAUGE = ZERO
        HBAB = ZERO
C
C  tabulate arrays
C
C    TB = PI*QJ+QI*PJ
C    TC = PI*QJ-QI*PJ
C    TD = PI*PJ+QI*QJ
C
        IF (ABS(FORM).GT.EPS10) THEN
          I1 = MPOS(I)
          J1 = MPOS(J)
          DO II = 1,NGRID
            TB(II) = PF(I1)*QF(J1)+QF(I1)*PF(J1)
            TC(II) = PF(I1)*QF(J1)-QF(I1)*PF(J1)
            TD(II) = PF(I1)*PF(J1)+QF(I1)*QF(J1)
            I1 = I1+1
            J1 = J1+1
          ENDDO
C
C  skip Coulomb part in certain circumstances
C
          IF (IMOD.EQ.1) GOTO 10
C
C  calculate Coulomb coefficients
C  -----------------
C
          CLP = SQRT(FL/FLP)
          CLM = -SQRT(FLP/FL)
          CIPLP = CLP*(DFKI-DFKJ)
          CIMLP = CLP*FLP
          CIPLM = CLM*(DFKI-DFKJ)
          CIMLM = -CLM*FL
C
C  tabulate Coulomb integrand
C
          DO II = 1,NGRID
            TA(II) = RGRID(II)*(BJ(3,II)*(CIPLP*TB(II)+CIMLP*TC(II))+BJ(!
     +1,II)*(CIPLM*TB(II)+CIMLM*TC(II)))
          ENDDO
          CALL QUAD(NGRID,VALUE)
          HCOUL = FORM*VALUE
C
   10     CONTINUE
C
C  calculate gauge dependent coefficients
C  ---------------
C
          CJL = -(FL+FLP)
          CIP = DFKI-DFKJ
C
C  tabulate gauge dependent integrand
C
          DO II = 1,NGRID
            TA(II) = RGRID(II)*(BJ(2,II)*CJL*TD(II)+BJ(3,II)*(CIP*TB(II)!
     ++FLP*TC(II))+BJ(1,II)*(CIP*TB(II)-FL*TC(II)))
          ENDDO
C
C  print gauge dependent integrand if requested
C  option 13 set
C
          IF (LTC(13).EQ.1) WRITE (IWRITE,3000) NP(I),NH(I),NP(J),NH(J),!
     +(TA(II),II=1,NGRID)
          CALL QUAD(NGRID,VALUE)
          HGAUGE = FORM*VALUE
C
          IF (LTC(19).EQ.1) THEN
            HBAB = HCOUL+GAUGE1*HGAUGE
            HCOUL = HCOUL+GAUGE2*HGAUGE
          ELSE
            HBAB = HCOUL+SQRT(FLP/FL)*HGAUGE
          ENDIF
C
        ENDIF
C
C  print Coulomb and gauge dependent integrals if requested
C
        IF (LTC(7).EQ.1) WRITE (IWRITE,3010) NP(I),NH(I),NP(J),NH(J),HCO!
     +UL,HGAUGE,HBAB
C
      ELSE
C
C   magnetic case
C   -------------
C
        HMAG = ZERO
        IF (ABS(FORM).GT.EPS10) THEN
          I1 = MPOS(I)
          J1 = MPOS(J)
          DO II = 1,NGRID
            TA(II) = (PF(I1)*QF(J1)+QF(I1)*PF(J1))*BJ(2,II)*RGRID(II)
            I1 = I1+1
            J1 = J1+1
          ENDDO
          CALL QUAD(NGRID,VALUE)
          HMAG = -VALUE*(FL+FLP)*(DFKI+DFKJ)*FORM/SQRT(FL*FLP)
        ENDIF
C
        IF (LTC(7).EQ.1) WRITE (IWRITE,3020) NP(I),NH(I),NP(J),NH(J),HMA!
     +G
C
      ENDIF
C
 3000 FORMAT (/' SPME : local form of gauge dependent integral (',I2,A2,!
     +',',I2,A2,')'//(1X,1P,7E11.3))
 3010 FORMAT (' SPME : Coulomb, gauge, Babushkin matrix elements (',I2,A!
     +2,',',I2,A2,')'/1X,1P,3E13.5)
 3020 FORMAT (' SPME : magnetic matrix element (',I2,A2,',',I2,A2,')'/1X!
     +,1P,E12.5)
      END
C
C                             *******************
C
      SUBROUTINE SSTC(IOPEN,ICFN,ICFR,NJ,COEFF)
C
C-----------------------------------------------------------------------
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      LOGICAL FREE
C
      PARAMETER (MANGM = 60)
      PARAMETER (MTRIAD=20)
      PARAMETER (M3MNGM = 3*MANGM)
      PARAMETER (M6J = 20)
      COMMON / NJS00  / J6C,J7C,J8C,JWC
      COMMON / NJS01  / J6(M3MNGM),J7(M3MNGM),J8(M3MNGM),
     +JW(6,M6J)
      COMMON / NJS02  / ICOUNT,J2TEST(MTRIAD),J3TEST(MTRIAD)
C
      INCLUDE 'grasp0.inc'
C
      COMMON / ANG00  / MMOM,NMOM,J1(MANGM),J2(MTRIAD,3),J3(MTRIAD,3),  !
     +                  FREE(MANGM)
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
      COMMON / NRD01  / MLX(4),MQX(4),JPOS(4),NOPEN
      COMMON / NRD06  / LSV(5,4,MXNC)
      COMMON / ORB04  / NW,NCF,NP(MXNW),NAK(MXNW),IQ(MXNW,MXNC)
      COMMON / ORB06  / JQS(3,MXNW,MXNC),JCUP(10,MXNC),ICHOP(MXNW,MXNC),!
     +                  IEXC
      COMMON / TCD    / ICD2(3,3,3),NCD2(3),ICD3(5,5,6),NCD3(6),        !
     +                  ICD4(8,8,7),NCD4(7),ICD5(10,10,7),NCD5(7),      !
     +                  NDN(7,3),JJDN(10,7,3),LSDN(10,7,3)
      COMMON / TCP    / ICP2(2,2),ICP3(3,3)
C
      PARAMETER (EPS8=1.D-8)
      PARAMETER (ZERO=0.D0)
      PARAMETER (ONE=1.D0)
      PARAMETER (TWO=2.D0)
C
      DIMENSION K1(40)
C-----------------------------------------------------------------------
C
C  Set up values
C
      LL = MLX(IOPEN)*2+1
      NQ = MQX(IOPEN)
      IF (LL.EQ.1) GOTO 30
      NL = LSV(3,IOPEN,ICFN)
      NS = LSV(2,IOPEN,ICFN)
      NV = LSV(1,IOPEN,ICFN)
      JP = JPOS(IOPEN)
      NQR1 = IQ(JP-1,ICFR)
      NJ1 = JQS(3,JP-1,ICFR)
      NV1 = JQS(1,JP-1,ICFR)
      NJ2 = JQS(3,JP,ICFR)
      NV2 = JQS(1,JP,ICFR)
C
      IF (NQ.GT.LL) GOTO 10
      MQ = NQ
      MQ1 = NQR1
      GOTO 20
C
   10 CONTINUE
      MQ = LL+LL-NQ
      MQ1 = LL-NQR1-1
   20 CONTINUE
      MQ2 = MQ-MQ1
      IF (MQ.GT.1) GOTO 40
   30 CONTINUE
      COEFF = ONE
      GOTO 230
C
C  P shell
C
   40 CONTINUE
      IF (LL.NE.3) GOTO 90
      IF (MQ.EQ.3) GOTO 80
      IF (NJ-3) 50,30,70
   50 CONTINUE
      J = MQ1/2+1
      K = (NL+1)/2
   60 CONTINUE
      IN = ICP2(J,K)
      IF (NL.EQ.5) IN = -IN
      ID = 3
      GOTO 180
C
   70 CONTINUE
      J = MQ1+1
      K = (NL-1)/2
      GOTO 60
C
   80 CONTINUE
      IF (NJ.NE.4) GOTO 30
      K = (NL+1)/2
      J = MQ1+1
      IN = ICP3(J,K)
      ID = 18
      GOTO 180
C
   90 CONTINUE
      IF (LL.NE.5) GOTO 190
C
C  D shell
C
      IF (MQ.GT.2) GOTO 100
      IF (NJ.EQ.3 .OR. NJ.EQ.7) GOTO 30
      K = (13-NJ)/4
      J = (5-NS)/2
      I = MQ1+1
      IF (NL.LT.7 .AND. K.EQ.2) J = J + 1
      IN = ICD2(I,J,K)
      ID = NCD2(K)
      GOTO 180
C
  100 CONTINUE
      ICHKJJ = NJ2+10*(MQ2+10*(NJ1+10*MQ1))
      ICHKLS = NL+10*(NS+10*NV)
      K = (NJ+1)/2
      JQ = MQ-2
      NC = NDN(K,JQ)
      DO IC = 1,NC
        IF (ICHKJJ.NE.JJDN(IC,K,JQ)) GOTO 110
        I = IC
        GOTO 120
C
  110   CONTINUE
      ENDDO
      GOTO 250
C
  120 CONTINUE
      DO IC = 1,NC
        IF (ICHKLS.NE.LSDN(IC,K,JQ)) GOTO 130
        J = IC
        GOTO 140
C
  130   CONTINUE
      ENDDO
      GOTO 250
C
  140 CONTINUE
      IF (MQ-4) 150,160,170
  150 CONTINUE
      IN = ICD3(I,J,K)
      ID = NCD3(K)
      GOTO 180
C
  160 CONTINUE
      IN = ICD4(I,J,K)
      ID = NCD4(K)
      GOTO 180
C
  170 CONTINUE
      IN = ICD5(I,J,K)
      ID = NCD5(K)
  180 CONTINUE
      IF (IN.EQ.0) GOTO 240
      COEFF = SQRT(DBLE(ABS(IN))/DBLE(ID))
      IF (IN.LT.0) COEFF = -COEFF
      GOTO 230
C
  190 CONTINUE
      IF (MQ.GT.2) GOTO 260
C
C  Higher shells with no more than 2 electrons
C
      IF (MOD(NJ+1,4).EQ.0) GOTO 30
      DO K = 1,21
        K1(K) = J1(K)
      ENDDO
      J1(1) = LL
      J1(2) = 2
      J1(4) = LL
      J1(5) = 2
      IF (NQR1.EQ.0) GOTO 200
      J1(3) = LL-1
      IF (NQR1.EQ.1) GOTO 210
      J1(6) = LL-1
      GOTO 220
C
  200 CONTINUE
      J1(3) = LL+1
  210 CONTINUE
      J1(6) = LL+1
  220 CONTINUE
      DO K = 9,21,6
        J1(K-2) = NL
        J1(K-1) = NS
        J1(K) = NJ
        DO J = 1,3
          J1(J+K) = 1
        ENDDO
      ENDDO
      CALL GENSUM (J6C,J7C,J8C,JWC,J6,J7,J8,JW,ICOUNT,J2TEST,
     +             J3TEST,COEFF)
      IF (NQR1.EQ.1) COEFF = COEFF*SQRT(TWO)
      DO K = 1,21
        J1(K) = K1(K)
      ENDDO
      IF (ABS(COEFF).LT.EPS8) GOTO 240
C
  230 CONTINUE
      IF (NQ.GT.LL) THEN
        IF (MOD(ABS(NV-NV1-NV2),4).EQ.2) COEFF = -COEFF
      ENDIF
C
      RETURN
C
  240 CONTINUE
      COEFF = ZERO
      RETURN
C
C  Error section
C
  250 CONTINUE
      WRITE (IWRITE,3000)
      WRITE (IPUNCH,3000)
      STOP
C
  260 CONTINUE
      WRITE (IWRITE,3010)
      WRITE (IPUNCH,3010)
      STOP
C
 3000 FORMAT (/' ERROR in SSTC : Configurations not found ... STOPPING')
 3010 FORMAT (/                                                         !
     +' ERROR in SSTC : No more than 2 electrons allowed in shells wit',!
     +'h L > 2 ... STOPPING')
      END
C
C                             *******************
C
      SUBROUTINE STWAVE(NLAST,J,ICLEM)
C
C-----------------------------------------------------------------------
C
C   This subroutine is used to produce estimates of the
C   wavefunctions by use of Slater-type orbitals.
C   Coefficients are read from input file in CIV3 format.
C
C      DATA
C
C         J           Serial number of function required
C         ICLEM = 0   Slater-type coefficients
C               = 1   Clementi-type coefficients
C
C      RESULT
C
C         The wavefunctions are tabulated in arrays PF and
C         QF, with the series expansion coefficients in
C         arrays PZ, QZ.
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  Parameter variables
C
      INTEGER N11
      PARAMETER (N11=MXNP+10)
      INTEGER NSTO
      PARAMETER (NSTO=30)
      INTEGER NIRAD
      PARAMETER (NIRAD=20)
C
C  Argument variables
C
      INTEGER ICLEM,J,NLAST
C
C  Local variables
C
      DOUBLE PRECISION DP,PQNORM,R(0:NIRAD),S(NSTO)
      DOUBLE PRECISION TWOCE,ZE(NSTO)
      INTEGER I,IRAD(NSTO),K,KAPPA
      INTEGER LFACTR,M,MXIRAD,NADD
      INTEGER NGRID,NPOINT,nx
C
C  Common variables
C
      DOUBLE PRECISION HALF,ONE,TEN,TENTH
      DOUBLE PRECISION THREE,TWO,ZERO
      COMMON / CONS   / ZERO,HALF,TENTH,ONE,TWO,THREE,TEN
C
C  Common variables
C
      DOUBLE PRECISION ACCY,C,EPH,H
      DOUBLE PRECISION RNT,Z
      INTEGER N,NCPRIN,NW1
      COMMON / DEF01  / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN
C
C  Common variables
C
      DOUBLE PRECISION PZ(MXNW),QZ(MXNW)
      COMMON / EXCO   / PZ,QZ
C
C  Common variables
C
      DOUBLE PRECISION RGRID(MXNP)
      COMMON / GRID   / RGRID
C
C  Common variables
C
      INTEGER IPUNCH,IREAD,IWRITE
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
C
C  Common variables
C
      DOUBLE PRECISION P(MXNP),PC(MXNP),Q(MXNP)
      DOUBLE PRECISION QC(MXNP)
      COMMON / INT2   / P,Q,PC,QC
C
C  Common variables
C
      integer icut(mxnw)
      common /nrbcut/icut
C
C  Common variables
C
      double precision fx
      integer istatx,npmin0
      common /nrbinf/fx,istatx,npmin0
C
C  Common variables
C
      INTEGER ITC(50)
      COMMON / OPT01  / ITC
C
C  Common variables
C
      DOUBLE PRECISION E(MXNW)
      COMMON / ORB01  / E
C
C  Common variables
C
      DOUBLE PRECISION GAMA(MXNW),XAM(MXNW)
      COMMON / ORB02  / GAMA,XAM
C
C  Common variables
C
      INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF
      INTEGER NP(MXNW),NW
      COMMON / ORB04  / NW,NCF,NP,NAK,IQ
C
C  Common variables
C
      INTEGER MPOIN(MXNW),MPOS(MXNW)
      COMMON / PATY   / MPOIN,MPOS
C
C  Common variables
C
      DOUBLE PRECISION CUTOFF
      COMMON / PATZ   / CUTOFF
C
C  Common variables
C
      DOUBLE PRECISION XTP(MXNP),XTQ(MXNP),YP(MXNP)
      DOUBLE PRECISION YQ(MXNP)
      COMMON / POTE   / YP,YQ,XTP,XTQ
C
C  Common variables
C
      DOUBLE PRECISION TA(N11),TB(N11)
      COMMON / TATB   / TA,TB
C
C  Common variables
C
      DOUBLE PRECISION PF(MXNG),QF(MXNG)
      COMMON / WAVE   / PF,QF
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
C
C   read eigenvalue and Slater-type function coefficients
C   similar to CIV3 (ISTAND.EQ.1) format
C
      READ (IREAD,*) E(J)
      READ (IREAD,*) M
      IF (M.GT.NSTO) THEN
        WRITE (IWRITE,3030) M,NSTO
        WRITE (IPUNCH,3030) M,NSTO
        STOP
      ENDIF
      READ (IREAD,*) (IRAD(K),K=1,M)
      READ (IREAD,*) (ZE(K),K=1,M)
      READ (IREAD,*) (S(K),K=1,M)
C
C   convert to Slater-type coefficients if necessary
C
      IF (ICLEM.EQ.1) THEN
        DO K = 1,M
          LFACTR = 1
          DO I = 1,2*IRAD(K)
            LFACTR = LFACTR*I
          ENDDO
          S(K) = S(K)*(TWO*ZE(K))**(IRAD(K)+HALF)/SQRT(DBLE(LFACTR))
        ENDDO
      ENDIF
C
C   evaluate large component P of orbital over grid and find first
C   approximation to small component Q using Thomas-Fermi potential
C
      KAPPA = NAK(J)
      TWOCE = TWO*C-E(J)/C
      R(0) = ONE
C
      MXIRAD = 0
      DO K = 1,M
        IF (IRAD(K).GT.MXIRAD) MXIRAD = IRAD(K)
      ENDDO
      IF (MXIRAD.GT.NIRAD) THEN
        WRITE (IWRITE,3040) MXIRAD,NIRAD
        WRITE (IPUNCH,3040) MXIRAD,NIRAD
        STOP
      ENDIF
C
      DO I = 1,N
        P(I) = ZERO
        Q(I) = ZERO
        DO K = 1,MXIRAD
          R(K) = R(K-1)*RGRID(I)
        ENDDO
        DO K = 1,M
          DP = S(K)*R(IRAD(K)-1)*EXP(-ZE(K)*R(1))
          P(I) = P(I)+DP*R(1)
          Q(I) = Q(I)+DP*(IRAD(K)-ZE(K)*R(1)+KAPPA)
        ENDDO
        Q(I) = Q(I)/(TWOCE+YP(I)/R(1)/C)
      ENDDO
C
C   find number of points required for orbital
C
      I = N
   10 CONTINUE
      IF (ABS(P(I)).LT.CUTOFF) THEN
        I = I-1
        IF (I.GT.0) GOTO 10
      ENDIF
C
      IF (I.EQ.0) THEN
        WRITE (IWRITE,3020)
        WRITE (IPUNCH,3020)
        STOP
      ELSEIF (I.EQ.N) THEN
        WRITE (IWRITE,3000) N
        WRITE (IPUNCH,3000) N
        STOP
      ENDIF
C
      NPOINT = I
c
c add buffer space for subsequent formation of new basis in rritz;
c extend it radially by a factor fx.
c
      if(np(j).ge.npmin0)then
        icut(j)=npoint                                 !store real end
        nx=log(fx)/h
        nx=nx+mod(nx,2)
      else
        nx=0
      endif
C
      IF (NPOINT.LT.N) THEN
        IF (MOD(NPOINT,2).EQ.1) THEN
          NADD = 8
        ELSE
          NADD = 7
        ENDIF
c
        nadd=nadd+nx
c
        IF (NPOINT+NADD.GT.N) NADD = N - NPOINT
        DO I = NPOINT+1,NPOINT+NADD
          P(I) = ZERO
          Q(I) = ZERO
        ENDDO
        NGRID = NPOINT+NADD
      ELSE
        NGRID = NPOINT
      ENDIF
C
C   normalize
C   check sign of P near the nucleus, it should be positive
C
      DO I = 1,NGRID
        TA(I) = (P(I)**2+Q(I)**2)*RGRID(I)
      ENDDO
      CALL QUAD(NGRID,PQNORM)
      PQNORM = 1/SQRT(PQNORM)
      IF (P(1).LT.ZERO) PQNORM = -PQNORM
      DO I = 1,NGRID
        P(I) = P(I)*PQNORM
        Q(I) = Q(I)*PQNORM
      ENDDO
C
C   expansion coefficients for P and Q near origin
C
      PZ(J) = P(1)/RGRID(1)**GAMA(J)
      IF (KAPPA.LT.0) THEN
        QZ(J) = PZ(J)*Z/(KAPPA-GAMA(J))/C
      ELSE
        QZ(J) = PZ(J)*C*(KAPPA+GAMA(J))/Z
      ENDIF
C
C   store wavefunctions in arrays PF and QF
C
      IF (NLAST+NGRID.GT.MXNG) THEN
        WRITE (IWRITE,3010) NLAST+NGRID,MXNG
        WRITE (IPUNCH,3010) NLAST+NGRID,MXNG
        STOP
      ENDIF
      K = NLAST+1
      DO I = 1,NGRID
        PF(K) = P(I)
        QF(K) = Q(I)
        K = K+1
      ENDDO
      MPOS(J) = NLAST+1
      MPOIN(J) = NGRID
      NLAST = NLAST+NGRID
C
C   write out wavefunction
C
      IF (ITC(16).EQ.1) CALL PRWF(J)
C
 3000 FORMAT (/' ERROR in STWAVE: dimension ... STOPPING'/              !
     +' Wavefunction is too large at end of radial mesh.'/              !
     +' You must increase MXNP from the present value ',I9)
 3010 FORMAT (/' ERROR in STWAVE: dimension ... STOPPING'/              !
     +' You must increase MXNG to at least ',I9,                        !
     +' from the present value of ',I9)
 3020 FORMAT (/' ERROR in STWAVE: ... STOPPING'/                        !
     +' Wavefunction cutoff not found.')
 3030 FORMAT (/' ERROR in STWAVE: dimension ... STOPPING'/              !
     +' You must increase NSTO to at least ',I9,                        !
     +' from the present value of ',I9)
 3040 FORMAT (/' ERROR in STWAVE: dimension ... STOPPING'/              !
     +' You must increase NIRAD to at least ',I9,                       !
     +' from the present value of ',I9)
      END
C
C                             *******************
C
      SUBROUTINE STWOPT
C
C-----------------------------------------------------------------------
C
C   This subroutine is used to improve estimates of the
C   wavefunctions which Slater-type orbitals input.
C
C      RESULT
C
C         The wavefunctions are tabulated in arrays PF and
C         QF, with the series expansion coefficients in
C         arrays PZ, QZ.
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  External functions
C
      EXTERNAL EIGENV
      DOUBLE PRECISION EIGENV
C
C  Parameter variables
C
      INTEGER N11
      PARAMETER (N11=MXNP+10)
      INTEGER MXITER
      PARAMETER (MXITER=10)
C
C  Local variables
C
      DOUBLE PRECISION DIFF,DIFFQ,DP(MXNP)
      DOUBLE PRECISION DPF(MXNG),PQNORM,QOLD,TWOCE
      DOUBLE PRECISION VN,XCA,XCP,XCQ
      DOUBLE PRECISION YPOLD(MXNP),ZFAC
      INTEGER I,ITER,J,K
      INTEGER NGRID
      LOGICAL LEIGEN(MXNW)
C
C  Common variables
C
      DOUBLE PRECISION HALF,ONE,TEN,TENTH
      DOUBLE PRECISION THREE,TWO,ZERO
      COMMON / CONS   / ZERO,HALF,TENTH,ONE,TWO,THREE,TEN
C
C  Common variables
C
      DOUBLE PRECISION XCAX
      COMMON / CONVG  / XCAX
C
C  Common variables
C
      DOUBLE PRECISION ACCY,C,EPH,H
      DOUBLE PRECISION RNT,Z
      INTEGER N,NCPRIN,NW1
      COMMON / DEF01  / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN
C
C  Common variables
C
      DOUBLE PRECISION PZ(MXNW),QZ(MXNW)
      COMMON / EXCO   / PZ,QZ
C
C  Common variables
C
      DOUBLE PRECISION RGRID(MXNP)
      COMMON / GRID   / RGRID
C
C  Common variables
C
      INTEGER IPUNCH,IREAD,IWRITE
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
C
C  Common variables
C
      DOUBLE PRECISION P(MXNP),PC(MXNP),Q(MXNP)
      DOUBLE PRECISION QC(MXNP)
      COMMON / INT2   / P,Q,PC,QC
C
C  Common variables
C
      INTEGER ITC(50)
      COMMON / OPT01  / ITC
C
C  Common variables
C
      CHARACTER*2 NH(MXNW)
      COMMON / ORB00  / NH
C
C  Common variables
C
      DOUBLE PRECISION E(MXNW)
      COMMON / ORB01  / E
C
C  Common variables
C
      DOUBLE PRECISION GAMA(MXNW),XAM(MXNW)
      COMMON / ORB02  / GAMA,XAM
C
C  Common variables
C
      INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF
      INTEGER NP(MXNW),NW
      COMMON / ORB04  / NW,NCF,NP,NAK,IQ
C
C  Common variables
C
      INTEGER MPOIN(MXNW),MPOS(MXNW)
      COMMON / PATY   / MPOIN,MPOS
C
C  Common variables
C
      DOUBLE PRECISION XTP(MXNP),XTQ(MXNP),YP(MXNP)
      DOUBLE PRECISION YQ(MXNP)
      COMMON / POTE   / YP,YQ,XTP,XTQ
C
C  Common variables
C
      DOUBLE PRECISION TA(N11),TB(N11)
      COMMON / TATB   / TA,TB
C
C  Common variables
C
      DOUBLE PRECISION PF(MXNG),QF(MXNG)
      COMMON / WAVE   / PF,QF
C
C  Common variables
C
      INTEGER ILO(MXNW),IWO(MXNW),NWO
      COMMON / WRO    / NWO,IWO,ILO
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
      WRITE (IWRITE,3000)
C
C   temporarily store static potential
C
      XCA = XCAX
      ZFAC = ONE
      DO I = 1,N
        YPOLD(I) = YP(I)
      ENDDO
C
C   iterations loop
C
      ITER = 0
   10 CONTINUE
      IF (ITER.LT.MXITER) THEN
        ITER = ITER+1
        DIFF = ZERO
C   diagonalize hamiltonian
        CALL MATRIX
C
C   loop over Slater-type orbitals
C
        DO J = 1,NW
          IF (ILO(J).EQ.4.OR.ILO(J).EQ.5) THEN
C
C   initialize arrays for this orbital including Lagrange multipliers
C   (note that LAGR uses array Q.)
C
            NGRID = MPOIN(J)
            TWOCE = TWO*C-E(J)/C
            CALL LAGR(J)
            K = MPOS(J)
            DO I = 1,NGRID
              P(I) = PF(K)
              Q(I) = QF(K)
              K = K+1
            ENDDO
            K = MPOS(J)
            IF (ITER.EQ.1) THEN
C   store DP/DR + KAPPA*P/R in arrays DP and DPF
              DO I = 1,NGRID
                DP(I) = Q(I)*(TWOCE+YPOLD(I)/RGRID(I)/C)
                DPF(K) = DP(I)
                K = K+1
              ENDDO
C   decide whether to estimate orbital eigenvalues
              IF (E(J).LE.ZERO) THEN
                LEIGEN(J) = .TRUE.
              ELSE
                LEIGEN(J) = .FALSE.
              ENDIF
            ELSE
              DO I = 1,NGRID
                DP(I) = DPF(K)
                K = K+1
              ENDDO
            ENDIF
C
C   revaluate small component Q of orbital with new static and
C   exchange potentials, using approximate eigenvalue if
C   necessary, and then normalize
C
            CALL YPOT(J,VN,ZFAC)
            CALL XPOT(J,XCA,XCP,XCQ)
            IF (LEIGEN(J)) E(J) = EIGENV(J)
            DIFFQ = ZERO
            DO I = 1,NGRID
              QOLD = Q(I)
              Q(I) = (DP(I)-XTP(I)/RGRID(I))/(TWOCE+YP(I)/RGRID(I)/C)
              DIFFQ = DIFFQ+ABS(QOLD-Q(I))
              TA(I) = (P(I)**2+Q(I)**2)*RGRID(I)
            ENDDO
            CALL QUAD(NGRID,PQNORM)
            DIFF = DIFF+DIFFQ*C/NGRID+ABS(PQNORM-ONE)
            PQNORM = 1/SQRT(PQNORM)
            DO I = 1,NGRID
              P(I) = P(I)*PQNORM
              Q(I) = Q(I)*PQNORM
              DP(I) = DP(I)*PQNORM
            ENDDO
C
C   expansion coefficients for P and Q near origin
C   and store wavefunctions in arrays PF and QF
C
            PZ(J) = P(1)/RGRID(1)**GAMA(J)
            IF (NAK(J).LT.0) THEN
              QZ(J) = PZ(J)*Z/(NAK(J)-GAMA(J))/C
            ELSE
              QZ(J) = PZ(J)*C*(NAK(J)+GAMA(J))/Z
            ENDIF
            K = MPOS(J)
            DO I = 1,NGRID
              PF(K) = P(I)
              QF(K) = Q(I)
              DPF(K) = DP(I)
              K = K+1
            ENDDO
C
C   write out wavefunction
C
            WRITE (IWRITE,3010) NP(J),NH(J),E(J),MPOIN(J)
            IF (ITC(16).EQ.1) CALL PRWF(J)
C
          ENDIF
        ENDDO
C
        IF (DIFF/NW.GE.ACCY) GOTO 10
      ELSE
        WRITE (IWRITE,3020) ITER
        WRITE (IPUNCH,3020) ITER
        STOP
      ENDIF
C
 3000 FORMAT (/' >>>> routine STWOPT - optimise Slater-type orbitals'/)
 3010 FORMAT (' ***  Slater-type orbitals *** ',I2,A2,' E = ',1P,E12.5,2!
     +X,I4,' points')
 3020 FORMAT (/' ERROR in routine STWOPT'/                              !
     +' orbitals not converged after ',I2,' iterations'/                !
     +' program is STOPPING'/)
      END
C
C                             *******************
C
      SUBROUTINE SUMMRY(IWRITE)
C
C-----------------------------------------------------------------------
C
C  This routine gives a final summary of the contributions to the
C  energy levels from zero-order, Breit, vacuum polarization and self
C  energy. these are given in a.u., cm-1, and eV.
C  The energy levels are written out in order of increasing energy.
C
C  No subroutine called.
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  Parameter variables
C
      DOUBLE PRECISION ONE
      PARAMETER (ONE=1.D0)
      DOUBLE PRECISION EPS10
      PARAMETER (EPS10=1.D-10)
C
C  Argument variables
C
      INTEGER IWRITE
C
C  Local variables
C
      DOUBLE PRECISION AM,CONST,ROW(7)
      INTEGER I,IJ,IP
      INTEGER J,KTC16,KTC17,KTC18
      INTEGER KTC19,L
C
C  Common variables
C
      DOUBLE PRECISION ATW,FACTAN,FACTCM,FACTEV
      DOUBLE PRECISION FACTRY
      COMMON / ATOM   / ATW,FACTRY,FACTCM,FACTEV,FACTAN
C
C  Common variables
C
      DOUBLE PRECISION COUVEC(MXNC,MXNC)
      COMMON / BRET1  / COUVEC
C
C  Common variables
C
      DOUBLE PRECISION ACCY,C,EPH,H
      DOUBLE PRECISION RNT,Z
      INTEGER N,NCPRIN,NW1
      COMMON / DEF01  / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN
C
C  Common variables
C
      DOUBLE PRECISION BREENG(MXNC),COUENG(MXNC)
      COMMON / ENRG1  / COUENG,BREENG
C
C  Common variables
C
      DOUBLE PRECISION SFENG(MXNC),VPENG(MXNC)
      COMMON / ENRG2  / VPENG,SFENG
C
C  Common variables
C
      INTEGER KTC(20)
      COMMON / OPT03  / KTC
C
C  Common variables
C
      INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF
      INTEGER NP(MXNW),NW
      COMMON / ORB04  / NW,NCF,NP,NAK,IQ
C
C  Common variables
C
      INTEGER ISPAR(MXNC),ITJPO(MXNC)
      COMMON / ORB07  / ITJPO,ISPAR
C
C  Common variables
C
      INTEGER LEV(MXNC)
      COMMON / PAT1   / LEV
C
C  Common variables
C
      INTEGER LORDER(MXNC)
      COMMON / PAT2   / LORDER
C
C  Common variables
C
      CHARACTER*80 IHED
      CHARACTER*20 RECORD
      COMMON / TITL   / IHED,RECORD
C
C  Common variables
C
      DOUBLE PRECISION WFACT
      COMMON / WFAC   / WFACT
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
      IF (ABS(ATW).LT.EPS10) THEN
        WRITE (IWRITE,3000) IHED(1:40),IHED(41:80),RECORD,WFACT
      ELSE
        WRITE (IWRITE,3010) IHED(1:40),IHED(41:80),RECORD,WFACT,ATW
      ENDIF
C
C  Ryd print     option 16 set
C  au print      option 17 set
C  cm-1 print    option 18 set
C  eV print      option 19 set
C
      KTC16 = KTC(16)
      KTC17 = KTC(17)
      KTC18 = KTC(18)
      KTC19 = KTC(19)
C-----------------------------------------------------------------------
   10 CONTINUE
C
      IF (KTC16.EQ.1) THEN
        KTC16 = 0
        CONST = FACTRY
        WRITE (IWRITE,3030)
        GOTO 20
      ENDIF
C
      IF (KTC17.EQ.1) THEN
        KTC17 = 0
        CONST = ONE
        WRITE (IWRITE,3020)
        GOTO 20
      ENDIF
C
      IF (KTC18.EQ.1) THEN
        KTC18 = 0
        CONST = FACTCM
        WRITE (IWRITE,3040) CONST
        GOTO 20
      ENDIF
C
      IF (KTC19.EQ.1) THEN
        KTC19 = 0
        CONST = FACTEV
        WRITE (IWRITE,3050) CONST
        GOTO 20
      ENDIF
C
      RETURN
C-----------------------------------------------------------------------
   20 CONTINUE
      WRITE (IWRITE,3060)
      DO J = 1,NCPRIN
C
        IF (J.EQ.1) THEN
          ROW(1) = COUENG(J)*CONST
          ROW(2) = BREENG(J)*CONST
          ROW(3) = ROW(1)+ROW(2)
          ROW(4) = VPENG(J)*CONST
          ROW(5) = SFENG(J)*CONST
          ROW(6) = ROW(4)+ROW(5)
          ROW(7) = ROW(3)+ROW(6)
        ELSE
          ROW(1) = (COUENG(J)-COUENG(1))*CONST
          ROW(2) = (BREENG(J)-BREENG(1))*CONST
          ROW(3) = ROW(1)+ROW(2)
          ROW(4) = (VPENG(J)-VPENG(1))*CONST
          ROW(5) = (SFENG(J)-SFENG(1))*CONST
          ROW(6) = ROW(4)+ROW(5)
          ROW(7) = ROW(3)+ROW(6)
        ENDIF
C
        I = LEV(J)
        IJ = ITJPO(I)-1
        IP = ISPAR(I)
        AM = COUVEC(I,J)
C
        IF (MOD(IJ,2).EQ.0) THEN
          IJ = IJ/2
          IF (IP.EQ.1) THEN
            IF (LORDER(J).EQ.0) THEN
              WRITE (IWRITE,3130) J,IJ,I,AM,ROW(1),ROW(2),ROW(6),ROW(7)
            ELSE
              WRITE (IWRITE,3140) J,IJ,I,AM,ROW(1),ROW(2),ROW(6),ROW(7)
            ENDIF
          ELSE
            IF (LORDER(J).EQ.0) THEN
              WRITE (IWRITE,3110) J,IJ,I,AM,ROW(1),ROW(2),ROW(6),ROW(7)
            ELSE
              WRITE (IWRITE,3120) J,IJ,I,AM,ROW(1),ROW(2),ROW(6),ROW(7)
            ENDIF
          ENDIF
        ELSE
          IF (IP.EQ.1) THEN
            IF (LORDER(J).EQ.0) THEN
              WRITE (IWRITE,3090) J,IJ,I,AM,ROW(1),ROW(2),ROW(6),ROW(7)
            ELSE
              WRITE (IWRITE,3100) J,IJ,I,AM,ROW(1),ROW(2),ROW(6),ROW(7)
            ENDIF
          ELSE
            IF (LORDER(J).EQ.0) THEN
              WRITE (IWRITE,3070) J,IJ,I,AM,ROW(1),ROW(2),ROW(6),ROW(7)
            ELSE
              WRITE (IWRITE,3080) J,IJ,I,AM,ROW(1),ROW(2),ROW(6),ROW(7)
            ENDIF
          ENDIF
        ENDIF
C
        DO L = 1,NCF
          IF (L.NE.I) THEN
            AM = COUVEC(L,J)
            IF (AM*AM .GT. .01D0) WRITE (IWRITE,3150) L,AM
          ENDIF
        ENDDO
C
      ENDDO
C
      GOTO 10
C-----------------------------------------------------------------------
 3000 FORMAT (/' >>>> routine SUMMRY called'//' Title  : ',A40/         !
     +'          ',A40/' Run at : ',A20//                               !
     +' WFACT (factor used to multiply frequency) = ',1P,E10.3/         !
     +' atomic weight has been set to infinity')
 3010 FORMAT (/' >>>> routine SUMMRY called'//' Title  : ',A40/         !
     +'          ',A40/' Run at : ',A20//                               !
     +' WFACT (factor used to multiply frequency) = ',1P,E10.3/         !
     +' ATW   (atomic weight)                     = ',0P,F10.4)
 3020 FORMAT (/' Summary of contributions to energy levels in a.u.')
 3030 FORMAT (/' Summary of contributions to energy levels in Ryd.')
 3040 FORMAT (/' Summary of contributions to energy levels in cm-1'/    !
     +' (1 a.u. =',1P,E17.10,' cm-1)')
 3050 FORMAT (/' Summary of contributions to energy levels in eV'/      !
     +' (1 a.u. =',1P,E17.10,' eV)')
 3060 FORMAT (/                                                         !
     +'   level          CSF      zero-order      Breit     QED       ',!
     +'total'/)
 3070 FORMAT ('   ',I4,1X,I4,'/2 o ',I4,F5.2,1P,E16.8,2E10.2,E16.8)
 3080 FORMAT (' * ',I4,1X,I4,'/2 o ',I4,F5.2,1P,E16.8,2E10.2,E16.8)
 3090 FORMAT ('   ',I4,1X,I4,'/2 e ',I4,F5.2,1P,E16.8,2E10.2,E16.8)
 3100 FORMAT (' * ',I4,1X,I4,'/2 e ',I4,F5.2,1P,E16.8,2E10.2,E16.8)
 3110 FORMAT ('   ',I4,1X,I4,'   o ',I4,F5.2,1P,E16.8,2E10.2,E16.8)
 3120 FORMAT (' * ',I4,1X,I4,'   o ',I4,F5.2,1P,E16.8,2E10.2,E16.8)
 3130 FORMAT ('   ',I4,1X,I4,'   e ',I4,F5.2,1P,E16.8,2E10.2,E16.8)
 3140 FORMAT (' * ',I4,1X,I4,'   e ',I4,F5.2,1P,E16.8,2E10.2,E16.8)
 3150 FORMAT (15X,I4,F5.2)
      END
C
C                             *******************
C
      SUBROUTINE TFPOT
C
C-----------------------------------------------------------------------
C
C  Calculation of the universal Thomas-Fermi potential.
C
C  No subroutines called.
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  Parameter variables
C
      DOUBLE PRECISION W1
      PARAMETER (W1=0.8853D0)
      DOUBLE PRECISION W2
      PARAMETER (W2=0.60112D0)
      DOUBLE PRECISION W3
      PARAMETER (W3=1.81061D0)
      DOUBLE PRECISION W4
      PARAMETER (W4=0.04793D0)
      DOUBLE PRECISION W5
      PARAMETER (W5=0.21465D0)
      DOUBLE PRECISION W6
      PARAMETER (W6=0.77112D0)
      DOUBLE PRECISION W7
      PARAMETER (W7=1.39515D0)
      DOUBLE PRECISION W8
      PARAMETER (W8=1.81061D0)
      DOUBLE PRECISION ONE
      PARAMETER (ONE=1.D0)
      DOUBLE PRECISION THREE
      PARAMETER (THREE=3.D0)
      DOUBLE PRECISION THIRD
      PARAMETER (THIRD=ONE/THREE)
C
C  Local variables
C
      DOUBLE PRECISION DGZ,WA,WB,WC
      DOUBLE PRECISION WD,WE,WF,WX
      INTEGER I,IDGZ
C
C  Common variables
C
      DOUBLE PRECISION ACCY,C,EPH,H
      DOUBLE PRECISION RNT,Z
      INTEGER N,NCPRIN,NW1
      COMMON / DEF01  / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN
C
C  Common variables
C
      INTEGER IPUNCH,IREAD,IWRITE
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
C
C  Common variables
C
      DOUBLE PRECISION ZZ(MXNP)
      COMMON / NPOT   / ZZ
C
C  Common variables
C
      INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF
      INTEGER NP(MXNW),NW
      COMMON / ORB04  / NW,NCF,NP,NAK,IQ
C
C  Common variables
C
      DOUBLE PRECISION XTP(MXNP),XTQ(MXNP),YP(MXNP)
      DOUBLE PRECISION YQ(MXNP)
      COMMON / POTE   / YP,YQ,XTP,XTQ
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
C
C  The Thomas-Fermi potential is stored in array YP
C
C-----------------------------------------------------------------------
      DGZ = Z
      DO I = 1,NW
        DGZ = DGZ-IQ(I,1)
      ENDDO
C
      IDGZ = NINT(DGZ)
      WRITE (IWRITE,3000) IDGZ
C
      WA = DGZ+ONE
      WB = Z-WA
      WC = RNT*WB**THIRD/W1
      WC = SQRT(WC)
      WX = SQRT(EPH)
C
      DO I = 1,N
C
C  Rational function approximation to the universal
C  Thomas-Fermi function
C
        WD = WC*(W2*WC+W3)+ONE
        WE = WC*(WC*(WC*(WC*(W4*WC+W5)+W6)+W7)+W8)+ONE
C
C  Potential function for atomic number Z, degree of
C  ionisation DGZ
C
        WF = WD/WE
        YP(I) = (ZZ(I)-WA)*WF*WF+WA
        WC = WC*WX
C
      ENDDO
C
 3000 FORMAT (/' >>>> routine TFPOT called to evaluate the Thomas-Fermi'!
     +/' >>>> potential for degree of ionization = ',I4/)
      END
C
C                             *******************
C
      SUBROUTINE TFWAVE(NLAST,J,MF)
C
C-----------------------------------------------------------------------
C
C   This subroutine is used to produce estimates of the wave functions
C   by use of the Thomas-Fermi approximation.
C
C   Subroutine SOLV0 is used to obtain the radial wave functions
C   corresponding to the potential Y(R) obtained in TFPOT.
C
C   DATA
C   ----
C   NLAST index of last element used in PF and QF
C   J     serial number of function required
C
C   RESULT
C   ------
C   The wave functions are tabulated in arrays PF and QF, with the
C   series expansion coefficients in arrays  PZ, QZ.
C   MF is non-zero if a failure occurs.
C
C   Subroutine called : SOLV0
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  Argument variables
C
      INTEGER J,MF,NLAST
C
C  Local variables
C
      DOUBLE PRECISION AST,GAMJ,ONEM,VN
      DOUBLE PRECISION WA
      INTEGER I,IJ,MX,NADD
      INTEGER NGRID,NPOINT,nx
      LOGICAL HIACC
C
C  Common variables
C
      DOUBLE PRECISION HALF,ONE,TEN,TENTH
      DOUBLE PRECISION THREE,TWO,ZERO
      COMMON / CONS   / ZERO,HALF,TENTH,ONE,TWO,THREE,TEN
C
C  Common variables
C
      DOUBLE PRECISION ACCY,C,EPH,H
      DOUBLE PRECISION RNT,Z
      INTEGER N,NCPRIN,NW1
      COMMON / DEF01  / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN
C
C  Common variables
C
      INTEGER IPUNCH,IREAD,IWRITE
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
C
C  Common variables
C
      DOUBLE PRECISION P(MXNP),PC(MXNP),Q(MXNP)
      DOUBLE PRECISION QC(MXNP)
      COMMON / INT2   / P,Q,PC,QC
C
C  Common variables
C
      DOUBLE PRECISION PARM(4),Z1
      INTEGER NPARM,NUCTYP
      COMMON / NPAR   / PARM,Z1,NUCTYP,NPARM
C
C  Common variables
C
      integer icut(mxnw)
      common /nrbcut/icut
C
C  Common variables
C
      double precision fx
      integer istatx,npmin0
      common /nrbinf/fx,istatx,npmin0
C
C  Common variables
C
      CHARACTER*2 NH(MXNW)
      COMMON / ORB00  / NH
C
C  Common variables
C
      DOUBLE PRECISION E(MXNW)
      COMMON / ORB01  / E
C
C  Common variables
C
      DOUBLE PRECISION GAMA(MXNW),XAM(MXNW)
      COMMON / ORB02  / GAMA,XAM
C
C  Common variables
C
      DOUBLE PRECISION CXP(MXNW)
      COMMON / ORB03  / CXP
C
C  Common variables
C
      INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF
      INTEGER NP(MXNW),NW
      COMMON / ORB04  / NW,NCF,NP,NAK,IQ
C
C  Common variables
C
      INTEGER MPOIN(MXNW),MPOS(MXNW)
      COMMON / PATY   / MPOIN,MPOS
C
C  Common variables
C
      DOUBLE PRECISION XTP(MXNP),XTQ(MXNP),YP(MXNP)
      DOUBLE PRECISION YQ(MXNP)
      COMMON / POTE   / YP,YQ,XTP,XTQ
C
C  Common variables
C
      DOUBLE PRECISION PF(MXNG),QF(MXNG)
      COMMON / WAVE   / PF,QF
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
      WA = CXP(J)
      WA = (Z-WA)/NP(J)
      WA = WA*WA*HALF
C
C  Replace very small estimates by a tenth
C
      IF (WA.LT.TENTH) WA = TENTH
C
C  Estimate of leading coefficient PZ
C
      GAMJ = GAMA(J)
      AST = Z**(GAMJ+HALF)
      IF (NAK(J).GT.0) AST = AST*Z/ (C*C)
      AST = AST*TENTH
C
C  Compute radial wave functions
C
      DO I = 1,N
        YQ(I) = YP(I)
        XTP(I) = ZERO
        XTQ(I) = ZERO
      ENDDO
C
      ONEM = -ONE
C
C  Estimate slope of potential
C
      VN = ZERO
      IF (NUCTYP.NE.0) VN = YP(1)/RNT
C
C  Solve the equations with no exchange
C
      HIACC = .FALSE.
      CALL SOLV0(J,VN,ONEM,ZERO,ZERO,AST,WA,MX,HIACC,NPOINT)
C
C  Failure :
C
      IF (MX.NE.0) THEN
        MF = 1
        WRITE (IWRITE,3000) NP(J),NH(J),E(J)
        RETURN
      ENDIF
C
C  Success :
C  Store wave functions in arrays PF and QF
C
c
c add buffer space for subsequent formation of new basis in rritz;
c extend it radially by a factor fx.
c
      if(np(j).ge.npmin0)then
        icut(j)=npoint                                 !store real end
        nx=log(fx)/h
        nx=nx+mod(nx,2)
      else
        nx=0
      endif
C
      IF (NPOINT.LT.N) THEN
        IF (MOD(NPOINT,2).EQ.1) THEN
          NADD = 8
        ELSE
          NADD = 7
        ENDIF
c
        nadd=nadd+nx
c
        IF (NPOINT+NADD.GT.N) NADD = N - NPOINT
        DO I = NPOINT+1,NPOINT+NADD
          P(I) = ZERO
          Q(I) = ZERO
        ENDDO
        NGRID = NPOINT+NADD
      ELSE
        NGRID = NPOINT
      ENDIF
C
      IF (NLAST+NGRID.GT.MXNG) THEN
        WRITE (IWRITE,3010) NLAST + NGRID,MXNG
        WRITE (IPUNCH,3010) NLAST + NGRID,MXNG
        STOP
      ENDIF
C
      IJ = NLAST+1
      DO I = 1,NGRID
        PF(IJ) = P(I)
        QF(IJ) = Q(I)
        IJ = IJ+1
      ENDDO
C
      MF = 0
      MPOS(J) = NLAST+1
      MPOIN(J) = NGRID
      NLAST = NLAST+NGRID
C
 3000 FORMAT (' FAILURE in TFWAVE for ',I2,A2,' eigenvalue = ',1P,E12.5)
 3010 FORMAT (/' ERROR in TFWAVE : dimension ... STOPPING'/             !
     +' You must increase MXNG to at least ',I9,                        !
     +' from the present value of ',I9/)
      END
C
C                             *******************
C
      SUBROUTINE TMSOUT
C
C-----------------------------------------------------------------------
C
C  Prints table of terms set by BLOCK DATA.
C
C  No subroutines called.
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
C
C  Local variables
C
      INTEGER I,II,JI,JJ
      INTEGER K,KK,KKK
C
C  Common variables
C
      INTEGER IPUNCH,IREAD,IWRITE
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
C
C  Common variables
C
      INTEGER ITAB(16),JTAB(16),NROWS
      INTEGER NTAB(255)
      COMMON / TERMS  / NROWS,ITAB,JTAB,NTAB
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
      WRITE (IWRITE,3000)
      WRITE (IWRITE,3010) NROWS, (ITAB(I),I=1,NROWS)
      WRITE (IWRITE,3020)
      DO I = 1,NROWS
        JI = JTAB(I)
        JJ = 3*ITAB(I)
        KK = JI+1
        KKK = JJ+JI
        II = I-1
        WRITE (IWRITE,3030) II, (NTAB(K),K=KK,KKK)
      ENDDO
C-----------------------------------------------------------------------
 3000 FORMAT (/40X,'Table of possible terms'//)
 3010 FORMAT (1X,I3,' rows of this table (NTAB) are defined.'/          !
     +' The lengths (ITAB) of the rows are, respectively,'/1X,16I5)
 3020 FORMAT (/' List of NTAB. '/                                       !
     +' Each triad of numbers corresponds to (V,W,2J+1),'/              !
     +' where V is seniority,'/                                         !
     +'   and W distinguishes states with the same values of V,J.'/)
 3030 FORMAT (' Row ',I2,' ,',8(I8,2I3)/(1X,I16,2I3,7(I8,2I3)))
      END
C
C                             *******************
C
      SUBROUTINE TNSRJJ(KA,IOPAR,JA,JB,IA1,IA2,VSHELL)
C
C-----------------------------------------------------------------------
C
C  The main program for evaluating the reduced matrix elements of one
C  particle operator for configurations in JJ-coupling.
C
C  Subroutines called: CFP,FIXJ,IROW1,ITRIG,NJSYM,GENSUM,
C                      SETUP,VIJOUT
C
C-----------------------------------------------------------------------
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      LOGICAL FREE
      LOGICAL FAIL
C
      PARAMETER (MANGM = 60)
      PARAMETER (MTRIAD=20)
      PARAMETER (M3MNGM = 3*MANGM)
      PARAMETER (M6J = 20)
      COMMON / NJS00  / J6C,J7C,J8C,JWC
      COMMON / NJS01  / J6(M3MNGM),J7(M3MNGM),J8(M3MNGM),
     +JW(6,M6J)
      COMMON / NJS02  / ICOUNT,J2TEST(MTRIAD),J3TEST(MTRIAD)
C
      INCLUDE 'grasp0.inc'
      PARAMETER (NPLX=14)
C
      COMMON / ANG00  / MMOM,NMOM,J1(MANGM),J2(MTRIAD,3),J3(MTRIAD,3),  !
     +                  FREE(MANGM)
      COMMON / ANG08  / JBQ1(3,MXNW),JBQ2(3,MXNW),JTQ1(3),JTQ2(3)
      COMMON / ANG10  / JJC1(NPLX),JJC2(NPLX)
      COMMON / ANG11  / NQ1(MXNW),NQ2(MXNW)
      COMMON / ANG12  / JJQ1(3,MXNW),JJQ2(3,MXNW)
      COMMON / ANG13  / JLIST(NPLX),KLIST(MXNW),NPEEL,NCORE
      COMMON / DEBUG  / IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
      COMMON / ORB04  / NW,NCF,NP(MXNW),NAK(MXNW),IQ(MXNW,MXNC)
      COMMON / ORB06  / JQS(3,MXNW,MXNC),JCUP(10,MXNC),ICHOP(MXNW,MXNC),!
     +                  IEXC
      COMMON / ORB07  / ITJPO(MXNC),ISPAR(MXNC)
      COMMON / TERMS  / NROWS,ITAB(16),JTAB(16),NTAB(255)
C
      DIMENSION VSHELL(MXNW)
      DIMENSION IS(2),KS(2)
      DIMENSION JLIS(NPLX),JC1S(NPLX),JC2S(NPLX)
C
      PARAMETER (EPS10=1.D-10)
      PARAMETER (ZERO=0.D0)
C-----------------------------------------------------------------------
      IA1 = 0
      KK = KA+KA+1
      IF (ITRIG(ITJPO(JA),ITJPO(JB),KK).EQ.0) RETURN
      IF (IOPAR.NE.0 .AND. ISPAR(JA)*ISPAR(JB)*IOPAR.NE.1) RETURN
C
      CALL SETUP(JA,JB,IWRITE,IBUG2)
      IF (IBUG4.EQ.1) CALL VIJOUT(JA,JB,IWRITE)
C
      DO IJ = 1,NW
        VSHELL(IJ) = ZERO
      ENDDO
C-----------------------------------------------------------------------
C
C  Analyse peel shell interactions
C
      IDQ = 0
      JA1 = 0
      JA2 = 0
C
      IF (NPEEL.EQ.0) GOTO 50
C
      DO JWW = 1,NPEEL
        IJ = JLIST(JWW)
        NDQ = NQ1(IJ)-NQ2(IJ)
        IF (ABS(NDQ).GT.1) GOTO 240
        IF (NDQ) 20,40,10
   10   CONTINUE
        JA1 = JWW
        GOTO 30
C
   20   CONTINUE
        JA2 = JWW
   30   CONTINUE
        IDQ = IDQ+1
   40   CONTINUE
      ENDDO
C
      IF (IDQ.GT.2) GOTO 240
C-----------------------------------------------------------------------
C
C  Evaluate the array VSHELL
C
C  There are two possibilities :
C
C  If IDQ=0, then loop over all shells by index ISH
C  If IDQ=2, then one orbital fixed on each side
C
C-----------------------------------------------------------------------
      NS = NPEEL
      IF (IDQ.EQ.2) GOTO 130
C-----------------------------------------------------------------------
C
C  loop over shells when IDQ=0
C
C-----------------------------------------------------------------------
   50 CONTINUE
      ISH = 0
      IF (NPEEL.EQ.0) GOTO 60
      DO I = 1,NPEEL
        JLIS(I) = JLIST(I)
      ENDDO
      IF (NPEEL.EQ.1) GOTO 60
      NPEELM = NPEEL-1
      DO I = 1,NPEELM
        JC1S(I) = JJC1(I)
        JC2S(I) = JJC2(I)
      ENDDO
C-----------------------------------------------------------------------
C
C  If ISH > NW, then loop is over and return
C
C-----------------------------------------------------------------------
   60 CONTINUE
      ISH = ISH+1
      IF (ISH.GT.NW) RETURN
      IF (ICHOP(ISH,JA).EQ.-1) GOTO 60
      IF (IBUG6.EQ.1) WRITE (IWRITE,3040) ISH
      IF (ICHOP(ISH,JA).EQ.0) GOTO 110
C-----------------------------------------------------------------------
C
C  Case one
C  The ISHth shell is in the core or in the peel and closed for both
C  sides
C
C-----------------------------------------------------------------------
      I = 1
      IF (NPEEL.EQ.0) GOTO 100
      DO I = 1,NPEEL
        IJ = JLIST(I)
        IF (ISH.LT.IJ) GOTO 70
      ENDDO
      I = NPEEL+1
      GOTO 80
C
   70 CONTINUE
      IM = NPEEL-I+1
      DO II = 1,IM
        JLIST(NPEEL+2-II) = JLIST(NPEEL+1-II)
        IF (NPEEL.EQ.II) GOTO 80
        JJC1(NPEEL+1-II) = JJC1(NPEEL-II)
        JJC2(NPEEL+1-II) = JJC2(NPEEL-II)
      ENDDO
   80 CONTINUE
      IF (I.LT.3) GOTO 90
      JJC1(I-1) = JJC1(I-2)
      JJC2(I-1) = JJC2(I-2)
      GOTO 100
C
   90 CONTINUE
      I1 = JLIST(1)
      JJC1(1) = JJQ1(3,I1)
      JJC2(1) = JJQ2(3,I1)
  100 CONTINUE
      JLIST(I) = ISH
      JA1 = I
      JA2 = I
      NS = NPEEL+1
      GOTO 130
C-----------------------------------------------------------------------
C
C  Case two
C  The ISHth shell is in the peel and open for either side
C
C-----------------------------------------------------------------------
  110 CONTINUE
      NS = NPEEL
      DO JWW = 1,NPEEL
        NX = ISH-JLIST(JWW)
        IF (NX.EQ.0) GOTO 120
      ENDDO
  120 CONTINUE
      JA1 = JWW
      JA2 = JWW
C-----------------------------------------------------------------------
C
C  ****** main computation ******
C
C  JA1 , JA2 are the indices of interacting shells in JLIST
C  IA1 , IA2 are the indices of interacting shells in NW
C
C-----------------------------------------------------------------------
  130 CONTINUE
      IA1 = JLIST(JA1)
      IA2 = JLIST(JA2)
      KS1 = 2*ABS(NAK(IA1))
      KS2 = 2*ABS(NAK(IA2))
C-----------------------------------------------------------------------
C
C  check triangular condition for the active shells
C
C-----------------------------------------------------------------------
      IF (ITRIG(KS1,KS2,KK).EQ.1) GOTO 140
      IF (IDQ.EQ.2) RETURN
      GOTO 220
C-----------------------------------------------------------------------
C
C  set tables of quantum numbers of non-interacting spectator shells
C
C-----------------------------------------------------------------------
  140 CONTINUE
      DO JWW = 1,NS
        IJ = JLIST(JWW)
        IF (IJ.EQ.IA1) GOTO 150
        DO K = 1,3
          JBQ1(K,IJ) = JJQ1(K,IJ)
        ENDDO
C
  150   CONTINUE
        IF (IJ.EQ.IA2) GOTO 160
        DO K = 1,3
          JBQ2(K,IJ) = JJQ2(K,IJ)
        ENDDO
        IF (IJ.EQ.IA1 .OR. IJ.EQ.IA2) GOTO 160
        DO K = 1,3
* correction due to Froese Fischer, Gaigalas and Ralchenko (2006)
* detected in GRASP92
*         IF (JBQ1(K,IJ).NE.JBQ2(K,IJ)) GOTO 250
           IF (JBQ1(K,IJ).NE.JBQ2(K,IJ)) GOTO 220
        ENDDO
  160   CONTINUE
      ENDDO
C-----------------------------------------------------------------------
C
C  ****** loop over parent states ******
C
C-----------------------------------------------------------------------
      IS(1) = IA1
      IS(2) = IA2
      KS(1) = KS1
      KS(2) = KS2
      VAL = ZERO
      KJ23 = 0
      IX = 0
      FAIL = .FALSE.
C**2
      NELCTS = NQ2(IA2)
      L2 = IROW1(NELCTS,KS2)
      LLS2 = ITAB(L2)
      LS2 = JTAB(L2)
C
      DO LB = 1,LLS2
        LS2 = LS2+3
        IT1 = NTAB(LS2)
        IT2 = KS2
        IT3 = JJQ2(3,IA2)
        IF (ITRIG(IT1,IT2,IT3).EQ.0) GOTO 200
        IF (ABS(NTAB(LS2-2)-JJQ2(1,IA2)).NE.1) GOTO 200
        DO K = 1,3
          JBQ2(K,IA2) = NTAB(LS2+K-3)
        ENDDO
C**1
        NELCTS = NQ1(IA1)
        L1 = IROW1(NELCTS,KS1)
        LLS1 = ITAB(L1)
        LS1 = JTAB(L1)
C
        DO LA = 1,LLS1
          LS1 = LS1+3
          IT1 = NTAB(LS1)
          IT2 = KS1
          IT3 = JJQ1(3,IA1)
          IF (ITRIG(IT1,IT2,IT3).EQ.0) GOTO 190
          IF (ABS(NTAB(LS1-2)-JJQ1(1,IA1)).NE.1) GOTO 190
          DO K = 1,3
            JBQ1(K,IA1) = NTAB(LS1+K-3)
          ENDDO
C
          DO K = 1,3
            IF (JBQ1(K,IA1).NE.JBQ2(K,IA1)) GOTO 190
            IF (JBQ1(K,IA2).NE.JBQ2(K,IA2)) GOTO 190
          ENDDO
C-----------------------------------------------------------------------
C
C  parent shells now defined
C
C-----------------------------------------------------------------------
          CALL FIXJ(JA1,JA2,KA,IS,KS,NS,KJ23)
          KJ23 = 1
C-----------------------------------------------------------------------
C
C  evaluate recoupling coefficient
C
C-----------------------------------------------------------------------
          IF (IX.EQ.0) THEN
            CALL NJSYM (RECUPS,-1,FAIL)
            IX = 1
          ENDIF
C
          IF (FAIL) GOTO 210
          CALL GENSUM (J6C,J7C,J8C,JWC,J6,J7,J8,JW,ICOUNT,J2TEST,
     +                 J3TEST,RECUPS)
          IF (IBUG6.EQ.1) WRITE (IWRITE,3030) RECUPS
          IF (ABS(RECUPS).LT.EPS10) GOTO 190
C-----------------------------------------------------------------------
C
C  evaluates 2 CFPs
C
C-----------------------------------------------------------------------
          IF (KS1.EQ.2) GOTO 170
          II = IA1
          NEL = NQ1(II)
          IVP = JBQ1(1,II)
          IWP = JBQ1(2,II)
          IJP = JBQ1(3,II)-1
          IVD = JJQ1(1,II)
          IWD = JJQ1(2,II)
          IJD = JJQ1(3,II)-1
          CALL CFP(KS1,NEL,IJD,IVD,IWD,IJP,IVP,IWP,C)
          IF (IBUG6.EQ.1) WRITE (IWRITE,3020) KS1,NEL,IJD,IVD,IWD,IJP,IV!
     +P,IWP,C
          IF (ABS(C).LT.EPS10) GOTO 190
          RECUPS = RECUPS*C
C
  170     CONTINUE
          IF (KS2.EQ.2) GOTO 180
          II = IA2
          NEL = NQ2(II)
          IVD = JJQ2(1,II)
          IWD = JJQ2(2,II)
          IJD = JJQ2(3,II)-1
          IVP = JBQ2(1,II)
          IWP = JBQ2(2,II)
          IJP = JBQ2(3,II)-1
          CALL CFP(KS2,NEL,IJD,IVD,IWD,IJP,IVP,IWP,C)
          IF (IBUG6.EQ.1) WRITE (IWRITE,3020) KS2,NEL,IJD,IVD,IWD,IJP,IV!
     +P,IWP,C
          IF (ABS(C).LT.EPS10) GOTO 190
          RECUPS = RECUPS*C
C
  180     CONTINUE
          VAL = VAL+RECUPS
  190     CONTINUE
        ENDDO
  200   CONTINUE
      ENDDO
C
C  *** end of loop over parent states ***
C
  210 CONTINUE
      IF (IDQ.EQ.2) GOTO 230
C-----------------------------------------------------------------------
C
C  ****** IDQ=0 case ******
C
C-----------------------------------------------------------------------
      VSHELL(ISH) = VAL*DBLE(NQ1(IA1))
C-----------------------------------------------------------------------
C
C  loop over all shells when IDQ=0
C
C-----------------------------------------------------------------------
  220 CONTINUE
      IF (NPEEL.EQ.0) GOTO 60
      DO I = 1,NPEEL
        JLIST(I) = JLIS(I)
      ENDDO
      IF (NPEEL.EQ.1) GOTO 60
      NPEELM = NPEEL-1
      DO I = 1,NPEELM
        JJC1(I) = JC1S(I)
        JJC2(I) = JC2S(I)
      ENDDO
      GOTO 60
C-----------------------------------------------------------------------
C
C  ****** IDQ=2 case ******
C
C  permutation factor for IDQ=2
C
C-----------------------------------------------------------------------
  230 CONTINUE
      VAL = VAL*SQRT(DBLE(NQ1(IA1)*NQ2(IA2)))
      LLD1 = MIN(IA1,IA2)+1
      LLD2 = MAX(IA1,IA2)
      IDL = 1
      IF (IA1.LT.IA2) IDL = 0
      DO K = LLD1,LLD2
        IDL = IDL+NQ1(K)
      ENDDO
      IF (MOD(IDL,2).NE.0) VAL = -VAL
      VSHELL(1) = VAL
      RETURN
C-----------------------------------------------------------------------
  240 CONTINUE
      IF (IBUG6.EQ.1) WRITE (IWRITE,3000)
      RETURN
C-----------------------------------------------------------------------
  250 CONTINUE
      IF (IBUG6.EQ.1) WRITE (IWRITE,3010)
C-----------------------------------------------------------------------
 3000 FORMAT (' one side has more than one interacting electron')
 3010 FORMAT (                                                          !
     +' spectator quantum numbers not diagonal for non-interacting she',!
     +'lls')
 3020 FORMAT (' CFP  ',I3,I4,I7,2I4,I7,2I4,1P,E20.9)
 3030 FORMAT (/' recoupling coeff=',1P,E20.9)
 3040 FORMAT (//' ISH=',I3)
      END
C
C                             *******************
C
      SUBROUTINE TRANS(NWM,NMAN)
C
C-----------------------------------------------------------------------
C
C  This subroutine calculates the JJ-LS transformation coeficients.
C
C  NWM   - number of NR orbitals
C  NMAN  - number of NR CSFs
C
C  Subroutines called : NRCSF
C
C-----------------------------------------------------------------------
C
C            TRANS
C              |
C            NRCSF
C              |
C       -------------------------------
C       |         |          |        |
C    LSTERM   JCLIST      NJSYM     JJLS
C                                     |
C                           ----------------------
C                           |         |          |
C                         SSTC     DRACAH     GENSUM
C                           |
C                         GENSUM
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  Parameter variables
C
      DOUBLE PRECISION ZERO
      PARAMETER (ZERO=0.D0)
      DOUBLE PRECISION ONE
      PARAMETER (ONE=1.D0)
      INTEGER NOPENX
      PARAMETER (NOPENX=4)
C
C  Argument variables
C
      INTEGER NMAN,NWM
C
C  Local variables
C
      INTEGER I,II,J,JF
      INTEGER JMAN,L,NFULL,NL
      INTEGER NOP,NOP1,NQ,NST
C
C  Common variables
C
      DOUBLE PRECISION TC(MXNC,MXNC)
      COMMON / NRD00  / TC
C
C  Common variables
C
      INTEGER JPOS(4),MLX(4),MQX(4),NOPEN
      COMMON / NRD01  / MLX,MQX,JPOS,NOPEN
C
C  Common variables
C
      INTEGER NLX(MXNW),NPX(MXNW),NQX(MXNW,MXNC)
      COMMON / NRD03  / NPX,NLX,NQX
C
C  Common variables
C
      INTEGER IPOS(MXNW),KPOS(4,MXNC)
      INTEGER NPOS(MXNC)
      COMMON / NRD04  / IPOS,NPOS,KPOS
C
C  Common variables
C
      INTEGER JSCUP(8,MXNC)
      COMMON / NRD05  / JSCUP
C
C  Common variables
C
      INTEGER JFX(MXNC),KOPEN(MXNC)
      COMMON / NRD08  / JFX,KOPEN
C
C  Common variables
C
      INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF
      INTEGER NP(MXNW),NW
      COMMON / ORB04  / NW,NCF,NP,NAK,IQ
C
C  Common variables
C
      INTEGER ISPAR(MXNC),ITJPO(MXNC)
      COMMON / ORB07  / ITJPO,ISPAR
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
C
C  Set transformation coefficients to zero
C
      DO I = 1,MXNC
        DO J = 1,MXNC
          TC(I,J) = ZERO
        ENDDO
      ENDDO
C
      DO I = 1,8
        DO J = 1,MXNC
          JSCUP(I,J) = 0
        ENDDO
      ENDDO
C
C   LOOP OVER EACH NON-RELATIVISTIC CONFIGURATION IN TURN
C   -----------------------------------------------------
C
      NST = 1
      DO JMAN = 1,NMAN
        NOPEN = KOPEN(JMAN)
        JF = JFX(JMAN)
        NCF = NPOS(JMAN)
C
C  SET UP THE ARRAYS MLX,MQX,JPOS
C  ------------------------------
C
        NOP = 0
        DO I = 1,NWM
          NL = NLX(I)
          NQ = NQX(I,JMAN)
          NFULL = 4*NL+2
          IF (NQ.EQ.NFULL .OR. NQ.EQ.0) GOTO 10
          NOP = NOP+1
          MLX(NOP) = NL
          MQX(NOP) = NQ
          JPOS(NOP) = IPOS(I)
   10     CONTINUE
        ENDDO
C
C   FOUR OPEN SHELLS MUST ALWAYS BE DEFINED
C   AND THE FOLLOWING CODE INCLUDES EXTRA DUMMY ORBITALS
C   TO ENSURE THIS
C
        IF (NOP.LT.NOPENX) THEN
          NOP1 = NOP+1
          II = 1
          DO I = NOP1,NOPENX
            MLX(I) = 0
            MQX(I) = 0
            JPOS(I) = NW+II
            II = II+1
          ENDDO
        ENDIF
C
C  CALCULATE JJ-LS TRANSFORMATION MATRICES
C  ---------------------------------------
C
        IF (NCF.GE.NST) THEN
          IF (NOPEN.EQ.0) THEN
            TC(NCF,NCF) = ONE
C
          ELSE
            L = NST
            JF = JF+1
            IF (JF.GT.0) THEN
              CALL NRCSF(L,NCF,JF)
C
            ELSE
              JF = ITJPO(NST)
              DO I = NST,NCF
                IF (ITJPO(I).EQ.JF) GOTO 20
                CALL NRCSF(L,I-1,JF)
                L = I
                JF = ITJPO(I)
   20           CONTINUE
              ENDDO
              CALL NRCSF(L,NCF,JF)
            ENDIF
C
          ENDIF
C
        ENDIF
C
        NST = NCF+1
      ENDDO
C
      END
C
C                             *******************
C
      SUBROUTINE VACPOL
C
C-----------------------------------------------------------------------
C
C  This routine sets up the vacuum polarization potential for a point
C  charge Z at each grid point using the analytic functions defined by
C  L. Wayne Fullerton and G. A. Rinker Jr. in Phys. Rev. A Vol 13, page
C  1283, (1976).
C
C  Actually R* their potential is tabulated as we shall only require
C  this when we integrate.
C
C  The potential is accumulated in array TB(I),I=1,N which is in common
C  block /TATB/.
C
C  No subroutines called.
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  Statement functions
C
      DOUBLE PRECISION B,CF,D,E
      DOUBLE PRECISION P
C
C  Parameter variables
C
      DOUBLE PRECISION ZERO
      PARAMETER (ZERO=0.D0)
      DOUBLE PRECISION ONE
      PARAMETER (ONE=1.D0)
      DOUBLE PRECISION TWO
      PARAMETER (TWO=2.D0)
      DOUBLE PRECISION THREE
      PARAMETER (THREE=3.D0)
      DOUBLE PRECISION P0
      PARAMETER (P0=-0.71740181754D0)
      DOUBLE PRECISION P1
      PARAMETER (P1=1.1780972274D0)
      DOUBLE PRECISION P2
      PARAMETER (P2=-0.37499963087D0)
      DOUBLE PRECISION P3
      PARAMETER (P3=0.1308967553D0)
      DOUBLE PRECISION P4
      PARAMETER (P4=-0.038258286439D0)
      DOUBLE PRECISION P5
      PARAMETER (P5=-0.0000242972873D0)
      DOUBLE PRECISION P6
      PARAMETER (P6=-0.3592014867D-3)
      DOUBLE PRECISION P7
      PARAMETER (P7=-0.171700907D-4)
      DOUBLE PRECISION B0
      PARAMETER (B0=-64.0514843293D0)
      DOUBLE PRECISION B1
      PARAMETER (B1=0.711722714285D0)
      DOUBLE PRECISION CF0
      PARAMETER (CF0=64.0514843287D0)
      DOUBLE PRECISION CF1
      PARAMETER (CF1=-0.711722686403D0)
      DOUBLE PRECISION CF2
      PARAMETER (CF2=0.0008042207748D0)
      DOUBLE PRECISION D0
      PARAMETER (D0=217.2386409D0)
      DOUBLE PRECISION D1
      PARAMETER (D1=1643.364528D0)
      DOUBLE PRECISION D2
      PARAMETER (D2=2122.244512D0)
      DOUBLE PRECISION D3
      PARAMETER (D3=-45.12004044D0)
      DOUBLE PRECISION E0
      PARAMETER (E0=115.5589983D0)
      DOUBLE PRECISION E1
      PARAMETER (E1=1292.191441D0)
      DOUBLE PRECISION E2
      PARAMETER (E2=3831.198012D0)
      DOUBLE PRECISION E3
      PARAMETER (E3=2904.410075D0)
      DOUBLE PRECISION XX
      PARAMETER (XX=163.0D0)
      INTEGER N11
      PARAMETER (N11=MXNP+10)
C
C  Local variables
C
      DOUBLE PRECISION FACTOR,X,Y
      INTEGER I
C
C  Common variables
C
      DOUBLE PRECISION ACCY,C,EPH,H
      DOUBLE PRECISION RNT,Z
      INTEGER N,NCPRIN,NW1
      COMMON / DEF01  / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN
C
      DOUBLE PRECISION RGRID(MXNP)
      COMMON / GRID   / RGRID
C
      DOUBLE PRECISION TA(N11),TB(N11)
      COMMON / TATB   / TA,TB
C
      DOUBLE PRECISION XCON1
      DOUBLE PRECISION XCON2
      DOUBLE PRECISION XCON3
      DOUBLE PRECISION XCON4
      DOUBLE PRECISION XCL
      DOUBLE PRECISION XPI
      DOUBLE PRECISION XTAU
      COMMON / XCONS / XCON1, XCON2, XCON3, XCON4, XCL, XPI, XTAU
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C
C  The following are the analytic functions needed:
C
      P(X) = P0+X*(P1+X*(P2+X*(P3+X*(P4+X*(P5+X*(P6+X*P7))))))
      B(X) = B0+X*(B1+X)
      CF(X) = CF0+X*(CF1+X*CF2)
      D(X) = D0+X*(D1+X*(D2+X*(D3+X)))
      E(X) = E0+X*(E1+X*(E2+X*E3))
C-----------------------------------------------------------------------
      FACTOR = -(TWO*Z)/(THREE*XPI*XCL)
C
      DO I = 1,N
        X = TWO*RGRID(I)*XCL
        IF (X.LE.ONE) THEN
          Y = X*X
          TB(I) = FACTOR*(P(X)+LOG(X)*B(Y)/CF(Y))
        ELSE
          IF (X.GE.XX) THEN
            TB(I) = ZERO
          ELSE
            Y = ONE/X
            TB(I) = FACTOR*EXP(-X)*D(Y)/E(Y)/X**(THREE/TWO)
          ENDIF
        ENDIF
      ENDDO
C
      END
C
C                             *******************
C
      SUBROUTINE VIJOUT(JA,JB,IWRITE)
C
C-----------------------------------------------------------------------
C
C  Prints out tables of configurational quantum numbers defined
C  by SETUP for current matrix element.
C
C  No subroutines called.
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  Parameter variables
C
      CHARACTER*2 IJ1
      PARAMETER (IJ1 = '/2')
      CHARACTER*2 IJ2
      PARAMETER (IJ2 = '  ')
      INTEGER NPLX
      PARAMETER (NPLX=14)
C
C  Argument variables
C
      INTEGER IWRITE,JA,JB
C
C  Local variables
C
      CHARACTER*2 IC(2)
      INTEGER I,J,JC(2),JWW
C
C  Common variables
C
      INTEGER JJC1(NPLX),JJC2(NPLX)
      COMMON / ANG10  / JJC1,JJC2
C
C  Common variables
C
      INTEGER NQ1(MXNW),NQ2(MXNW)
      COMMON / ANG11  / NQ1,NQ2
C
C  Common variables
C
      INTEGER JJQ1(3,MXNW),JJQ2(3,MXNW)
      COMMON / ANG12  / JJQ1,JJQ2
C
C  Common variables
C
      INTEGER JLIST(NPLX),KLIST(MXNW),NCORE,NPEEL
      COMMON / ANG13  / JLIST,KLIST,NPEEL,NCORE
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
      IF (NPEEL.EQ.0) GOTO 50
C-----------------------------------------------------------------------
C
C   PRINT ACTIVE SHELL QUANTUM NUMBERS
C   FROM JLIST TABLE
C
C-----------------------------------------------------------------------
      WRITE (IWRITE,3000) JA,JB
      WRITE (IWRITE,3010)
C-----------------------------------------------------------------------
      DO J = 1,NPEEL
        JWW = JLIST(J)
        JC(1) = JJQ1(3,JWW)-1
        IC(1) = IJ1
        IF (MOD(JC(1),2).EQ.1) GOTO 10
        JC(1) = JC(1)/2
        IC(1) = IJ2
   10   CONTINUE
        JC(2) = JJQ2(3,JWW)-1
        IC(2) = IJ1
        IF (MOD(JC(2),2).EQ.1) GOTO 20
        JC(2) = JC(2)/2
        IC(2) = IJ2
   20   CONTINUE
        WRITE (IWRITE,3020) JWW,NQ1(JWW),JJQ1(1,JWW),JJQ1(2,JWW),JC(1),I!
     +C(1),NQ2(JWW),JJQ2(1,JWW),JJQ2(2,JWW),JC(2),IC(2)
      ENDDO
C-----------------------------------------------------------------------
      IF (NPEEL.LT.2) GOTO 50
C-----------------------------------------------------------------------
C
C   PRINT COUPLING ANGULAR MOMENTA
C      IF NPEEL.GE.2
C
C-----------------------------------------------------------------------
      WRITE (IWRITE,3030)
C-----------------------------------------------------------------------
      DO J = 2,NPEEL
        JC(1) = JJC1(J-1)-1
        IC(1) = IJ1
        IF (MOD(JC(1),2).EQ.1) GOTO 30
        JC(1) = JC(1)/2
        IC(1) = IJ2
   30   CONTINUE
        JC(2) = JJC2(J-1)-1
        IC(2) = IJ1
        IF (MOD(JC(2),2).EQ.1) GOTO 40
        JC(2) = JC(2)/2
        IC(2) = IJ2
   40   CONTINUE
        WRITE (IWRITE,3040) (JC(I),IC(I),I=1,2)
      ENDDO
C-----------------------------------------------------------------------
   50 CONTINUE
      WRITE (IWRITE,3050) NCORE
C-----------------------------------------------------------------------
 3000 FORMAT (//'   Configuration(',I3,') -',23X,'Configuration(',I3,   !
     +') -'//)
 3010 FORMAT (6X,'Shell',4X,'Q',4X,'V',2X,'W',2X,'J',19X,'Q',4X,'V',2X, !
     +'W',2X,'J'//)
 3020 FORMAT (7X,I3,I6,I5,2I3,A2,15X,I3,I5,2I3,A2)
 3030 FORMAT (//'    Coupling schemes - ')
 3040 FORMAT (14X,I2,A2,27X,I2,A2)
 3050 FORMAT (//'   There are ',I3,' inactive closed shells.'/)
      END
C
C                             *******************
C
      FUNCTION XA(JA,JB,K)
C
C-----------------------------------------------------------------------
C
C   Determine coefficient required for XPOT.
C
C   Subroutines called : CLRX
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      DOUBLE PRECISION XA
      INCLUDE 'grasp0.inc'
C
C  External functions
C
      EXTERNAL CLRX
      DOUBLE PRECISION CLRX
C
C  Parameter variables
C
      INTEGER N18
      PARAMETER (N18=MXNC*(MXNC+1)/2)
C
C  Argument variables
C
      INTEGER JA,JB,K
C
C  Local variables
C
      DOUBLE PRECISION COEF,WA,WX
      INTEGER ICOEF,IFA,IFB,IL
      INTEGER ILCX,ILDA,ILDB,ILDN
      INTEGER IQA,IQB,IRS,ITR
      INTEGER KA,KB
C
C  Common variables
C
      DOUBLE PRECISION HALF,ONE,TEN,TENTH
      DOUBLE PRECISION THREE,TWO,ZERO
      COMMON / CONS   / ZERO,HALF,TENTH,ONE,TWO,THREE,TEN
C
C  Common variables
C
      DOUBLE PRECISION ACCY,C,EPH,H
      DOUBLE PRECISION RNT,Z
      INTEGER N,NCPRIN,NW1
      COMMON / DEF01  / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN
C
C  Common variables
C
      DOUBLE PRECISION BREENG(MXNC),COUENG(MXNC)
      COMMON / ENRG1  / COUENG,BREENG
C
C  Common variables
C
      DOUBLE PRECISION EAV,UCF(MXNW)
      COMMON / HMAT   / EAV,UCF
C
C  Common variables
C
      DOUBLE PRECISION XSLDR(MXNM)
      INTEGER ISLDR(MXNM),NMCP
      COMMON / MCPA   / XSLDR,ISLDR,NMCP
C
C  Common variables
C
      INTEGER NNLDR(N18),NSLDF(N18)
      COMMON / MCPB   / NNLDR,NSLDF
C
C  Common variables
C
      integer jtc(20)
      common / opt02  / jtc
C
C  Common variables
C
      INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF
      INTEGER NP(MXNW),NW
      COMMON / ORB04  / NW,NCF,NP,NAK,IQ
C
C  Common variables
C
      INTEGER NKJ(MXNW),NKL(MXNW)
      COMMON / ORB05  / NKL,NKJ
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
      IFA = NKJ(JA)+1
      IFB = NKJ(JB)+1
      KA = NAK(JA)
      KB = NAK(JB)
      WA = ZERO
      ICOEF = 0
C
      DO ITR = 1,NCF
        IQA = IQ(JA,ITR)
        IQB = IQ(JB,ITR)
        IF (IQA.LT.IFA .AND. IQB.LT.IFB .and. jtc(13).ne.0) GOTO 10 !nrb
C
C   One orbital is in closed shell
C
        IF (ICOEF.EQ.0) THEN
          COEF = CLRX(KA,K,KB)**2
          ICOEF = 1
        ENDIF
C
        WX = -IQA*IQB*COEF
        GOTO 30
C
C   Both orbitals are in open shells
C
   10   CONTINUE
        IF (NMCP.EQ.0) GOTO 40
        IRS = (ITR-1)*(NCF+NCF-ITR)/2+ITR
        ILDN = NNLDR(IRS)
        IF (ILDN.LE.0) GOTO 40
        ILDA = NSLDF(IRS)
        ILDB = ILDA+ILDN-1
C
C   Form code number
C
        IF (JA.GT.JB) THEN
          ILCX = (((K*NW1+JB)*NW1+JA)*NW1+JA)*NW1+JB
        ELSE
          ILCX = (((K*NW1+JA)*NW1+JB)*NW1+JB)*NW1+JA
        ENDIF
C
        DO IL = ILDA,ILDB
          IF (ILCX.EQ.ISLDR(IL)) GOTO 20
        ENDDO
        GOTO 40
C
   20   CONTINUE
        WX = XSLDR(IL)
C
   30   CONTINUE
        WA = WA+WX*COUENG(ITR)*COUENG(ITR)
   40   CONTINUE
      ENDDO
C
      XA = WA/UCF(JA)
      END
C
C                             *******************
C
      SUBROUTINE XB(JC,JB,JD,K,WA)
C
C-----------------------------------------------------------------------
C
C   This subroutine is called by subroutine XPOT to accumulate
C   a list of the terms involved in tabulating exchange
C   potentials.
C
C   No subroutines called.
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  Argument variables
C
      DOUBLE PRECISION WA
      INTEGER JB,JC,JD,K
C
C  Local variables
C
      INTEGER I,ILCX
C
C  Common variables
C
      DOUBLE PRECISION ACCY,C,EPH,H
      DOUBLE PRECISION RNT,Z
      INTEGER N,NCPRIN,NW1
      COMMON / DEF01  / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN
C
C  Common variables
C
      INTEGER IPUNCH,IREAD,IWRITE
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
C
C  Common variables
C
      DOUBLE PRECISION CXCF(MXNE)
      INTEGER JXCF(MXNE),NSCF,NSCFY
      COMMON / MCPC   / CXCF,JXCF,NSCF,NSCFY
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
      ILCX = ((K*NW1+JD)*NW1+JB)*NW1+JC
C
C   If list is empty, add entry and set NSCF=1
C
      IF (NSCF.LE.0) GOTO 10
      DO I = 1,NSCF
C
C   Test if term already present
C
        IF (ILCX.EQ.JXCF(I)) GOTO 20
      ENDDO
C
C   If term not present, add new entry to table
C
   10 CONTINUE
      NSCF = NSCF+1
      IF (NSCF.GT.MXNE) GOTO 30
      IF (NSCF.GT.NSCFY) NSCFY = NSCF
      JXCF(NSCF) = ILCX
      CXCF(NSCF) = WA
      RETURN
C
C   If term already present, add new coefficient to entry
C
   20 CONTINUE
      CXCF(I) = CXCF(I)+WA
      RETURN
C
   30 CONTINUE
      WRITE (IWRITE,3000)
      WRITE (IPUNCH,3000)
      STOP
C
 3000 FORMAT (/' ERROR in XB : dimension of NSCF ... STOPPING'/         !
     +' Increase the value of MXNE')
      END
C
C                             *******************
C
      SUBROUTINE XPOT(J,XCF,ALX,ALY)
C
C-----------------------------------------------------------------------
C
C   This subroutine tabulates the exchange terms XP(R) and XQ(R).
C
C   Data
C
C   J     : serial number of orbital
C   XCF   : scale factor for multipying exchange terms
C
C   Results
C
C   XTP,XTQ : arrays containing exchange terms
C   ALX,ALY : leading coefficients in the expansions of the exchange
C             terms in powers of R
C
C   Subroutines called : XA,XB,QUAD,YZK
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  External functions
C
      EXTERNAL XA
      DOUBLE PRECISION XA
C
C  Parameter variables
C
      DOUBLE PRECISION EPS10
      PARAMETER (EPS10=1.D-10)
      INTEGER N10
      PARAMETER (N10=MXNX*MXNC)
      INTEGER N11
      PARAMETER (N11=MXNP+10)
      INTEGER N18
      PARAMETER (N18=MXNC*(MXNC+1)/2)
C
C  Argument variables
C
      DOUBLE PRECISION ALX,ALY,XCF
      INTEGER J
C
C  Local variables
C
      DOUBLE PRECISION RESULT,TOT,WA
      INTEGER I,IA,IB,ICF
      INTEGER ICFP,IJ,IJLB,IJLC
      INTEGER IJLD,IL,ILCX,ILDN
      INTEGER IRS,ITR,JAA,JBB
      INTEGER JJ,JLA,JLB,JLC
      INTEGER JLD,JTR,K,KA
      INTEGER KL,KM,KN,L
      INTEGER NCFM,NGRID,NGRID1,NKLNKJ
      INTEGER NKTEST
C
C  Common variables
C
      DOUBLE PRECISION HALF,ONE,TEN,TENTH
      DOUBLE PRECISION THREE,TWO,ZERO
      COMMON / CONS   / ZERO,HALF,TENTH,ONE,TWO,THREE,TEN
C
C  Common variables
C
      DOUBLE PRECISION ACCY,C,EPH,H
      DOUBLE PRECISION RNT,Z
      INTEGER N,NCPRIN,NW1
      COMMON / DEF01  / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN
C
C  Common variables
C
      INTEGER ICCMIN(MXNC),NCMIN
      COMMON / DEF07  / NCMIN,ICCMIN
C
C  Common variables
C
      DOUBLE PRECISION BREENG(MXNC),COUENG(MXNC)
      COMMON / ENRG1  / COUENG,BREENG
C
C  Common variables
C
      DOUBLE PRECISION PZ(MXNW),QZ(MXNW)
      COMMON / EXCO   / PZ,QZ
C
C  Common variables
C
      INTEGER JFIX(MXNW)
      COMMON / FIXD   / JFIX
C
C  Common variables
C
      DOUBLE PRECISION RGRID(MXNP)
      COMMON / GRID   / RGRID
C
C  Common variables
C
      DOUBLE PRECISION EAV,UCF(MXNW)
      COMMON / HMAT   / EAV,UCF
C
C  Common variables
C
      DOUBLE PRECISION XF(MXNP),XG(MXNP),XR(MXNP)
      DOUBLE PRECISION XS(MXNP),XU(MXNP),XV(MXNP)
      COMMON / INT3   / XU,XV,XR,XS,XF,XG
C
C  Common variables
C
      DOUBLE PRECISION XSLDR(MXNM)
      INTEGER ISLDR(MXNM),NMCP
      COMMON / MCPA   / XSLDR,ISLDR,NMCP
C
C  Common variables
C
      INTEGER NNLDR(N18),NSLDF(N18)
      COMMON / MCPB   / NNLDR,NSLDF
C
C  Common variables
C
      DOUBLE PRECISION CXCF(MXNE)
      INTEGER JXCF(MXNE),NSCF,NSCFY
      COMMON / MCPC   / CXCF,JXCF,NSCF,NSCFY
C
C  Common variables
C
      DOUBLE PRECISION ECV(MXNO)
      INTEGER IECC(MXNO),NEC
      COMMON / OFFD   / ECV,IECC,NEC
C
C  Common variables
C
      INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF
      INTEGER NP(MXNW),NW
      COMMON / ORB04  / NW,NCF,NP,NAK,IQ
C
C  Common variables
C
      INTEGER NKJ(MXNW),NKL(MXNW)
      COMMON / ORB05  / NKL,NKJ
C
C  Common variables
C
      INTEGER MPOIN(MXNW),MPOS(MXNW)
      COMMON / PATY   / MPOIN,MPOS
C
C  Common variables
C
      DOUBLE PRECISION XTP(MXNP),XTQ(MXNP),YP(MXNP)
      DOUBLE PRECISION YQ(MXNP)
      COMMON / POTE   / YP,YQ,XTP,XTQ
C
C  Common variables
C
      DOUBLE PRECISION CCR(N10),CHK(N10)
      COMMON / SEMI   / CHK,CCR
C
C  Common variables
C
      DOUBLE PRECISION TA(N11),TB(N11)
      COMMON / TATB   / TA,TB
C
C  Common variables
C
      DOUBLE PRECISION PF(MXNG),QF(MXNG)
      COMMON / WAVE   / PF,QF
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
C
C   clear for accumulation of sums
C
      ALX = ZERO
      ALY = ZERO
      DO I = 1,N
        XTP(I) = ZERO
        XTQ(I) = ZERO
      ENDDO
C
      IF (XCF.LT.EPS10) RETURN
C-----------------------------------------------------------------------
C
C   sum over all orbitals, avoiding serial number J
C
      DO L = 1,NW
C
        IF (JFIX(J).EQ.1 .AND. JFIX(L).EQ.0) GOTO 80
        IF (L.EQ.J) GOTO 80
C
C   tabulate mixed density
C
        NGRID = MIN(MPOIN(J),MPOIN(L))
        IJ = MPOS(J)
        IL = MPOS(L)
        DO I = 1,NGRID
          XU(I) = PF(IJ)*PF(IL)+QF(IJ)*QF(IL)
          XV(I) = XU(I)*RGRID(I)
          IJ = IJ+1
          IL = IL+1
        ENDDO
C
C   determine bounds for summation over K
C
        KM = (NKJ(J)+NKJ(L))/2
        KN = ABS(NKJ(J)-NKJ(L))/2
        NKLNKJ = NAK(L)*NAK(J)
C
        IF (NKLNKJ.LT.0) GOTO 50
C
C   tabulate integrand for expansion coefficients
C
        IF (NKLNKJ.GT.NAK(J)**2) GOTO 60
C
        IF (KN-1) 10,20,30
   10   CONTINUE
        DO I = 1,NGRID
          TA(I) = XU(I)
        ENDDO
        GOTO 40
C
   20   CONTINUE
        DO I = 1,NGRID
          TA(I) = XU(I)/RGRID(I)
        ENDDO
        GOTO 40
C
   30   CONTINUE
        DO I = 1,NGRID
          TA(I) = XU(I)/(RGRID(I)**KN)
        ENDDO
C
   40   CONTINUE
        CALL QUAD(NGRID,RESULT)
        WA = XA(J,L,KN)*XCF/C
C
        IF (ABS(WA).LT.EPS10) GOTO 60
        ALX = ALX+RESULT*QZ(L)*WA
        ALY = ALY-RESULT*PZ(L)*WA
        GOTO 60
C
   50   CONTINUE
        KN = KN+1
C
   60   CONTINUE
        DO K = KN,KM,2
C
          WA = XA(J,L,K)
          WA = WA*XCF/C
C
          IF (ABS(WA).LT.EPS10) GOTO 70
C
C   form integrand for subroutine YZK
C
          DO I = 1,NGRID
            TA(I) = XV(I)
          ENDDO
C
C    tabulate function YK(R)
C
          CALL YZK(NGRID,K)
C
C   add contributions from exchange terms
C
          IL = MPOS(L)
          DO I = 1,NGRID
            XTP(I) = XTP(I)+TB(I)*QF(IL)*WA
            XTQ(I) = XTQ(I)-TB(I)*PF(IL)*WA
            IL = IL+1
          ENDDO
C
   70     CONTINUE
        ENDDO
C
C   add contributions from off-diagonal parameters
C   ----------------------------------------------
C
        IF (NEC.GT.0) THEN
C
          IF (J.LT.L) THEN
            KA = NW1*L+J
          ELSE
            KA = NW1*J+L
          ENDIF
C
          DO I = 1,NEC
            IF (IECC(I).EQ.KA) THEN
C
              WA = ECV(I)*XCF/(UCF(J)*C)
C
              IF (ABS(WA).GT.EPS10) THEN
C
C   add contribution to leading coefficients
C
                ALX = ALX+WA*QZ(L)
                ALY = ALY-WA*PZ(L)
C
C   add contributions to exchange terms
C
                KL = MPOS(L)
                DO K = 1,NGRID
                  XTP(K) = XTP(K)+WA*QF(KL)*RGRID(K)
                  XTQ(K) = XTQ(K)-WA*PF(KL)*RGRID(K)
                  KL = KL+1
                ENDDO
C
              ENDIF
C
            ENDIF
          ENDDO
C
        ENDIF
C
   80   CONTINUE
      ENDDO
C-----------------------------------------------------------------------
C
C   add contributions from open shell orbitals
C   ------------------------------------------
C
      IF (NCMIN.EQ.0) RETURN
      IF (NMCP.EQ.0) RETURN
C
      NSCF = 0
      NCFM = NCF-1
      DO ITR = 1,NCFM
        ICFP = ITR+1
        DO JTR = ICFP,NCF
          IRS = (ITR-1)*(NCF+NCF-ITR)/2+JTR
          ILDN = NNLDR(IRS)
C
          IF (ILDN.GT.0) THEN
            JAA = NSLDF(IRS)
            JBB = JAA+ILDN-1
            DO JJ = JAA,JBB
C
C   extract quantum number from coded forms
C
              ILCX = ISLDR(JJ)
              JLA = MOD(ILCX,NW1)
              ILCX = ILCX/NW1
              JLB = MOD(ILCX,NW1)
              ILCX = ILCX/NW1
              JLC = MOD(ILCX,NW1)
              IF (JLC.EQ.0) GOTO 90
              ILCX = ILCX/NW1
              JLD = MOD(ILCX,NW1)
              K = ILCX/NW1
C
              IF (NCMIN.LE.1) THEN
                WA = XSLDR(JJ)*COUENG(ITR)*COUENG(JTR)
              ELSE
                TOT = ZERO
                IA = ITR
                IB = JTR
                DO I = 1,NCMIN
                  TOT = TOT+CCR(IA)*CCR(IB)
                  IA = IA+NCF
                  IB = IB+NCF
                ENDDO
                WA = XSLDR(JJ)*TOT/NCMIN
              ENDIF
C
C   accumulate coefficients from each of the four parameters
C   in turn
C
              IF (JLA.EQ.J) CALL XB(JLC,JLB,JLD,K,WA)
              IF (JLB.EQ.J) CALL XB(JLD,JLA,JLC,K,WA)
              IF (JLC.EQ.J) CALL XB(JLA,JLB,JLD,K,WA)
              IF (JLD.EQ.J) CALL XB(JLB,JLA,JLC,K,WA)
   90         CONTINUE
            ENDDO
          ENDIF
C
        ENDDO
      ENDDO
C-----------------------------------------------------------------------
      IF (NSCF.GT.0) THEN
C
C   retrieve successive terms
C
        DO ICF = 1,NSCF
          ILCX = JXCF(ICF)
          JLC = MOD(ILCX,NW1)
          IF (JFIX(J).EQ.1 .AND. JFIX(JLC).EQ.0) GOTO 150
          ILCX = ILCX/NW1
          JLB = MOD(ILCX,NW1)
          IF (JFIX(J).EQ.1 .AND. JFIX(JLB).EQ.0) GOTO 150
          ILCX = ILCX/NW1
          JLD = MOD(ILCX,NW1)
          IF (JFIX(J).EQ.1 .AND. JFIX(JLD).EQ.0) GOTO 150
          K = ILCX/NW1
C
C   determine coefficient
C
          WA = CXCF(ICF)*XCF/(C*UCF(J))
C
          IF (ABS(WA).GE.EPS10) THEN
C
C   form integrand for subroutine YZK
C
            NGRID = MIN(MPOIN(JLB),MPOIN(JLD))
            IJLB = MPOS(JLB)
            IJLD = MPOS(JLD)
            DO I = 1,NGRID
              TA(I) = (PF(IJLB)*PF(IJLD)+QF(IJLB)*QF(IJLD))*RGRID(I)*WA
              IJLB = IJLB+1
              IJLD = IJLD+1
            ENDDO
C
C   tabulate YK(R)
C
            CALL YZK(NGRID,K)
C
C   add contributions to exchange terms
C   -----------------------------------
C
            NGRID1 = MIN(NGRID,MPOIN(JLC))
            IJLC = MPOS(JLC)
            DO I = 1,NGRID1
              XTP(I) = XTP(I)+TB(I)*QF(IJLC)
              XTQ(I) = XTQ(I)-TB(I)*PF(IJLC)
              IJLC = IJLC+1
            ENDDO
C
C   add contributions to leading coefficients
C   -----------------------------------------
C
            NKTEST = NAK(JLC)*NAK(J)
            IF (NKTEST.GT.NAK(J)**2) GOTO 140
            IF (NKTEST.LT.0) GOTO 140
            IF (K.GT.ABS(NAK(J)-NAK(JLC))) GOTO 140
C
            NGRID = MIN(MPOIN(JLB),MPOIN(JLD))
            IJLB = MPOS(JLB)
            IJLD = MPOS(JLD)
C
            IF (K-1) 100,110,120
C
  100       CONTINUE
            DO I = 1,NGRID
              TA(I) = PF(IJLB)*PF(IJLD)+QF(IJLB)*QF(IJLD)
              IJLB = IJLB+1
              IJLD = IJLD+1
            ENDDO
            GOTO 130
C
  110       CONTINUE
            DO I = 1,NGRID
              TA(I) = (PF(IJLB)*PF(IJLD)+QF(IJLB)*QF(IJLD))/RGRID(I)
              IJLB = IJLB+1
              IJLD = IJLD+1
            ENDDO
            GOTO 130
C
  120       CONTINUE
            DO I = 1,NGRID
              TA(I) = (PF(IJLB)*PF(IJLD)+QF(IJLB)*QF(IJLD))/(RGRID(I)**K!
     +)
              IJLB = IJLB+1
              IJLD = IJLD+1
            ENDDO
C
  130       CONTINUE
            CALL QUAD(NGRID,RESULT)
            ALX = ALX+RESULT*QZ(JLC)*WA
            ALY = ALY-RESULT*PZ(JLC)*WA
C
  140       CONTINUE
          ENDIF
C
  150     CONTINUE
        ENDDO
      ENDIF
C
      END
C
C                             *******************
C
      FUNCTION YA(JA,JB,K)
C
C-----------------------------------------------------------------------
C
C   Determine coefficient required by YPOT.
C
C   Subroutines called : CLRX
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      DOUBLE PRECISION YA
      INCLUDE 'grasp0.inc'
C
C  External functions
C
      EXTERNAL CLRX
      DOUBLE PRECISION CLRX
C
C  Parameter variables
C
      INTEGER N18
      PARAMETER (N18=MXNC*(MXNC+1)/2)
C
C  Argument variables
C
      INTEGER JA,JB,K
C
C  Local variables
C
      DOUBLE PRECISION COEF,WA,WX
      INTEGER ICOEF,IFA,IFB,IL
      INTEGER ILCX,ILDA,ILDB,ILDN
      INTEGER IQA,IQB,IRS,ITR
      INTEGER KA
C
C  Common variables
C
      DOUBLE PRECISION HALF,ONE,TEN,TENTH
      DOUBLE PRECISION THREE,TWO,ZERO
      COMMON / CONS   / ZERO,HALF,TENTH,ONE,TWO,THREE,TEN
C
C  Common variables
C
      DOUBLE PRECISION ACCY,C,EPH,H
      DOUBLE PRECISION RNT,Z
      INTEGER N,NCPRIN,NW1
      COMMON / DEF01  / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN
C
C  Common variables
C
      DOUBLE PRECISION BREENG(MXNC),COUENG(MXNC)
      COMMON / ENRG1  / COUENG,BREENG
C
C  Common variables
C
      DOUBLE PRECISION EAV,UCF(MXNW)
      COMMON / HMAT   / EAV,UCF
C
C  Common variables
C
      DOUBLE PRECISION XSLDR(MXNM)
      INTEGER ISLDR(MXNM),NMCP
      COMMON / MCPA   / XSLDR,ISLDR,NMCP
C
C  Common variables
C
      INTEGER NNLDR(N18),NSLDF(N18)
      COMMON / MCPB   / NNLDR,NSLDF
C
C  Common variables
C
      integer jtc(20)
      common / opt02  / jtc
C
C  Common variables
C
      INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF
      INTEGER NP(MXNW),NW
      COMMON / ORB04  / NW,NCF,NP,NAK,IQ
C
C  Common variables
C
      INTEGER NKJ(MXNW),NKL(MXNW)
      COMMON / ORB05  / NKL,NKJ
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
      IFA = NKJ(JA)+1
      IFB = NKJ(JB)+1
      KA = NAK(JA)
      WA = ZERO
      ICOEF = 0
C
      DO ITR = 1,NCF
        IQA = IQ(JA,ITR)
        IQB = IQ(JB,ITR)
        IF (IQA.LT.IFA .AND. IQB.LT.IFB .and. jtc(13).ne.0) GOTO 10 !nrb
C
C  One orbital is in a closed shell
C
        IF (JA.NE.JB.or.iqa.eq.0) GOTO 40
        IF (ICOEF.EQ.0) THEN
          COEF = CLRX(KA,K,KA)**2
          ICOEF = 1
        ENDIF
C
        WX = -IQA*IQA*COEF
c
c mod for pure SCF run with no use of MCP.DAT data - nrb 25/09/09
c
        if(jtc(13).eq.0.and.iqa.lt.ifa)then
          wx=wx*dble(ifa*(iqa-1))/dble((ifa-1)*iqa)
        endif
c
        GOTO 30
C
C  Both orbitals are in open shells
C
   10   CONTINUE
        IF (NMCP.EQ.0) GOTO 40
        IRS = (ITR-1)*(NCF+NCF-ITR)/2+ITR
        ILDN = NNLDR(IRS)
        IF (ILDN.LE.0) GOTO 40
        ILDA = NSLDF(IRS)
        ILDB = ILDA+ILDN-1
C
C  Construct code number
C
        IF (JA.GT.JB) THEN
          ILCX = (((K*NW1+JB)*NW1+JA)*NW1+JB)*NW1+JA
        ELSE
          ILCX = (((K*NW1+JA)*NW1+JB)*NW1+JA)*NW1+JB
        ENDIF
C
C  Hunt in table
C
        DO IL = ILDA,ILDB
          IF (ILCX.EQ.ISLDR(IL)) GOTO 20
        ENDDO
        GOTO 40
C
   20   CONTINUE
        WX = XSLDR(IL)
        IF (JA.EQ.JB) WX = WX + WX
C
   30   CONTINUE
        WA = WA+WX*COUENG(ITR)*COUENG(ITR)
   40   CONTINUE
      ENDDO
C
      YA = WA/UCF(JA)
C
      END
C
C                             *******************
C
      SUBROUTINE YBRA(NGRID,K)
C
C-----------------------------------------------------------------------
C
C  This routine calculates the function Y(K BAR) occuring in the
C  computation of Breit interaction integrals. This function is
C  calculated by the same outward integration used to compute the
C  function Z in the evaluation of Slater integrals.
C
C  The function Y(K BAR) is returned in the array TB
C
C  Data
C
C  TA :  common array containing a table of the integrand, F(R).
C  K  :  value of K.
C
C  No subroutines called.
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  Parameter variables
C
      DOUBLE PRECISION EPS30
      PARAMETER (EPS30=1.D-30)
      DOUBLE PRECISION Y0
      PARAMETER (Y0=13.D0/24.D0)
      DOUBLE PRECISION Y1
      PARAMETER (Y1=1.D0/24.D0)
      INTEGER N11
      PARAMETER (N11=MXNP+10)
C
C  Argument variables
C
      INTEGER K,NGRID
C
C  Local variables
C
      DOUBLE PRECISION FK,FL,RATIO,WA
      DOUBLE PRECISION WB,WC,WD,WE
      INTEGER I,J
C
C  Common variables
C
      DOUBLE PRECISION HALF,ONE,TEN,TENTH
      DOUBLE PRECISION THREE,TWO,ZERO
      COMMON / CONS   / ZERO,HALF,TENTH,ONE,TWO,THREE,TEN
C
C  Common variables
C
      DOUBLE PRECISION ACCY,C,EPH,H
      DOUBLE PRECISION RNT,Z
      INTEGER N,NCPRIN,NW1
      COMMON / DEF01  / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN
C
C  Common variables
C
      DOUBLE PRECISION TA(N11),TB(N11)
      COMMON / TATB   / TA,TB
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
C
C  Find estimate for initial slope from first two non-zero values of TA
C
      DO J = 1,NGRID
        TB(J) = ZERO
      ENDDO
C
      DO J = 1,NGRID
        IF (ABS(TA(J)).LT.EPS30) GOTO 10
        RATIO = TA(J+1)/TA(J)
        IF (RATIO.GT.ZERO) GOTO 20
   10   CONTINUE
      ENDDO
      RETURN
C
   20 CONTINUE
      FL = LOG(RATIO)/H
      FK = DBLE(K)
      WA = FK+FL
C
C  Two starting values for outward integration
C
      TB(1) = TA(1)/WA
      TB(2) = TA(2)/WA
C
C  Coefficients in outward recurrence relation
C
      WA = EXP(-FK*H)
      WD = Y0*H
      WC = WD*WA
      WE = -Y1*H
      WB = WE*WA*WA
      WE = WE/WA
C
C  Add two extra zeros at end of table
C
      TA(NGRID+2) = ZERO
      TA(NGRID+1) = ZERO
C
C  Outward integration
C
      DO I = 2,NGRID
        TB(I+1) = WA*TB(I)+WB*TA(I-1)+WC*TA(I)+WD*TA(I+1)+WE*TA(I+2)
      ENDDO
C
      END
C
C                             *******************
C
      SUBROUTINE YPOT(J,VN,ZFAC)
C
C-----------------------------------------------------------------------
C
C  This subroutine tabulates the potential function Y(R) for orbital J.
C  The function is tabulated in the arrays YP and YQ.  Also VN is
C  calculated.  VN is the second term in the expansion of Y(R)
C      Y(R)= Z+VN*R + ...
C
C  Subroutines called : YA, QUAD, YZK
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  External functions
C
      EXTERNAL YA
      DOUBLE PRECISION YA
C
C  Parameter variables
C
      DOUBLE PRECISION EPS10
      PARAMETER (EPS10=1.D-10)
      INTEGER N11
      PARAMETER (N11=MXNP+10)
C
C  Argument variables
C
      DOUBLE PRECISION VN,ZFAC
      INTEGER J
C
C  Local variables
C
      DOUBLE PRECISION QA,QB,WA,WX
      INTEGER I,IL,K,KB
      INTEGER KBA,L,NGRID
C
C  Common variables
C
      DOUBLE PRECISION HALF,ONE,TEN,TENTH
      DOUBLE PRECISION THREE,TWO,ZERO
      COMMON / CONS   / ZERO,HALF,TENTH,ONE,TWO,THREE,TEN
C
C  Common variables
C
      DOUBLE PRECISION ACCY,C,EPH,H
      DOUBLE PRECISION RNT,Z
      INTEGER N,NCPRIN,NW1
      COMMON / DEF01  / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN
C
C  Common variables
C
      DOUBLE PRECISION BREENG(MXNC),COUENG(MXNC)
      COMMON / ENRG1  / COUENG,BREENG
C
C  Common variables
C
      INTEGER JFIX(MXNW)
      COMMON / FIXD   / JFIX
C
C  Common variables
C
      DOUBLE PRECISION RGRID(MXNP)
      COMMON / GRID   / RGRID
C
C  Common variables
C
      DOUBLE PRECISION EAV,UCF(MXNW)
      COMMON / HMAT   / EAV,UCF
C
C  Common variables
C
      DOUBLE PRECISION PARM(4),Z1
      INTEGER NPARM,NUCTYP
      COMMON / NPAR   / PARM,Z1,NUCTYP,NPARM
C
C  Common variables
C
      DOUBLE PRECISION ZZ(MXNP)
      COMMON / NPOT   / ZZ
C
C  Common variables
C
      INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF
      INTEGER NP(MXNW),NW
      COMMON / ORB04  / NW,NCF,NP,NAK,IQ
C
C  Common variables
C
      INTEGER NKJ(MXNW),NKL(MXNW)
      COMMON / ORB05  / NKL,NKJ
C
C  Common variables
C
      INTEGER MPOIN(MXNW),MPOS(MXNW)
      COMMON / PATY   / MPOIN,MPOS
C
C  Common variables
C
      DOUBLE PRECISION XTP(MXNP),XTQ(MXNP),YP(MXNP)
      DOUBLE PRECISION YQ(MXNP)
      COMMON / POTE   / YP,YQ,XTP,XTQ
C
C  Common variables
C
      DOUBLE PRECISION TA(N11),TB(N11)
      COMMON / TATB   / TA,TB
C
C  Common variables
C
      DOUBLE PRECISION PF(MXNG),QF(MXNG)
      COMMON / WAVE   / PF,QF
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
C
C  clear for total density
C
      DO I = 1,N
        TA(I) = ZERO
      ENDDO
C
C  loop over the orbitals
C
      DO L = 1,NW
C
        IF (JFIX(J).EQ.1 .AND. JFIX(L).EQ.0) GOTO 10
C
        WA = ZERO
        DO I = 1,NCF
          QA = DBLE(IQ(J,I))
          QB = DBLE(IQ(L,I))
          WX = QA*QB
          IF (L.EQ.J) WX = WX - QA
          WA = WA+COUENG(I)*COUENG(I)*WX
        ENDDO
        WA = WA/UCF(J)
C
C  add contribution to density
C
        IF (ABS(WA).GE.EPS10) THEN
          NGRID = MPOIN(L)
          IL = MPOS(L)
          DO I = 1,NGRID
            TA(I) = TA(I)+(PF(IL)*PF(IL)+QF(IL)*QF(IL))*WA
            IL = IL+1
          ENDDO
        ENDIF
C
   10   CONTINUE
      ENDDO
C
C  compute VN
C  ----------
C
      CALL QUAD(N,VN)
      VN = -VN+Z1*ZFAC
C
C  tabulate integrand for subroutine YZK
C
      DO I = 1,N
        TA(I) = TA(I)*RGRID(I)
      ENDDO
C
C  result includes all terms with K = 0
C
      CALL YZK(N,0)
      DO I = 1,N
        YP(I) = ZZ(I)*ZFAC-TB(I)
      ENDDO
C
C  now compute other values of K
C  -----------------------------
C
      KB = NKJ(J)-1
      DO L = 1,NW
        IF (JFIX(J).EQ.1 .AND. JFIX(L).EQ.0) GOTO 20
C
        KBA = NKJ(L)-1
        IF (KB.LT.KBA) KBA = KB
C
        IF (KBA.GT.0) THEN
          DO K = 2,KBA,2
            WA = YA(J,L,K)
C
            IF (ABS(WA).GE.EPS10) THEN
C
C  tabulate integrand
C
              NGRID = MPOIN(L)
              IL = MPOS(L)
              DO I = 1,NGRID
                TA(I) = WA*RGRID(I)*(PF(IL)*PF(IL)+QF(IL)*QF(IL))
                IL = IL+1
              ENDDO
C
C  form YK(R)
C
              CALL YZK(NGRID,K)
C
C  add contribution to Y(R)
C
              DO I = 1,NGRID
                YP(I) = YP(I)-TB(I)
              ENDDO
            ENDIF
C
          ENDDO
        ENDIF
C
   20   CONTINUE
      ENDDO
C
      DO I = 1,N
        YQ(I) = YP(I)
      ENDDO
C
      END
C
C                             *******************
C
      SUBROUTINE YPOTX
C
C-----------------------------------------------------------------------
C
C   This subroutine evaluates the static potential.
C
C   Subroutines called : YZK
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  Parameter variables
C
      INTEGER N11
      PARAMETER (N11=MXNP+10)
C
C  Local variables
C
      DOUBLE PRECISION DGZ,EXCESS,STEP1,STEP2
      INTEGER I,IJ,J,NGRID
      INTEGER NLAST
C
C  Common variables
C
      DOUBLE PRECISION HALF,ONE,TEN,TENTH
      DOUBLE PRECISION THREE,TWO,ZERO
      COMMON / CONS   / ZERO,HALF,TENTH,ONE,TWO,THREE,TEN
C
C  Common variables
C
      DOUBLE PRECISION ACCY,C,EPH,H
      DOUBLE PRECISION RNT,Z
      INTEGER N,NCPRIN,NW1
      COMMON / DEF01  / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN
C
C  Common variables
C
      DOUBLE PRECISION RGRID(MXNP)
      COMMON / GRID   / RGRID
C
C  Common variables
C
      DOUBLE PRECISION EAV,UCF(MXNW)
      COMMON / HMAT   / EAV,UCF
C
C  Common variables
C
      INTEGER IPUNCH,IREAD,IWRITE
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
C
C  Common variables
C
      DOUBLE PRECISION ZZ(MXNP)
      COMMON / NPOT   / ZZ
C
C  Common variables
C
      INTEGER ITC(50)
      COMMON / OPT01  / ITC
C
C  Common variables
C
      INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF
      INTEGER NP(MXNW),NW
      COMMON / ORB04  / NW,NCF,NP,NAK,IQ
C
C  Common variables
C
      INTEGER MPOIN(MXNW),MPOS(MXNW)
      COMMON / PATY   / MPOIN,MPOS
C
C  Common variables
C
      DOUBLE PRECISION TA(N11),TB(N11)
      COMMON / TATB   / TA,TB
C
C  Common variables
C
      DOUBLE PRECISION PF(MXNG),QF(MXNG)
      COMMON / WAVE   / PF,QF
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
      WRITE (IWRITE,3000)
C
      DO I = 1,N
        TA(I) = ZERO
      ENDDO
C
      DO J = 1,NW
        IJ = MPOS(J)
        NGRID = MPOIN(J)
        DO I = 1,NGRID
          TA(I) = TA(I)+UCF(J)*(PF(IJ)*PF(IJ)+QF(IJ)*QF(IJ))
          IJ = IJ+1
        ENDDO
      ENDDO
C
      DO I = 1,N
        TA(I) = TA(I)*RGRID(I)
      ENDDO
C-----------------------------------------------------------------------
      STEP1 = RGRID(2)-RGRID(1)
      STEP2 = RGRID(N)-RGRID(N-1)
      WRITE (IWRITE,3040) N,H,EPH,RGRID(1),RGRID(N),STEP1,STEP2
C
      CALL YZK(N,0)
C
      DO I = 1,N
        TA(I) = TB(I)-ZZ(I)
      ENDDO
C-----------------------------------------------------------------------
C
C   Write out the logarithmic grid and static potential.
C
      IF (ITC(42).EQ.1) THEN
        WRITE (IWRITE,3010) (RGRID(I),I=1,N)
        WRITE (IWRITE,3020) (TA(I),I=1,N)
        WRITE (IWRITE,3030) (TB(I),I=1,N)
      ENDIF
C
      WRITE (IWRITE,3060) TA(N)
      WRITE (IWRITE,3070) ZZ(N)
C
      DGZ = Z
      DO I = 1,NW
        DGZ = DGZ-IQ(I,1)
      ENDDO
C
      EXCESS = TA(N)+DGZ
      WRITE (IWRITE,3050) EXCESS
C
      NLAST = MPOS(NW)+MPOIN(NW)-1
C
      WRITE (IWRITE,3080) NLAST,MXNG,N,MXNP
C-----------------------------------------------------------------------
 3000 FORMAT (/' >>>> routine YPOTX called')
 3010 FORMAT (/' log grid'/' --------'/(1X,1P,6E12.4))
 3020 FORMAT (/' static potential'/1X,16('-')/(1X,1P,6E12.4))
 3030 FORMAT (/' total charge'/1X,16('-')/(1X,1P,6E12.4))
 3040 FORMAT (/' logarithmic grid is defined as follows :'//            !
     +'    N (number of points)   = ',I4/'    H (stepsize)           = '!
     +,1P,E12.5/'    EXP(H)                 = ',E12.5/                  !
     +'    first grid point (RNT) = ',E12.5/                            !
     +'    last  grid point       = ',E12.5/                            !
     +'    initial stepsize       = ',E12.5/                            !
     +'      final stepsize       = ',E12.5)
 3050 FORMAT (' excess (static potential+residual charge) = ',1P,E14.7)
 3060 FORMAT (/' last point in  static potential           = ',1P,E14.7)
 3070 FORMAT (' last point in nuclear potential           = ',1P,E14.7)
 3080 FORMAT (/' number of w.f. points                     = ',I7,      !
     +'       (max=',I7,')'/                                            !
     +' number of grid points                     = ',I7,'       (max=',!
     +I7,')')
      END
C
C                             *******************
C
      SUBROUTINE YZK(NGRID,K)
C
C-----------------------------------------------------------------------
C
C   This subroutine evaluates potentials Y(K,R) which are used to form
C   the SCF potentials and Slater integrals.
C            Y(K,R)=R*I<U(K,R,S)*F(S)>
C   where I<> denotes the integral from zero to infinity over S
C   If  Z(K,R)=J<F(S)*S**K>/R**K  where J<> denotes the integral from
C   zero to R over S, then we can obtain a pair of coupled equations
C   for Y and Z. These are solved , outward for Z and inward for Y.
C
C   initially : TA contains S*F(S) for I=1,..,NGRID
C   finally   : TB contains Y(K,R) for I=1,..,NGRID
C
C Note that the array TA is zero for I>NGRID with the point being
C controlled by the parameter CUTOFF. Therefore it is assumed
C that when the point NGRID is reached
C      Y = Z = CONSTANT/R**K
C This is also assumed for the point NGRID-1.
C
C   TA is tabulated to N+2
C   TB is tabulated to N+3
C   TC is tabulated to N+2
C
C   This version uses a five point central difference formula,
C   which corresponds to Simpson's rule plus a correction to give
C   an error varying as O(H**6). The method thus steps two points
C   at once, and the errors at odd and even points are independent.
C   The method is described by Charlotte Froese Fischer in her book
C   'The Hartree Fock Method For Atoms', Wiley, 1977. However this
C   routine does not subtract the error in the Z0 function at large
C   R from the value of Z0 at all R. In the MCDF programs RNT
C   is usually 1.0E-5, which is much smaller than in MCHF. In this
C   case the use of an expansion technique for ZK at small R
C   introduces no significant error, and the accuracy of the Z0
C   functions at large R is limited by the precision of the computer.
C   This routine may need to be modified if RNT is to be increased
C   beyond 1.0E-3.
C
C   No subroutines called.
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  Parameter variables
C
      DOUBLE PRECISION EPS35
      PARAMETER (EPS35=1.D-35)
      DOUBLE PRECISION ZERO
      PARAMETER (ZERO=0.D0)
      DOUBLE PRECISION ONE
      PARAMETER (ONE=1.D0)
      DOUBLE PRECISION THREE
      PARAMETER (THREE=3.D0)
      DOUBLE PRECISION FOUR
      PARAMETER (FOUR=4.D0)
      DOUBLE PRECISION THIRD
      PARAMETER (THIRD=ONE/THREE)
      DOUBLE PRECISION YY0
      PARAMETER (YY0=-1.D0/9.D1)
      DOUBLE PRECISION YY1
      PARAMETER (YY1=-3.4D1)
      DOUBLE PRECISION YY2
      PARAMETER (YY2=-1.14D2)
      INTEGER N11
      PARAMETER (N11=MXNP+10)
C
C  Argument variables
C
      INTEGER K,NGRID
C
C  Local variables
C
      DOUBLE PRECISION CA,CB,CC,CD
      DOUBLE PRECISION CE,EMP,FK,FL
      DOUBLE PRECISION RATIO,TC(N11),WA,WB
      DOUBLE PRECISION WC,WK,WKL,WKS
      DOUBLE PRECISION XA,XB,YA,YB
      DOUBLE PRECISION YC,YD,YE
      INTEGER I,J
C
C  Common variables
C
      DOUBLE PRECISION ACCY,C,EPH,H
      DOUBLE PRECISION RNT,Z
      INTEGER N,NCPRIN,NW1
      COMMON / DEF01  / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN
C
C  Common variables
C
      DOUBLE PRECISION TA(N11),TB(N11)
      COMMON / TATB   / TA,TB
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
C
C   find the power dependence of TA near the origin
C
      DO J = 1,NGRID
        IF (ABS(TA(J)).LT.EPS35) GOTO 10
        RATIO = TA(J+1)/TA(J)
        IF (RATIO.GT.ZERO) GOTO 20
   10   CONTINUE
      ENDDO
      do j=1,ngrid
        tb(j)=zero
      enddo
      RETURN
C
   20 CONTINUE
      FL = LOG(RATIO)/H
      EMP = ONE/EPH
      WA = EMP**FL
C
C   copy TA into TB. Move elements by one to allow a zeroth
C   element to be included.
C
      TB(1) = WA*TA(1)
      DO I = 1,NGRID
        TB(I+1) = TA(I)
      ENDDO
C
      TB(NGRID+2) = ZERO
      TB(NGRID+3) = ZERO
C
C   set up constants for integration
C
C   Simpson's rule
C
      CB = H*THIRD
      CA = CB*FOUR
C
C   five point central difference formula
C
      CC = H*YY0
      CD = YY1*CC
      CE = YY2*CC
C
      FK = K
C
C   solve equations for Z(K,R) outwards
C   TA contains Z(K,R)
C
      WK = EMP**FK
      WKS = WK*WK
      WA = CB*WKS
      WB = CA*WK
      WC = CB
C
      YA = CC*WKS*WK
      YB = CD*WKS
      YC = CE*WK
      YD = CD
      YE = CC/WK
C
C   start outwards integration by using the power dependence
C   of TA at the first two points, then Simpson's rule at
C   the third
C
      WKL = ONE/(FK+FL)
      TA(1) = TB(1)*WKL
      TA(2) = TB(2)*WKL
      TA(3) = WKS*TA(1)+WA*TB(1)+WB*TB(2)+WC*TB(3)
C
C   main outwards integration using five point central formula
C
      DO J = 4,NGRID+2
        TC(J) = YA*TB(J-3)+YB*TB(J-2)+YC*TB(J-1)+YD*TB(J)+YE*TB(J+1)
      ENDDO
C
      DO J = 4,NGRID+2
        TA(J) = WKS*TA(J-2)+TC(J)
      ENDDO
C
C  complete the table using Z=Y=CONSTANT/R**K
C
      IF (NGRID+2.LT.N) THEN
        DO I = NGRID+3,N+1
          TA(I) = TA(I-1)*WK
        ENDDO
        DO I = NGRID+1,N
          TB(I) = TA(I+1)
        ENDDO
      ENDIF
C
C   solve equations for Y(K,R) inwards
C   TB contains Y(K,R)
C
      WK = WK*EMP
      WKS = WK*WK
      XB = FK+FK+ONE
      XA = XB*WK
C
      WA = CB*XA*WK
      WB = CA*XA
      WC = CA*XB
C
      YA = CC*XA*WKS
      YB = CD*XA*WK
      YC = CE*XA
      YD = CD*XB
      YE = CC*XB/WK
C
C   main integration with five point central difference
C
      TB(NGRID) = TA(NGRID+1)
      TB(NGRID-1) = TA(NGRID)
      DO J = NGRID-2,2,-1
        TC(J) = YA*TA(J+4)+YB*TA(J+3)+YC*TA(J+2)+YD*TA(J+1)+YE*TA(J)
      ENDDO
C
      DO J = NGRID-2,2,-1
        TB(J) = WKS*TB(J+2)+TC(J)
      ENDDO
C
C   complete inward integration with Simpson's rule for first point
C
      TB(1) = WKS*TB(3)+WA*TA(4)+WB*TA(3)+WC*TA(2)
C
      END
C
C                             *******************
C
      SUBROUTINE ZEFR(J,R,ZE)
C
C-----------------------------------------------------------------------
C
C   This subroutine calculates an effective charge ZE such
C   that in a coulomb field of charge ZE the mean radius
C   <R> of orbital J is equal to the input value R .
C      Find ZE such that   <R>-R=0
C   The Newton method is used with accuracy EPS6 and maximum
C   number of iterations ITR .
c
c   Fix for L-spinors           -        nrb 09/01/08
c
C
C   No subroutines called.
C
C-----------------------------------------------------------------------
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      IMPLICIT NONE
      INCLUDE 'grasp0.inc'
C
C  Parameter variables
C
      DOUBLE PRECISION EPS5
      PARAMETER (EPS5=1.D-5)
      DOUBLE PRECISION EPS6
      PARAMETER (EPS6=1.D-6)
      INTEGER ITR
      PARAMETER (ITR=30)
C
C  Argument variables
C
      DOUBLE PRECISION R,ZE
      INTEGER J
C
C  Local variables
C
      DOUBLE PRECISION A(3),B(3),BN,FK
      DOUBLE PRECISION FKS,FNR,WA,WB
      INTEGER I,II,K,L
      INTEGER MK,NN,NNS
C
C  Common variables
C
      DOUBLE PRECISION ACCY,C,EPH,H
      DOUBLE PRECISION RNT,Z
      INTEGER N,NCPRIN,NW1
      COMMON / DEF01  / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN
C
C  Common variables
C
      INTEGER IPUNCH,IREAD,IWRITE
      COMMON / INFORM / IREAD,IWRITE,IPUNCH
C
C  Common variables
C
      CHARACTER*2 NH(MXNW)
      COMMON / ORB00  / NH
C
C  Common variables
C
      INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF
      INTEGER NP(MXNW),NW
      COMMON / ORB04  / NW,NCF,NP,NAK,IQ
C
C  Common variables
C
      INTEGER NKJ(MXNW),NKL(MXNW)
      COMMON / ORB05  / NKL,NKJ
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C-----------------------------------------------------------------------
      NN = NP(J)
      K = NAK(J)
      L = NKL(J)
      MK = ABS(K)
      NNS = NN*NN
C
C  Initial estimate using non-relativistic formula.
C
      A(3) = DBLE(NNS+NNS+NNS-L*(L+1))/(R+R)
      FK = DBLE(K)
      FKS = FK*FK
      FNR = DBLE(NN-MK)
C
C  Begin iterations on the relativistic formula.
C
      I = 1
   10 CONTINUE
      A(1) = A(3)-EPS5
      A(2) = A(3)+EPS5
      DO II = 1,3
        WA = A(II)/C
        WA = WA*WA
        if(fks-wa.lt.0)go to 50                !catch L-spinors
        WB = SQRT(FKS-WA)+FNR
        WA = WB*WB+WA
        if(wa.lt.0)go to 50                    !catch L-spinors
        BN = SQRT(WA)
        WA = WB*(WA+WA+WA-FKS)-BN*FK
        WB = A(II)*BN
        B(II) = WA/(WB+WB)-R
      ENDDO
      WB = A(3)
      WA = EPS5*B(3)/(B(2)-B(1))
      A(3) = A(3)-(WA+WA)
      IF (ABS(A(3)-WB)-EPS6) 40,40,20
   20 CONTINUE
      I = I+1
      IF (I-ITR) 10,10,30
   30 CONTINUE
      WRITE (IWRITE,3000) NP(J),NH(J)
C
   40 CONTINUE
      ZE = A(3)
c
      return
c
   50 ze=z
      return
C
 3000 FORMAT (' WARNING in ZEFR : iteration limit exceeded for ',I2,A2)
      END