cFOR,IS         ,ELP*PROGFIL.STSTRUCTURE
cO    OVERLAY(SSTRUCT,0,0)                                              CRA79OCT
cO    PROGRAM STRUCT(INPUT,OUTPUT,PUNCH,RSFILE,TAPE5=INPUT,TAPE6=OUTPUT,UCL77JAN
cO   C TAPE7=PUNCH,TAPE10=RSFILE)
C     S U P E R S T R U C T U R E  1974-EISSNER/JONES/NUSSBAUMER/STOREY.
C
cC    COMMON MAXGR,NF,GAP(8),COMSS(&MXD08)  /DXRL/ QLMZ(&MXD01)         UCL76SEP
cC   C  /COEFF/ QUMC(&MXD03)  /JSPOR/ JSP(&MXD04)  /CCLSH/ NLQ(&MXD05)
cC   C  /DBD2/ WEY(&MXD09),QKY(&MXD06)  /TERMS/ QDMT(&MXD07)
cC   C  /MQVC/ WORDS(5),NEL(15, 60)  /OUTP/ WDS(6)
C     SR ZERO PRINTS DIMENSIONS FOR THIS RUN
      CALL ZERO
C
C     EACH OF THE FOLLOWING TWO SR'S CALLED BY MAIN READS DATA INPUT
C     OVERLAY STRUCTURE, BARE MINIMUM AS ON CDC ...
C     IN THE ROOT, (,0,0)  MAIN, JACORD,ROTSYM /TERMS,DBD2,DXRL,CCLSH,
   80 CALL ALGEB
C     OVERLAY(,1,0)  ALGEB /ALGCOM+,QTG,OUTP/
C      OVERLAY(,1,1)  ALG1+ALGEB1, VCU,VCE, FIND,DISKDC /COMOSC/
C      OVERLAY(,1,2)  ALG2+ALGEB2, FLGLH /CFCT,NXRL/
C      OVERLAY(,1,3)  ALG3+ALGEB3, SPOR,RES /COMRES/
      CALL MINIM
C     OVERLAY(,2,0)  MINIM, VA04A,CALCFX,YLAMK,WEDDLE /GENINF,RADF,CADJ,
C                      ARDIAG,WEIGHT,OUTP/ -- DIFF /EX,REL,TRANS/
C      OVERLAY(,2,1)  RADIAL, RADWIN, TFDAPO,RK1ST, RADWAV,NUMERO,WHITEX
C                        GAMMA
C       BRANCH TFDAPO-RADWAV-RADWIN ON MACHINES ALLOWING TERTIARY LEVEL.
C      OVERLAY(,2,2)  DIAGON
C      OVERLAY(,2,3) -- SOCC, RAD
C      OVERLAY(,2,4) -- DIAGFS, SJS
C      OVERLAY(,2,5) -- CASC
      GO TO 80
      END
      SUBROUTINE JACORD(N,EIVEC,A,V,MAXMAT)
C
C     -- CALCULATES EIGENVALUES AND EIGENVECTORS OF A REAL SYMMETRICAL
C     MATRIX A WITH THE METHOD OF JACOBI.
C   N=ORDER OF THE MATRIX A
C   EIVEC=.TRUE.EIGENVECTORS WANTED,=.FALSE.NO EIGENVECTORS WANTED.
C   RESULTS.
C   V(I,K),I=1,N EIGENVECTORS TO A(K,K)=EIGENVALUE.
C   THE ORIGINAL A IS DESTROYED. THE EIGENVALUES WILL BE ORDERED-
C   A(K,K).GT.A(I,I) FOR K.LT.I BUT IF N.LT.0 NO REORDERING TAKES PLACE,
C   IN THAT CASE N=-N AT THE BEGINNING
C
C   JACORD AND ROTSYM ARE BASED ON ALGOL PROCEDURES WRITTEN BY
C   RUTISHAUSER AT THE ETH (ZURICH, SWITZERLAND). FOR AN IMPROVED
C   VERSION SEE  RUTISHAUSER,NUMER.MATH.9(1966)1-10.
C
cS    IMPLICIT INTEGER*2 (I-L,N)
      DOUBLE PRECISION  SS,T,C,S,THETA, A,V, AKK,AKL,ALL, SS0
      PARAMETER(TOL0=1.E-30,TOL1=3.16E29,STOL=1.E20,TRESH=0.)
      LOGICAL EIVEC,BNOGT
      DIMENSION A(MAXMAT,MAXMAT),V(MAXMAT,MAXMAT)
      BNOGT = N.LT.0
      IF(BNOGT) N=-N
      IF(.NOT.EIVEC) GO TO 2
      DO 10 K=1,N
      DO 1 L=1,N
    1 V(K,L)=0.
   10 V(K,K)=1.
    2 IF(N.EQ.1) GO TO 9
CP    STOL=1.E+11
CQ    STOL=1.E+5
      SS0=0.
      N0 = N + 99
      DO 8 I=1,N0
C
      SS=0.
      DO 3 K=1,N-1
      DO 3 L= K+1,N
      AKL = A(K,L)
C   AVOID IBM-360/65 UNDERFLOW MESSAGES
      IF (ABS(AKL).LT.TOL0)  AKL = 0.0
    3 SS = AKL*AKL + SS
C
      DO 7 K=1,N-1
      DO 7 L=K+1,N
      AKK = A(K,K)
      ALL = A(L,L)
      AKL = A(K,L)
C   AVOID IBM-360/65  UNDERFLOW MESSAGES
      IF (ABS(AKL).LT.1.E-20)  AKL = 0.0
      T = ABS(AKL)*STOL
      IF (T.NE.0.0 .AND. (ABS(AKK).LE.T .OR.  ABS(ALL).LE.T)) GO TO 4   UCL78JUN
      AKL = 0.0
C
C   IF NO REORDERING REQUIRED THEN JUMP
      IF(BNOGT) GO TO 4
C
C   IF IN PROPER ORDER THEN JUMP
cP    IF ((ALL-AKK)*STOL.LT.1.+AKK)  GO TO 4
      IF (ALL-AKK.LT.(1.+AKK)*1.E8*TOL0)  GO TO 4
      C=0.
      S=1.0
      GO TO 6
    4 IF (ABS(AKL).LE.TRESH)  GO TO 7
      THETA = (ALL-AKK)/(2*AKL)
      IF (ABS(THETA).LT.TOL1)  GO TO 5
      S=1/(2*THETA)
      C=1.
      GO TO 6
    5 T= ABS(THETA)+ SQRT(THETA*THETA+1.)
      IF(THETA.LE.0.) T=-T
      T=1/T
      C=1./SQRT(T*T+1.)
      S=T*C
    6 A(K,L) = AKL
      CALL ROTSYM(N,N,EIVEC,C,S,K,L,A,V,MAXMAT)
      A(K,L)=0.
    7 CONTINUE
C     IF(SS.LE.1.E-35) GO TO 9
      IF(SS.EQ.0.) GO TO 9
      IF(SS.NE.SS0) GO TO 11
       NN0=NN0-1
       IF(NN0.GT.0) GO TO 8
C      IF(SS.LE.1.E-37) GO TO 9 -- RUB'96MAY20:
       IF(SS.LE.1.E-15) GO TO 9
       WRITE(6,'(37H ITERATING JACORD RETURNS CONST. SS =,1P,E9.1)') SS
       GO TO 9
   11 SS0=SS
      NN0=4
    8 CONTINUE
      WRITE(6,'(/37H ITERATIONS IN JACORD EXHAUSTED, SS =,1P,E9.1/)') SS
    9 RETURN
      END
      SUBROUTINE ROTSYM(N,NP,EIVEC,C,S,IP,IQ,A,V,MAXMAT)
C
C   EXECUTES A JACOBI ROTATION IN THE ROW IP AND THE COLUMN IQ OF A AND
C   V. C,S=COSINES,SINES OF THE ROTATION. THE RESULTS ARE AGAIN IN A AND
C   V. N,NP=ACTUAL DIMENSIONS OF A AND V,A(I,J),I=1,NP,J=1,N. EIVEC SEE
C   JACORD.
C
cS    IMPLICIT INTEGER*2 (I-L,N)
      LOGICAL EIVEC
      DIMENSION A(MAXMAT,MAXMAT),V(MAXMAT,MAXMAT)
      DOUBLE PRECISION H,C,S,G, A,V
      H=C*C*A(IP,IP) - 2*C*S*A(IP,IQ) + S*S*A(IQ,IQ)
      G=S*S*A(IP,IP) + 2*C*S*A(IP,IQ) + C*C*A(IQ,IQ)
      A(IP,IQ)=C*S*(A(IP,IP)-A(IQ,IQ)) + A(IP,IQ)*(C*C-S*S)
      A(IP,IP)=H
      A(IQ,IQ)=G
      I1=IP-1
      IF(I1.EQ.0) GO TO 11
      DO 1  J=1,I1
      H=C*A(J,IP) - S*A(J,IQ)
      A(J,IQ)=S*A(J,IP) + C*A(J,IQ)
    1 A(J,IP)=H
   11 I1=IP + 1
      K1=IQ - 1
      IF(I1.GT.K1) GO TO 12
      DO 2  J=I1,K1
      H=C*A(IP,J) - S*A(J,IQ)
      A(J,IQ)=S*A(IP,J) + C*A(J,IQ)
    2 A(IP,J)=H
   12 K1=IQ + 1
      IF(K1.GT.N) GO TO 13
      DO 3  J=K1,N
      H=C*A(IP,J) - S*A(IQ,J)
      A(IQ,J)=S*A(IP,J) + C*A(IQ,J)
    3 A(IP,J)=H
   13 IF(.NOT.EIVEC) GO TO 5                                            UCL78JUN
      DO 4 J=1,NP
      H=C*V(J,IP) - S*V(J,IQ)
      V(J,IQ)=S*V(J,IP) + C*V(J,IQ)
    4 V(J,IP)=H
    5 RETURN
      END
cP    REAL FUNCTION VCC (J1,J2,J,M1,M2,M,FCT,N)
      DOUBLE PRECISION FUNCTION VCC (J1,J2,J,M1,M2,M,FCT,N)
C     NORDITA1966 F.P.L.3, WITH MODIFICATIONS UCL'71FEB19,DL'82JUL28W.E.
C     THE SIX QUANTUM NUMBER ARGUMENTS HAVE TWICE THEIR PHYSICAL VALUE;
C     FACTORIALS MUST BE SUPPLIED BY FCT(I)=(I/2-1)!/16**(I/2-1),I=4,N,2FCT82JUL
C     (FCT(2)=0!=1), AND PHASE FACTORS BY FCT(I)=MOD(I+1,4)-1,I=1,N,2.
      DOUBLE PRECISION FCT, CC
      INTEGER Z,ZMIN,ZMAX
      DIMENSION FCT(N)
      EQUIVALENCE (ZMIN,JG),(ZMAX,JH),(Z,JI)                            79/10/31
      CC = 0.0
      IF (M1+M2.NE.M)  GO TO 1
      IF(ABS(M1).GT.J1) GO TO 1
      IF(ABS(M2).GT.J2) GO TO 1
      IF(ABS(M).GT.J) GO TO 1
      IF(J.LT.ABS(J1-J2)) GO TO 1
      K0 = J1+J2-J + 2
      IF (K0.LE.0) GO TO 1
      JB = K0 + 2
      JJ = JB+J+J
      IF(JJ.GT.N) GO TO 4
C     IF(FCT(4)*16.NE.1) GO TO 4 ! 1/16-TEST
      ZMIN = 0
      K4 = J-J2+M1
      IF (K4.LT.0)  ZMIN = -K4
      K3 = J-J1-M2
      IF (K3+ZMIN.LT.0)  ZMIN = -K3
      ZMAX = K0
      K2 = J2+M2 + 2
      IF (K2.LT.ZMAX)  ZMAX = K2
      K1 = J1-M1 + 2
      IF (K1.LT.ZMAX)  ZMAX = K1
      JC = K1 + 2
      JD = K2 + 2
      ZMIN = ZMIN + 2
      DO 2 Z=ZMIN,ZMAX,2
    2  CC = FCT(Z-1)/(FCT(Z)*FCT(JB-Z)*FCT(Z+K3)*FCT(JC-Z)*
     *                                 FCT(Z+K4)*FCT(JD-Z)) + CC
      JB = K4 + K1
      JC = K3 + K2
C     JB=(J+J1-J2)+2, JH=(J+M1+M2)+2, JD=(J1+M1)+2; K1=(J1-M1)+2
C     JC=(J-J1+J2)+2, JI=(J-M1-M2)+2, JG=(J2-M2)+2; K2=(J2+M2)+2           82JUL
      JD = K4 + K0
      JG = K0 + K3
      JH = K2 + K4
      JI = K1 + K3
      CC =  SQRT(( REAL(J+1)*FCT(K0)*FCT(JB)*FCT(JC)/(FCT(JJ)*16  )) *
     *            FCT(K1)*FCT(JG)*FCT(JH)*FCT(JI)*FCT(JD)*FCT(K2)) * CC FCT82JUL
    1 VCC = CC
      RETURN
    3 FORMAT(36H FCT.VCC: FACTORIAL ARRAY TOO SHORT,,I4,6H.GT.N=,I3)    82/07/30
    4 PRINT 3, JJ,N
      STOP
      END
      SUBROUTINE ZERO
      CHARACTER  KNAM(36)*5, KOF*3
      DOUBLE PRECISION  TOL,EPS,NIL,ONE,TWO,H,T, DFS
      PARAMETER (NIL=0.,ONE=1.,TWO=2.)
      DIMENSION  KDIM(36)
      COMMON /COMFAC/ DFS( 64),MT
cZ    COMMON /NAGPAR/ TOL,EPS,MFAIL
      DATA KNAM( 1),KNAM( 2),KNAM( 3)    /'MAXCF','MAXGR','MAXCL'/
      DATA KNAM( 4),KNAM( 5),KNAM( 6)    /'MXEL0','MAXSL','MAXJG'/
      DATA KNAM( 7),KNAM( 8),KNAM( 9)    /'MAXTM','MAXCT','MAXLV'/
      DATA KNAM(10),KNAM(11),KNAM(12)    /'MAXAD','MXADJ','MXEST'/
      DATA KNAM(13),KNAM(14),KNAM(15)    /'MXST0','MAXDC','MAXUC'/
      DATA KNAM(16),KNAM(17),KNAM(18)    /'MAXJU','MAXRK','MAXRL'/
      DATA KNAM(19),KNAM(20),KNAM(21)    /'MAXMI','MXRSS','MXSOI'/
      DATA KNAM(22),KNAM(23),KNAM(24)    /'MXSOC','MAXLL','MAXDF'/
      DATA KNAM(25),KNAM(26),KNAM(27)    /'MAXDI','MAXDK','MAXB1'/
      DATA KNAM(28),KNAM(29),KNAM(30)    /'MAXB2','MXVAR','MXNOR'/
      DATA KNAM(31),KNAM(32),KNAM(33)    /'MAXTR','MAXCA','LPNCH'/
      DATA KNAM(34),KNAM(35),KNAM(36)    /'MXD30','MAXBO','LAMAX'/
      DATA KOF/'OFF'/
      DATA KDIM( 1),KDIM( 2),KDIM( 3)    / 60,15,78/
      DATA KDIM( 4),KDIM( 5),KDIM( 6)    /54, 60,  38/
      DATA KDIM( 7),KDIM( 8),KDIM( 9)    /1225,1725,3100/
      DATA KDIM(10),KDIM(11),KDIM(12)    / 61500,523000, 200000/
      DATA KDIM(13),KDIM(14),KDIM(15)    / 19000,1750000, 97000/
      DATA KDIM(16),KDIM(17),KDIM(18)    /700000, 513000, 11000/
      DATA KDIM(19),KDIM(20),KDIM(21)    / 5000,500000,5500/
      DATA KDIM(22),KDIM(23),KDIM(24)    / 550000,4, 450/
      DATA KDIM(25),KDIM(26),KDIM(27)    /290,572, 999/
      DATA KDIM(28),KDIM(29),KDIM(30)    / 999,15,-0/
      DATA KDIM(31),KDIM(32),KDIM(33)    / 10633,   450,7/
      DATA KDIM(34),KDIM(35),KDIM(36)    / 64,130,3/
 1000 FORMAT(/82H THIS VERSION OF SUPERSTRUCTURE IS COMPILED WITH THE FO
     *LLOWING STORAGE PARAMETERS://4(6X,4HNAME,4X,5HVALUE,10X)//
     *       4(5X,A5,1X,I8,10X))
  999 FORMAT(/5X,19HPRECISION IS DOUBLE, 10X,11HRESTART IS ,A3,
cP999 FORMAT(/5X,19HPRECISION IS SINGLE, 10X,11HRESTART IS ,A3,
     C 10X,48HJACORD USED FOR DIAGONALIZATION OF S**2 AND L**2/
cY   C 10X,48HNAGLIB USED FOR DIAGONALIZATION OF S**2 AND L**2/
cZ   C 10X,48HNAGMK4 USED FOR DIAGONALIZATION OF S**2 AND L**2/
     C 18X,6(1H*),21X,3H***,10X,6(1H*)/
     C 5X,'I.E. EPS = 2**',I5.4/10X,'TOL = 2**',I5.4)
C
      L = 0
      T = ONE
   10  T=T/TWO
       L=L-1
       H=ONE+T
       IF(H.LE.ONE) GO TO 20
       EPS = T
       K = L
       GO TO 10
   20  IF(T.LE.NIL) GO TO 30
       TOL = T
       GO TO 10
   30 L = L+1
C     print *, ' EPS,TOL = ', eps,tol !,T
C
      PRINT 1000, (KNAM(I),KDIM(I),I=1,36)
      KOF = ' ON'
      PRINT 999,  KOF, K,L
C
      DFS(1) = 1
      DFS(2) = 1
      DO 40 I=3, 64,2
       DFS(I) = -DFS(I-2)
   40  DFS(I+1) = (I-1)*DFS(I-1)/32 ! 32 in '82JUL
      RETURN
      END
      SUBROUTINE  ALGEB
C
C     -- READS CONFIGURATION INPUT AND CONTROLS THE ALGEBRAIC BRANCH.
C     NOTE: ANGULAR QUANTUM NUMBERS WILL BE INTERNALLY STORED AS TWICE
C      THEIR VALUE; THIS ALLOWS FOR INTEGER NOTATION AND MEETS THE
C      REQUIREMENTS OF THE COPENHAGEN PACKAGE OF ANGULAR SUBROUTINES.
C
cM    IMPLICIT INTEGER*2 (Q)
cS   C        ,INTEGER*2 (I-L,N)
      IMPLICIT INTEGER (Q)
cS    INTEGER  KUTSS
      DOUBLE PRECISION  DC,DY,DEF, MLIT0,MLIT
      LOGICAL LSTART
cP    PARAMETER (MXD99= 513000)
      PARAMETER (MXD99= 513000*2)
cM    PARAMETER (MXD00=( 513000+MXD99+1)*2
cS   *        - 513000-1
cM   * , MXD07= 60*5+1225*6+ 61500*2+6
cS   *        - 60  -1225*3- 61500  -3
cM   * , MXD12=(523000+ 550000+5500+1)*2
cS   *         -523000- 550000-1 
cM   * , MXD11= 60*3+1725*5+4
cS   *        - 60  -1725  -2
cM   * , MXD10= 5000*5+523000+500000+4)
      PARAMETER (MXD07= 60*4+1225*3+ 61500+3,
     *   MXD12=5500*2+523000+ 550000+1, MXD00= 513000+MXD99+1,
     *   MXD11= 60*2+1725*4+2, MXD10= 5000*5+523000+500000+4)
      PARAMETER (MXD04=3100*3+  38+1,MXD06=54* 60+15*2,
C    *   MXD01=MAX( 11000*5+MXD00, 200000)) -- SIMULATING MAX(MXD1,MXD2):
     *   MXD1= 11000*5+MXD00, MXD2= 200000,  MXD05=78*3+1)
      PARAMETER (MXT1=MXD1/MXD2,MXT2=MXD2/MXD1,MXT0=MXD1/MXD2+MXD2/MXD1)
      PARAMETER (MXD01=MXD1*MXT1/MXT0+MXD2*MXT2/MXT0)
      DIMENSION    MLIT0(2), QBMS( 19000), QLMS( 200000), JYI( 60)
     C , DC(1750000),MLIT(2), QBML( 19000), QLMC( 200000), JYF( 60)
      COMMON /OUTP/MPRINT,KUTSS,QCUT,
cM   *   QDUM,
     *   KDUM,LCE1,LCE2 //MAXGR,NF,KX,KG,K1,K2
     C   ,KUM(3),MGAP, DCS(500000),QCS(MXD10)  /JSPOR/ JSP(MXD04)
     C  /COEFF/ DEF( 550000),QEF(MXD12)  /CCLSH/ NLQ(MXD05)
     *  /DXRL/ QLMZ(MXD01)  /QTG/ MTGD,QTG(MXD11)
     C  /MQVC/ MAXDC, MODE,KCUT,QCL0,QCS0,NEL(15, 60)
     C  /DBD2/ DY(15),QKY(MXD06)   /TERMS/ QDMT(MXD07)
CDISK COMMON /COMDSK/IFI,IFREE
      EQUIVALENCE (DC(1),MLIT0(1))
     *     ,    (QLMZ(1),QLMS(1))
      DATA  MXEL0,MXST0,MXEST/54, 19000, 200000/, QPLUS,QCT0/1H+,1H?/
     *     ,   MR/10/
      MAXDC=1750000
      KH = 0
C
C     IN IF-LOOP 96 CARDS ARE READ UNTIL A TERMINATOR IS FOUND
C     (A CARD THAT IS BLANK IN T10,I2 IS REFERRED TO AS A C-TERMINATOR).
  96  KG = KH
  94  I = KH+21
      IF (I.GT.MXST0)  GO TO 99
      KF = KH + 1
      KH = I
  99  READ 50, MSTRT0, IFREE, QCS0,QCL0, (QBMS(I),QBML(I),I=KF,KH), MLIT
C     A TERMINATOR AS FIRST CONFIGURATION CARD CANCELS THE JOB
      IF (QBMS(1).EQ.0)  STOP
C     OTHERWISE (T10,21(I2,Z1)) EXCEPT ON THE TERMINATOR ARE READ AS A
C     STRING OF Q=MOD(C(I2),50) EQUIVALENT ELECTRONS NL=FUNCTION(C(Z1));
C     Q+50 STANDS FOR: THESE Q ELECTRONS FORM A CONFIGURATION TOGETHER
C     WITH WHAT STANDS LEFT OF IT.
C     EXAMPLE: ' 22523 12533' IN COLUMNS 10..21 WILL BE INTERPRETED (IN
C     SR ALGEB1) AS TWO CONFIGURATIONS, 2S**2+2P**2 AND 2S+2P**3,
C     PROVIDED THE TERMINATOR IS BLANK IN COLUMNS 16..60; THEN K=C(Z1) =
C     1,2,3,..9,A,..F STANDS FOR 1S,2S,2P,..4D,4F,..5G.
C     THE STRING MAY BE BROKEN BY A MULTIPLE OF THREE GAPS AFTER ANY
C     CONFIGURATION, BUT ON THE NEXT CARD IT MUST CONTINUE IN T10,I2,Z1.
      IF (KF.NE.1)  GO TO 98
      MPRINT = MSTRT0
      MODE = IFREE
      MLIT0(1) = MLIT(1)
      MLIT0(2) = MLIT(2)
      K1 = QCS0
      K2 = QCL0
C     ON THE SECOND AND FOLLOWING RECORDS COLUMNS 1..9 AND 73..80 ARE
C     IGNORED; THE LAST 8 COLUMNS OF THE FIRST CARD ARE PRINTED AT THE
C     BEGINNING OF THE HEADLINE (AS LITERAL DATA); C(T1,I2)=BLANK SUP-
C     PRESSES PRINTOUT OF SLATER STATES AND OF ALL ANGULAR COEFFICIENTS.
C     C(T3,I2)=MODE IS INPUT TO SR VCU OR DISKDC AND IS DESCRIBED BELOW;
C     FOR THE PROBLEMS DEALT WITH HERE MODE=-1 SUFFICES.
C     C(T5,I2)=K1 AND C(T7,I2)=K2 WILL BE INTERPRETED AS FOLLWS: K1..K2
C     FORM A CORE CONFIGURATION C0 OF CLOSED SUBSHELLS COMMON TO ALL
C     CONFIGURATIONS LISTED IN THE STRING BEHIND (AN ORBITAL (N,L)
C     SPECIFIED IN BOTH PLACES WILL BE IGNORED IN THE LATTER).
  98  IF (QBMS(KF).NE.0)  GO TO 96
C     COLUMNS 16..69 OF THE TERMINATOR ALLOW FOR REDEFINING K=1,2,3..18:
C     IF THE K'TH (I2,I1) IS NOT BLANK  NK=C(I2) + LK=C(I1) (IN ALGEB1).
C     IF IFREE.LE.0 SR DISKDC WILL BE SKIPPED (IN SR ALGEB1)
C     (SR DISKDC READS SLATER STATES AND VCC'S FROM A LIBRARY SET).
C-DSK ALTERNATIVELY IFREE COULD SERVE TO SPECIFY INDIVIDUAL RESTARTFILES
      IF (IFREE.GT.0)  MR = IFREE    ! UCL76SEP
C
      QCUT = QBML(KH)
      IF (QCUT.EQ.QPLUS) GO TO 94
      KUTSS=QBMS(KH)
      KCUT = QBMS(KG+2)
      LCE1 = 0
      LCE2 = 0
      IF (ABS(MODE).LT.3) THEN
       LCE1 = QCS0
       LCE2 = QCL0
       QCS0 = 0
       QCL0 = 0
      ENDIF
C
C     DECODE NUMBER OF VALENCE ELECTRONS FROM FIRST CONFIGURATION,
C     MAKE BEST USE OF ARRAYS QLMC,QLMS(MAXEL,MAXST) (OPTIMIZE MAXST)
      MAXEL = QBMS(1)
      DO 97  I=2,KG
       IF (QBMS(I).LE.50)  GO TO 95
  97   MAXEL = QBMS(I)-50 + MAXEL
  95  MAXST = MXEST/MAXEL
      LSTART = MSTRT0.EQ.0 .OR. MPRINT.LT.-5
      IF (LSTART)  GO TO 71
  60  REWIND MR                      ! UCL75MAY
      MSTART = MOD(ABS(MSTRT0),5)    ! I/O10IBM
      IF (MSTART.GT.1)  GO TO 73
  71  MSTART = 1
C MVD PRINT '(//1X,2A4,4X,9HATOM WITH,5X,I2,10H ELECTRONS)', MLIT0,MAXEL
      IF (MAXEL.LE.MXEL0)  GO TO 91
      PRINT 199,  MXEL0,MAXEL
      MODE = -10
  91  IF (KG.LT.KH)  GO TO 92
      PRINT 195,  MXST0
      MODE = -10
  92  IF (MAXST.GT.MXST0)  MAXST = MXST0
      CALL ALGEB1(DC,QLMC,QLMS,QBML,QBMS,JYI,JYF, MAXST,MAXEL)
      IF (NF.LE.0)  GO TO 79
      IF (LSTART)  GO TO 75
      WRITE (MR)  MLIT,MAXGR,NF,MAXDC,MODE,KCUT,QCL0,QCS0,NEL,NLQ,QKY,DY
  72  WRITE (MR)  QLMZ
      WRITE (MR)  DC,MAXST,MAXEL,JYI,JYF,QBML,QBMS,QLMC, QTG
  76  PRINT 80, MLIT ,MSTRT0
      IF (ABS(MSTRT0).GE.5)  STOP
      MSTRT0 = MSTRT0 + MSTRT0/MSTART
      IF (MSTRT0.LT.0)  GO TO 60
      IF (MSTART-2)  75,77,79
  73  READ (MR) MLIT ,MAXGR,NF,MAXDC,MODE,KCUT,QCL0,QCS0,NEL,NLQ,QKY,DY
      PRINT 70, MLIT ,MSTART
      IF (MSTART.EQ.2)  GO TO 74                                        UCL766EB
      READ (MR)  QDMT
  74  READ (MR)  QLMZ
      IF (MSTART.GT.3)  GO TO 78
      READ (MR)  DC,MAXST,MAXEL,JYI,JYF,QBML,QBMS,QLMC, QTG
      IF (MSTART.GT.2)  GO TO 77
  75  MSTART = 2
      CALL ALGEB2(DC,QLMC,QLMS,QBML,QBMS,JYI,JYF, MAXST,MAXEL)
      IF (NF.LE.0)  GO TO 79
      IF (LSTART)  GO TO 77
      BACKSPACE MR
      BACKSPACE MR
      WRITE (MR)  QDMT
      GO TO 72
  77  MSTART = 3
      CALL ALGEB3(DC,QLMC,QBML,QBMS,JYI,JYF,MAXST,MAXEL)
      CALL ALGEB4(DC,QLMC,QBML,QBMS,JYI,JYF,MAXST,MAXEL)
      IF (JSP(1).LT.0) GO TO 79
      QCL0 = KUTSS
      QCS0 = QCUT
      IF (LSTART)  GO TO 79
      IF (JSP(1).LT.0)  GO TO 79                                        UCL75JUL
      BACKSPACE MR
      WRITE (MR)  JSP, DEF,QEF, DCS,QCS
      GO TO 76
  78  READ (MR)  JSP, DEF,QEF, DCS,QCS
      QCS0 = QCT0
      QCL0 = 999
  79  IF (MPRINT.GT.-7)  GO TO 90
      PRINT 190, MPRINT
      IF (MPRINT.EQ.-7)  GO TO 93
      IF (NF.LE.0)  STOP
C     I.E. LEVEL MPRINT.LT.-7
  93  NF = 0
  90  RETURN
C     COMMENT TO SR VCU AND DISKDC (CALLED IN SR ALGEB1)
C   MODE.EQ.0: ALL VCC FOR ALL COMPLETE TERMS I OF CONFG CF TO BE STORED
C                 PROVIDED KCUT=CFMAX (RATHER THAN =0) IS SPECIFIED
C   MODE.EQ.1: ONLY VCC FOR SLATERSTATES WITH |ML+MS|=MIN OF ALL TERMS I
C   MODE.EQ.2: ONLY VCC FOR SLATERSTATES WITH ML=0,|MS|=MIN OF ALL TERMS
C   MODE.EQ.-1,M-.EQ.-2 EQUIV +1,2 FOR ML,MS.LT.0, BUT ALL -,-.GT.0 KEPT
C    .GE.3: ONLY SLSTATES AND VCC WITH ML=L,MS=S OF TERM 2S=QCS0,2L=QCL0
C
CZ 50 FORMAT(2I2, 2I2, 1X, 21(I2,Z1), 2A4)
C     NOTE: WHEN USING A COMPILER THAT DOES NOT ALLOW FOR HEXADECIMAL
C     INPUT Z  ONE MAY READ A1 INSTEAD AND DECODE IN SR ALGEB1 LOOP 36
   50 FORMAT     (4I2, 1X, 21(I2,A1), 2A4)
   70 FORMAT(//15H RESTART FILE ',2A4,24H' READ BACK WITH MSTART=,I2//)
   80 FORMAT(/32H SR.ALGEB CREATES RESTART FILE ',2A4,10H', MSTART=,I2/)
  190 FORMAT(/' THIS WAS NO MORE THAN A DIMENSION CHECK -- MPRINT=',I2/)
  195 FORMAT(/85H SR.ALGEB: YOU ARE TRYING TO READ MORE CONFIGURATION IN
     1PUT THAN THE BUFFER CAN HOLD -/11X,54HAS BUFFER THE PROGRAM USES T
     2HE ARRAYS OF SIZE  *MXST0=,I4,1H./11X,54HEACH C CARD, AND THE TERM
     3INATOR, REQUIRE 21 LOCATIONS./11X,70HCASE SKIPPED. PUNCH MORE CONF
     4IGURATIONS ON A CARD, OR AUGMENT  *MXST0.)
  199 FORMAT(27H SR.ALGEB: STORAGE FOR ONLY,I3,42H ELECTRONS PROVIDED --
     C AUGMENT  * MXEL0 TO,I3)
      END
      SUBROUTINE  ALGEB1( DC,QLML,QLMS,QBML,QBMS,JYI,JYF, MAXST,MAXEL )
C
C     -- DEALS WITH THE PROBLEMS DESCRIBED IN SECTION 3.1 OF E+N
C     IT CALCULATES SLATER-STATES AND VECTOR COUPLING COEFFICIENTS (VCC)
C     FOR THE KM INPUT CONFIGURATIONS FROM THE CODED INPUT IN QBML+QBMS
C
cM    IMPLICIT INTEGER*2 (L,Q)
cS   C        ,INTEGER*2 (I-K,N)
      IMPLICIT INTEGER (Q)
      CHARACTER*8  DMT,DMU,DMN
      DOUBLE PRECISION DC, DU,DV,DS,DE,D2,DEY, EPS,TOL
      LOGICAL LG,LP, LF,LT
      PARAMETER (MXD13=78*3, MAXLL=4,
     *   MXD03 =  550000*(4
     *                   +2
     *                    )
     *                 /2-523000  -1
cS   *          - 550000  -523000  -1
     *          +5500*2+523000*2+2)
      DIMENSION QLMS(MAXEL,MAXST),QBMS(MAXST),QLP(15),DMN(12),DMU(7)
     1 , DMT(10),QLML(MAXEL,MAXST),QBML(MAXST),LIT0(10),LIT1(10),LIT(28)
     2 , DU( 450, 450),DS( 450),JYI( 60),LL(54),NDI( 450)
     3 , DV( 450, 450),DE( 450),JYF( 60),DC(1750000)
     4 , D2( 450, 450)
cY   4 , D2( 450)
cZ   4 , D2( 450)
      COMMON  MAXGR,NF,KF,KG,JA,JB
cS   C                            , JGAP
cT   C                                  ,DU
cU   C                                  ,D2
cZ   C /NAGPAR/ TOL,EPS,MFAIL
cV   C /COEFF/ QUMC(MXD03)
     C /DBD2/ DEY(15), QCG(54, 60),QL(15),QN(15)
     C /QTG/ MTGD,ND,NTG(0: 60),JTGD(1725), QCP( 60),
     C   QTGS(1725),QTGL(1725),QTGD(1725)
     C /MQVC/ MAXDC,MOD,KCUT,QMCL,QMCS,NEL(15, 60)
     * /OUTP/ MPRINT,MKUTS(2),NCUTS(3) /CCLSH/ NW,NNL(MXD13)
CDISK COMMON /COMDSK/IFI20,IFREE
      EQUIVALENCE  (LL(1),NDI(1)), (LIT0(2),LIT(1))
cV   *,(QUMC(1),DV(1,1))
      DATA DMT( 1),DMT( 2),DMT( 3) /'( /  I4,', '5H=CF 2,', '5HML 2M,'/,
     C     DMT( 4),DMT( 6),DMT( 7) /'5HS 2MJ,', '(I5,I3),', '   3X,  '/,
     C     DMT( 9),DMT(10)         /'(I3,I2, ', ' I3) / )'/
      DATA DMU( 1),DMU( 2),DMU( 4) /'(   I6, ', 'I5,2I4, ', '(I5,I3),'/,
     C     DMU( 5),DMU( 7)         /' 3X,    ', 'F8.4   )'/
      DATA DMN( 1),DMN( 2),DMN( 3) /'       1', '       2', '       3'/,
     C     DMN( 4),DMN( 5),DMN( 6) /'       4', '       5', '       6'/,
     C     DMN( 7),DMN( 8),DMN( 9) /'       7', '       8', '       9'/,
     C     DMN(10),DMN(11),DMN(12) /'      10', '      11', '      12'/
      DATA LIT1(1),LIT1(2),LIT1(3),LIT1(4),LIT1(5) /1HS,1HP,1HD,1HF,1HG/
     C    ,LIT1(6),LIT1(7),LIT1(8),LIT1(9),LIT1(10)/1HH,1HI,1HJ,1HK,1HL/
      DATA LIT0(1),LIT( 1),LIT( 2),LIT( 3),LIT( 4) /1H0,1H1,1H2,1H3,1H4/
     C   , LIT( 5),LIT( 6),LIT( 7),LIT( 8),LIT( 9) /1H5,1H6,1H7,1H8,1H9/
     C   , LIT(10),LIT(11),LIT(12),LIT(13),LIT(14) /1HA,1HB,1HC,1HD,1HE/
     C   , LIT(15),LIT(16),LIT(17),LIT(18),LIT(19) /1HF,1HG,1HH,1HI,1HJ/
     C   , LIT(20),LIT(21),LIT(22),LIT(23),LIT(24) /1HK,1HL,1HM,1HN,1HO/
     C   , LIT(25),LIT(26),LIT(27),LIT(28), MXLIT  /1HP,1HQ,1HR,1HS, 28/'87JUN11
      DATA MAXCF,MAXCL,MAXDF/ 60,78, 450/, LBLK/1H /,QPLUS/1H+/
cZ    MFAIL=0
      MAXGR=15
      IF (MAXGR.LE.MXLIT)  GO TO 87
      PRINT 88, MAXGR, MXLIT
      MAXGR=MXLIT
  87  LF = MOD.EQ.-10
C        = .TRUE. DIVERTS CONTROL TO NEAREST GO TO ERROR EXIT (LABEL 9)
C
C     DEFINE GROUP INDICES K=1,2,..MAXGR FOR NL=
C     1S,2S,2P...; K MAY HAVE BEEN REDEFINED THROUGH INPUT, SEE LOOP 31
C
      QLMAX = -1
      K = 0
      DO 33 I=1,10
       DO 33  L=1,I
        K = K + 1
        IF (K.GT.MAXGR)  GO TO 32
        DEY(K) = 0.0
        QN(K) = I
        QLP(K) = L-1
  33    QL(K) = (L-1)*2
  32  LT = .FALSE.
      DO 31 K=1,MAXGR
       L = (K-1)/18
       I = KG+K+2 + L*3
       IF (QBMS(I).EQ.0)  GO TO 31
       IF (K.GT.18 .AND. QBML(KG+L*21).NE.QPLUS)  GO TO 31              '87APR17
       QN(K) = QBMS(I)
       DO 26 M=1,10
        IF (QBML(I).NE.LIT0(M) .AND. QBML(I).NE.LIT1(M))  GO TO 26      '87APR18
        L = M-1
        GO TO 27
  26    CONTINUE
       GO TO 24
  27   QL(K) = 2*L
       QLP(K) = L
       LT = .TRUE.
       IF (QN(K).GT.L)  GO TO 31
  24   PRINT 93,  K, QN(K),QBML(I)
       LF = .TRUE.
  31   CONTINUE
C
C     DECODE INPUT ARRAYS QBML AND QBMS (ACCORDING TO GROUP DEFINITION)
C     OF KM CONFIGURATIONS, EACH CONFIGURATION KF DEFINED BY THE NUMBER
C     NEL(K,KF) OF EQUIVALENT ELECTRONS N,L=QN(K),QL(K)/2;
C     DECODE CLOSED SHELL CONFIGURATION C0 (OF NW ELECTRONS) COMMON TO
C     ALL KM CONFIGURATIONS (THIS FACILITY REDUCES STORAGE REQUIREMENTS)
C
      KM = 0
CW    LG = .FALSE.
      DO 36  I=1,KG
       IF (QBML(I).EQ.LBLK)  GO TO 36
       M = QBMS(I)
       DO 39  K=1,MAXGR
        IF (QBML(I).NE.LIT(K))  GO TO 39
        DEY(K) = 1.0
        IF (M.LE.50)  GO TO 38
         M = M-50
         IF (KM.GT.0)  GO TO 35                                         UCL76OCT
  38    NK = KM-1
C       DUPLICATE CONFIGURATIONS WILL BE DROPPED QUIETLY - OR FLAG CW
        IF (NK.LE.0)  GO TO 43
        DO 42 L=1,NK
         DO 41 J=1,MAXGR
          IF (NEL(J,L).NE.NEL(J,KM))  GO TO 42
  41      CONTINUE
         IF (KM.LE.KCUT)  KCUT = KCUT-1
CW       LG = .TRUE.
         GO TO 44
  42     CONTINUE
  43    KM = KM+1
        IF (KM.LE.MAXCF)  GO TO 44
        PRINT 92,  MAXCF
        LF = .TRUE.
        KM = KM-1
  44    QCP(KM) = 0
        DO 34 J=1,MAXGR
  34     NEL(J,KM) = 0
  35    IF (K.GE.JA.AND.K.LE.JB)  GO TO 36
        L = NEL(K,KM)+M
        NEL(K,KM) = L
        QCP(KM) = QCP(KM)+M
        IF (QL(K).GT.QLMAX) QLMAX=QL(K)
        IF (L.LE.(QL(K)+1)*2)  GO TO 36
        PRINT 97,  L, QN(K),QLP(K), KM
        LF = .TRUE.
        GO TO 36
  39    CONTINUE
       J = (I-1)/21+1
       L = (I-(J-1)*21)*3+9
       PRINT 89,  QBML(I),I,J,L, MAXGR
       LF = .TRUE.
  36   CONTINUE
      IF (LF)  GO TO 9
C
      NW = 0
      IF (JB.EQ.0) THEN
       PRINT 100, DC(1),DC(2), MAXEL, KM
      ELSE
       IF (JA.EQ.0)  JA = 1
       DO 84 J=JA,JB
        DEY(J) = 1.
        L = QL(J)
  82     I = NW + 1
         NW = I + 1
         IF (NW.LE.MAXCL)  GO TO 85
         PRINT 95, MAXCL
         GO TO 9
  85     DO 83  K=I,NW
          NNL(K) = J
          NNL(K+MAXCL) = L
  83      NNL(K+2*MAXCL) = (NW-K)*2 - 1
         L = L - 2
         IF ( L.GE.-QL(J) )  GO TO 82
        DO 84  I=1,MAXCF
  84     NEL(J,I) = - 2*(QL(J)+1)
       PRINT 40,  DC(1),DC(2), NW,MAXEL, KM, (QN(J),QLP(J),J=JA,JB)
      ENDIF
      DO 37 K=1,KM
       IF (QCP(K).EQ.MAXEL)  GO TO 37
       PRINT 94,   K,QCP(K)
       LF = .TRUE.
  37   CONTINUE
      IF (.NOT.LT)  GO TO 25
      PRINT 50,  (K,K=1,18), (QN(K),QLP(K),K=1,MAXGR)                   '87MAR22
      DO 29 K=1,MAXGR
       IF (DEY(K).EQ.0.0)  GO TO 29
       DO 28  I=1,K
        IF (I.EQ.K .OR. QN(K).NE.QN(I).OR.QL(K).NE.QL(I))  GO TO 28
        PRINT 91,  I,K, QN(I),QLP(I)
        LF = .TRUE.
  28    CONTINUE
  29   CONTINUE
  25  IF (LF)  GO TO 9
C
C     COMPUTE (BY VCU) OR READ FROM PERMANENT DISK SET (BY DISKDC)
C     SLATERSTATES (SLST) OF CONFIGURATIONS KF=1..KM, RESULTING TERMS SL ALGEB1
C     AND VECTOR COUPLING COEFFICIENTS (VCC); INPUT  NEL(K,KF)
C
C-NAG SET UP MACHINE-DEPENDENT CONSTANTS FOR NAG-SR'S (NEEDED IN SR.VCE)*NAGLIB*
CYMK4 EPS = X02AAF(MTGD) !- OUT ON XMP '92MAR10; BUT 92NOV10==>93SEP25
CZcjz EPS = 2.D0**(-52) --- perfect on Silicon Graphics
c         =  macheps, the smallest eps '1.+eps .gt. eps'
CDC   EPS = 1.E-14
CY    EPS = X02AJF()           -- OUT WITH MARK 18 '99OCT.
CYMK4 TOL = X02ADF(MTGD) !- ''
CZcjz TOL = 2.D0**(-220) --- 2**-1022 on SG - '02Jun8 coded in sr ZERO
CDC   TOL = 1.E-80
C
      IF (KCUT*KCUT.GE.KCUT*KM)  GO TO 22
      IF (MOD.NE.0)  GO TO 22
      MOD = -1
      PRINT 130
  22  MTGD = 0
C     JMCS = -1, JMCL = -1
      JB = 1
      NTG(0) = 0
      LP = MPRINT.GT.1
CW    IF(LG) PRINT MESSAGE THAT DUPLICATED CF'S HAVE BEEN DROPPED, KCUT.
      DO 12  KF=1,KM
      NT = NTG(KF-1)
      ND = MPRINT+6
      IF (KF.EQ.KCUT+1 .AND. KCUT.NE.0)  PRINT 120
CDISK LT = .FALSE.
CDISK IF (IFREE.LE.0)  GO TO 10
CDISK CALL  DISKDC(DC,QLML,QLMS,QBML,QBMS, MAXST,MAXEL)
C     KG.LT.0: STORAGE EXCEEDED;  KG=0: KF NOT IN LIBRARY DATA SET
C     KG.GT.0: (CODED) DISK POSITION OF CONFIGURATION KF
CDISK IF(KG) 13,10,13
  10  CALL  VCU( DC , QLML,QLMS,QBML,QBMS
     *              , D2,DU,DV, DE,DS,NDI , MAXST,MAXDF,MAXEL )
C     KG.LT.0: STORAGE EXCEEDED;  KG.GT.0: ACCURACY OR PHASE FAILURE
C     KG=0: SLATER STATES AND VCC PROPERLY COMPUTED BY VCU/VCE
      LT = KG.GT.0
CC13  WRITE(6,30)  KF,KG, (QN(QCG(I,KF)),QLP(QCG(I,KF)),I=1,NF)
  13  DO 23 I=1,NF
       K = QCG(I,KF)
       QLMS(I,1) = QN(K)
       LL(I) = QLP(K)
  23   QLML(I,1) = QL(K)
      PRINT 30,  KF,KG, (QLMS(I,1),LL(I),I=1,NF)
      IF (ND.EQ.0)  GO TO 99
      M = NTG(KF)
      NK = M-NT
      IF (NK.EQ.0)  GO TO 11
      LG = NK+NF.LE.13
      K = NT+1
      IF(MPRINT.GE.0) THEN
      PRINT 20,   JA,JB,QBMS(1),MAXST, MTGD,MAXDC, MAXDF, MOD           UCL77AUG
     *          , ND, (QTGS(I),QTGL(I),QTGD(I),I=K,M)
      ELSE
      PRINT 140,  JA,JB,QBMS(1),MAXST, MTGD,MAXDC, MAXDF, MOD
     *          , ND, (QTGS(I),QTGL(I),QTGD(I),I=K,M)
      ENDIF
      IF (KG.LT.0)  GO TO 99
      IF (.NOT.LP)  GO TO 11
      IF(LG)  GO TO 14
      PRINT 70,  KF, (QLMS(I,1),QLML(I,1),I=1,NF)
      PRINT 80!, JB, KG, MAXST
      DO 19 J=JA,JB
       L = QBMS(J) + QBML(J)
  19   PRINT 80,  J, QBML(J),QBMS(J),L, (QLML(I,J),QLMS(I,J), I=1,NF)
      PRINT 110,  ND,  (QTGS(I),QTGL(I),QTGD(I),I=K,M)
      GO TO 15
  14   DMT(5) = DMN(NF)
       DMT(8) = DMN(NK)
      WRITE(6,DMT)  KF, (QLMS(I,1),QLML(I,1),I=1,NF)                    UCL77AUG
     *        , (QTGS(I),QTGL(I),QTGD(I),I=K,M)
       DMU(3) = DMN(NF)
       DMU(6) = DMN(13-NF)
  15  IF (LT)  GO TO 11
      DO 18  J=JA,JB
       DO 17 I=1,NK
        K = J + JTGD(I+NT)
  17    DS(I) = DC(K)
       IF (LG)  GO TO 16
       PRINT 60,  J, (DS(I),I=1,NK)
       GO TO 18
  16  WRITE(6,DMU)  J,QBML(J),QBMS(J),  QBMS(J)+QBML(J),
     *   (QLML(I,J),QLMS(I,J),I=1,NF), (DS(I),I=1,NK)
  18   CONTINUE
      PRINT 110
  11  JYI(KF) = JA
      IF (.NOT.LT)  GO TO 12
      LF = .TRUE.
      IF (KG.GT.MAXDF)  GO TO 21
      PRINT 96
cZ   *        , MFAIL,EPS
      GO TO 12
  21  PRINT 98
  12  JYF(KF) = JB
C     RESULTS FOR ANY OF THE KM CONFIGURATIONS KF: 1-QCP(KF) = PARITY,
C     SLST'S  NL'S AS QCG(I,KF),I=1,NF = GROUP NUMBER K OF I'TH ELECTRON
C      THE OTHER QUANTUM NUMBERS ARE IN SECTIONS J=JYI(KF)...JYF(KF) OF
C      QLMS,QLML(I,J) = 2* LITTLE MS,ML OF I'TH ELECTRON IN SLST J;
C      QBMS,QBML(J) = 2* TOTAL MS,ML OF SLST J (= SUM OVER LITTLE M'S).
C     TERMS  QTGS,QTGL(I),I=NTG(KF-1)+1,NTG(KF) = 2*S,2*L
C      (QMCS,QMCL = 2*SMAX,2*LMAX OF ALL THE NTG(KM) TERMS);
C     DC(JTGD(KF)+J) = VCC OF J'TH SLST TO TERM I, WITH I,J LIMITS ABOVE
      IF (NTG(KM).EQ.0)  GO TO 9
      IF (LF)  GO TO 9
      ND = KM
      IF(MAXLL*2.LT.QLMAX) PRINT 150, MAXLL,QLMAX/2
      RETURN
C
  150 FORMAT(///9X,56(1H*)/9X,'* WARNING: COMPUTATION OF ANGULAR ALGEBRA
     * WILL BE SLOW *'/9X,'* =======  BECAUSE SED PARAMETER MAXLL=',I2,
     * ' .LT.',I2,7X,'*'/9X,56(1H*)//)
  140 FORMAT(17H SLATER-STATES IN,I5,3H=JA,I5,1H(,I5,12H)=JB, MAXST=,I5,
     * 18H, VCC STORED UP TO,I8,13H=MTGD, MAXDC=,I7, 9H; MAXDF =,
     * I3,  8H;  MODE=,I2/ I6,32H SPECTROSCOPIC TERMS (2S 2L DP):,
     * (T42, 8(2X,I3,I2,I3)))
   20 FORMAT(24H SLATER-STATES STORED IN,I5,3H=JA,I5,1H(,I5,12H)=JB, MAX
     *ST=,I5,19H,  VCC STORED UP TO,I7,14H=MTGD, MAXDC =,I7, 10H;  MAXDF
     * =,I3, 10H;    MODE=,I2/ I6,32H SPECTROSCOPIC TERMS (2S 2L DP):,  77MR79MY
     * (T42, 9(2X,I3,I2,I3)))
   30 FORMAT(/18H CONFIGURATION CF=,I3,1H,,I4,29H ON DISK,  (N L)-COMBIN
     *ATIONS,(T58,10(I4,I2)))
   40 FORMAT(/////1X,2A4,4X,9HATOM WITH,I3,2H +,I2,14H ELECTRONS  IN,I3,
     *37H CONFIGURATIONS, CLOSED (N L)-SHELLS , 4(I5,I3)/(83X,4(I5,I3)))
   50 FORMAT(/ 121H ATTENTION: SOME OF THE INTERNAL ORBITAL INDICES HAVE 
     * BEEN REDEFINED AND MAY NOT BE THE DEFAULT (K=1,2,3..FOR 1S,2S,2P.
     *.)/6H    K ,18I6,3H.../(7H   N L ,18(I4,I2)))
   60 FORMAT(I4,(T5,16F8.4))
   70 FORMAT(/I4, 15H=CF 2ML 2MS 2MJ, 1X, (14(I5,I3)))
   80 FORMAT(I6, I5,I4,I4, 1X, (14(I5,I3)))
  100 FORMAT(////1X,2A4,4X,9HATOM WITH,5X,I2,14H ELECTRONS  IN,
     * I3,15H CONFIGURATIONS)
  110 FORMAT(/I4,(T5,16(I3,I2,I3)))
  120 FORMAT(/66H ATTENTION: THE FOLLOWING CF'S ARE MERE CORRELATION CON
     *FIGURATIONS)
  130 FORMAT(/90H MODE=0 RESET TO -1, BECAUSE SR.VCU DOES NOT LIKE CORRE
     *LATION CONFIGURATIONS IN THAT MODE.)
C DMT-FORMAT( /  I4, 15H=CF 2ML 2MS 2MJ, NF(I6,I3), 3X, ND(I3,I2,I3) / )
C DMU-FORMAT( I6, I5,I4,I4, NF(I6,I3), 3X, (13-NF)F8.4 )                UCL75NOV
   88 FORMAT(/24H SR.ALGEB1 RESETS MAXGR=,I2,10H TO MXLIT=,I2,70H; IF NE
     *EDED EXTEND ARRAY LIT(MXLIT) AND ADJUST DATA:MXLIT IN SR.ALGEB1)
   89 FORMAT(21H SR.ALGEB1: ORBITAL ',A1,13H' IN POSITION,I4,17H OF C-IN
     *PUT (CARD,I3,7H COLUMN,I3,27H) IS OUTSIDE RANGE, MAXGR =,I3)
   90 FORMAT(/' SR.ALGEB1: STORAGE EXCEEDED IN VCU- OR DISKDC-CALL'/
     * 86H  'DISK'= -3 IF TOO MANY SLATER STATES ((JB').GT.MAXST): AUGME
     *NT  * MXEST  OR  * MXST0/
     * 10X,'-2 IF TOO MANY TERMS (SUM(ND).GT.MAXCT):',16X,'* MAXTM'/
     * 10X,'-1 IF TOO MANY VCC (MTGD.GT.MAXDC):',21X,'* MAXDC')
   91 FORMAT(50H SR.ALGEB1: ERROR WHEN REDEFINING GROUP INDICES K,,I3,
     *4H AND,I3,30H BOTH REPRESENT ELECTRONS NL =,2I2)
   92 FORMAT(57H SR.ALGEB1: C-INPUT REQUIRES STORAGE FOR MORE THAN MAXCF
     *=,I2,15H CONFIGURATIONS)
   93 FORMAT(32H SR.ALGEB1: YOU'VE REDEFINED K =,I3,8H AS NL =,I2,1X,A1)
   94 FORMAT(/51H SR.ALGEB1: CONFIGURATION INPUT INCONSISTENT - YOUR,I3,
     *26H'TH CONFIGURATION CONTAINS,I3,18H VALENCE ELECTRONS)
   95 FORMAT(/' SR.ALGEB1: SPACE FOR ONLY MAXCL=',I2,15H CORE ELECTRONS)
   96 FORMAT(/53H SR.ALGEB1: SR VCU HAS FAILED - IN PHASES OR ACCURACY
cZ   *,' - IFAIL =',I3,', EPS =',1P,E8.1
     *//)
   97 FORMAT(11H SR.ALGEB1:,I3,15H ELECTRONS NL =,2I2,7H IN CF=,I3)
   98 FORMAT(75H SR.ALGEB1: WORKING ARRAYS D2,DU,DV,DFS,DE,NDI TOO SMALL
     C ('DISK'.GT.*MAXDF))
   99 PRINT 90
   9  NF = 0
      RETURN
      END
      SUBROUTINE VCU(DC,QLML,QLMS,QBML,QBMS,DA,DU,DV,DL,DS,NO,MXS,MT,ME) VCU
C
C     -- SETS UP SLATER STATES TO A CONFIGURATION GIVEN AS GROUPS OF
C     EQUIVALENT ELECTRONS,  AND COMPUTES VECTOR COUPLING COEFFICIENTS
C     (VCC) FOR CONSTRUCTING TERMS OF TOTAL SL FROM THE SLATER STATES.
C     IT REQUIRES SR VCE (WHICH REQUIRES SR JACORD AND ROTSYM).
C     M, IN /MQVC/, RULES DIFFERENT MODES, SEE COMMENT AT THE END.
C     NB=0: SUCCESSFUL RUN; OTHERWISE STUDY RETURN-COMMENTS AND CHECK NB
C  INPUT: CONFIGURATION KF, CONSISTING OF GROUPS K=1,2..MAXGR OF
C     NEL(K,KF) EQUIVALENT ELECTRONS WITH ANGULAR LITTLE L = QL(K)/2;
C     NEL.LT.0 IS IGNORED IN THIS PROGRAM (MIGHT BE USED FOR MARKING
C     CLOSED SUBSHELLS ELSEWHERE). FOR A KF.GT.KCUT SEE NOTE AT END.
C     JB = HIGHEST INDEX TO SLATER STATE ARRAYS QBXX AND QLXX OCCUPIED
C     BY CONFIGURATIONS .LT.KF; NTG(KF-1) = HIGHEST PREVIOUS INDEX TO
C     TERM ARRAYS XTGX; VCC-ARRAY DC
C     (OF LENGTH MXD) HAS BEEN FILLED UP TO MTGD IN PREVIOUS CALL.
C     QCS0,QCL0 = 2*(SMAX,LMAX) IN CONFIGURATIONS .LT.KF
C  OUTPUT: NF = NUMBER OF ELECTRONS, QCG(I,KF) = GROUP NUMBER OF I'TH
C     ELECTRON, SLATERSTATES QLML+QLMS(I,J),I=1,NF,J=JA,JB QBML+QBMS(J);
C     ND=NTG(KF)-NTG(KF-1)+1 SL-TERMS WITH 2S,2L,NO= QTGS,L,D(K),
C     K=NTG(KF-1)+1,NTG(KF), COUPLING COEFFICIENTS DC(J+JTGD(K)). PARITY
C     QCP(KF) (0,2 FOR EVEN,ODD). NEW VALUES FOR JB, MTGD, QCS0,QCL0
cM    IMPLICIT INTEGER*2 (Q)
cS   C        ,INTEGER*2 (I-L,N)
      INTEGER  QLML,QLMS,QBML,QBMS, QCG,QL, QTGS,QTGL,QTGD,QCP,QCS0,QCL0
     C        ,QCS,QCL,QS0,QL0
      DOUBLE PRECISION  DD,DI, DA,DU,DV,DL,DS, DC, DEY
      LOGICAL  MGE3, MSEQS
      DIMENSION QLML(ME,MXS),QLMS(ME,MXS), QBML(MXS),QBMS(MXS), DC(   1) 86SEP04
     C ,DU(MT,MT),DL(MT),DS(MT),DA(MT,MT),DV(MT,MT),NO(MT)
      COMMON  MAXGR,NF,KF,NB,JA,JB  /QTG/ MTGD,ND,NTG(0: 60),
     C   JTGD(1725),QCP( 60),QTGS(1725),QTGL(1725),QTGD(1725)
     C  /DBD2/ DEY(15), QCG(54, 60),QL(15),QN(15)
     C  /MQVC/ MXD,M,KCUT,QCL0,QCS0,NEL(15, 60)
      DATA MAXCT/1725/, STOL/1.E-6/
cQ    STOL=1.E-4
      MSEQS = ND.LT.0                                                   UCL76SEP
C     IF TRUE: SIZE CHECK ONLY -- NO VCC'S
C
C
C  COMPILE ALL THE SLATER STATES THAT FORM THE GIVEN CONFIGURATION --   UCL76JAN
C     IN ARRAY LOCATIONS J=JA,JB, FOR NF ELECTRONS I=1,NF
C
      NB = -3
      MP = 0
      ND = 0
      NF = 0
      N4 = JB+1
      JA = N4
      DO 11  K=1,MAXGR
       NRJ = NEL(K,KF)
       IF (NRJ.LE.0)  GO TO 11
       NI = NF+1
       NU = NF+NRJ
       NF = NU
       IF (NU.GT.ME)  GO TO 13
       MP = NRJ*QL(K) + MP
       N3 = JA
       JD = N4-N3
   15  N4 = N3+JD
       QBMS(1) = N4
       IF (N4.GT.MXS)  GO TO 100                                        77AG84MY
C      AS PROBLEM REQUIRES MORE SLATER STATE LOCATIONS THAN PROVIDED;
       IF (NU.LT.NI)  GO TO 24
       MS = 1
       ML = QL(K)
       DO 21  I=NI,NU
        QCG(I,KF) = K
C       IF (ML.LT.-QL(K))  GO TO 13
        QLMS(I,1) = MS
        QLML(I,1) = ML
        MS = -MS
   21   ML = ML - 1-MS
   24  DO 25 J=N3,N4
        L = J-JD-1
        IF (L.LT.JA)  L = J
        DO 25 I=1,NF
         IF (I.EQ.NI)  L = 1
         QLML(I,J) = QLML(I,L)
   25    QLMS(I,J) = QLMS(I,L)
       N3 = N4+1
       DO 20  I=NI,NF
        MS = QLMS(I,1)
        ML = QLML(I,1) -1+MS
        IF (ML.LT.-QL(K))  GO TO 11
        QLMS(I,1) = -MS
        QLML(I,1) = ML
        NU = I-1
        IF (I.EQ.NF)  GO TO 15
        IF (QLMS(I+1,1).EQ.MS)  GO TO 15
        IF (QLML(I+1,1).NE.ML)  GO TO 15
   20   CONTINUE
C      STOP;  LABEL 13 ENTERED IF TOO MANY ELECTRONS
   13  NB = -4
       GO TO 100
   11  CONTINUE
      JB = N4                                                           84MAY18
      DO 18  J=JA,JB
       QBML(J) = 0
       QBMS(J) = 0
       DO 18  I=1,NF
        QBML(J) = QLML(I,J) + QBML(J)
   18   QBMS(J) = QLMS(I,J) + QBMS(J)
      QCP(KF) = MOD(MP,4)                                               84MAY18
C
C
C  LISTING OF ND TERMS (SL) CONTAINED IN THE (JB-JA+1) SLATER STATES
C     IN ARRAY LOCATIONS K=NTGX(KF)+1,NTG(KF) (WHERE NTG-NTGX+1.LE.ND)  UCL74DEC
C
      NB = -2
      N2 = NTG(KF-1)
      N1 = N2 + 1
      QCS = 0
      QCL = 0
      MGE3 = ABS(M).GE.3
      MP = 0
      IF (M.LE.-3)  MP = 2
   41 QL0 = -1
      DO 43  J=JA,JB
       MS = QBMS(J)
       IF (MS.LT.-NF)  GO TO 43
       IF (QBML(J)-QL0)  43,42,23
   42  IF (MS.LE.QS0)  GO TO 43
   23  QL0 = QBML(J)
       QS0 = MS
   43  CONTINUE
      IF (QL0.LT.0)  GO TO 50
      ML = -QL0
      IF (MGE3)  GO TO 22
      IF (KCUT**2.GE.KF*KCUT)  GO TO 28
      DO 27 J=1,KCUT
       IF (QCP(J).NE.QCP(KF))  GO TO 27
       N3 = NTG(J-1)+1
       N4 = NTG(J)
       DO 26 I=N3,N4
        IF (QTGS(I).EQ.QS0 .AND. QTGL(I).EQ.QL0)  GO TO 28
   26   CONTINUE
   27  CONTINUE
      GO TO 44
   22 IF (QL0.LT.QCL0-MP)  GO TO 45
      IF (QS0-QCS0)  45,40,44
   40 IF (QL0.NE.QCL0)  GO TO 44
   28 N2 = N2+1
CM       MODIFY THE PRECEEDING STATEMENT '28' IF YOU WISH TO EXCLUDE    UCL76FEB
CM       SELECTED TERMS; E.G. RETAIN ALL TERMS IN CONFIGURATIONS 1 AND 2
CM 28    IF (KF.LE.2)  GO TO 101
CM       AND DROP S AND P TERMS, SELECT FROM D'S, AND KEEP HIGHER TERMS:
CM       IF (QL0-4)  44,102,101
CM       EXCLUDE DOUBLETS (QS0/2 = SPIN-S -- AND QL0/2 = ORBITAL-L):
CM102    IF (QS0.EQ.1)  GO TO 44
CM101 N2 = N2+1
      IF (N2.GT.MAXCT)  GO TO 44
C     AS TERM ARRAYS TOO SMALL FOR PROBLEM;
      IF (QCS.LT.QS0)  QCS = QS0
      IF (QCL.LT.QL0)  QCL = QL0
      QTGS(N2) = QS0
      QTGL(N2) = QL0
      QTGD(N2) = 0
      DO 49  K=N1,N2
       IF (QTGL(K).NE.QL0)  GO TO 49
       IF (QTGS(K).NE.QS0)  GO TO 49
       QTGD(K) = QTGD(K) - 1
   49  CONTINUE
   44 ND = ND + 1                                                       UCL74DEC
   45  MS = -QS0
   46   DO 47  J=JA,JB
         IF (QBMS(J).NE.MS)  GO TO 47
         IF (QBML(J).NE.ML)  GO TO 47
         QBMS(J) = QBMS(J) - NF-NF-1
         GO TO 48
   47    CONTINUE
C       STOP
   48   MS = MS+2
        IF (MS.LE.QS0)  GO TO 46
       ML = ML+2
       IF (ML.LE.QL0)  GO TO 45
      GO TO 41
  50  NTG(KF) = N2                                                      UCL74DEC
      IF (N2.GT.MAXCT)  GO TO 100                                       74DC84MY
C     AS TERM ARRAYS TOO SMALL FOR PROBLEM.
C
C     CROSS OUT UNWANTED SLATER STATES J, SET UP VCC ORGANIZATION
C     (AND FOR M=1, 2ND ENTRY THROUGH 30  NB=0, CANCEL FURTHER STATES)
      NB = -1
      NU = NF - (NF/2)*2
      NI = QCS + NU
      DD = - 0.0
      IF (MSEQS)  DD = 1                                                UCL77JAN
  30  L = JA - 1
      IF (N2.LT.N1)  GO TO 39                                           UCL74DEC
      DO 33  J=JA,JB
       I = L+1
       ML = QBML(J)
       IF (NB.EQ.0)  GO TO 34
       MS = QBMS(J) + NF+NF+1
       IF (.NOT.MGE3)  GO TO 31
       IF (MS.NE.QCS)  GO TO 33
       IF (ML.GT.QCL)  GO TO 33
       IF (ML.LT.QCL-MP)  GO TO 33
       GO TO 36
  31   DO 19  K=N1,N2
        IF (M)  17,12,14                                                VCU*2.01
  12    IF (KCUT.EQ.0)  GO TO 36                                        VCU+2.02
        IF (MS.GT.QTGS(K)+2)  GO TO 19
        IF (MS.GE.-1)  GO TO 36
COLFS   IF (MS+ML.GE.-1)  GO TO 36
        GO TO 33
  14    IF (M.EQ.1)  GO TO 16
        IF (ML.NE.0)  GO TO 33
        IF (MS.NE.NU)  GO TO 33
        GO TO 36
  16    IF (ML.GT.NI)  GO TO 33
  17    IF (ML+MS.LT.0)  GO TO 33
        IF (ABS(MS).GT.QTGS(K))  GO TO 19
        IF (ABS(ML).GT.QTGL(K))  GO TO 19
        IF (M.GE.-1)  GO TO 36
        IF (ML*MS) 33,36,36
  19    CONTINUE
       GO TO 33
  34   MTGD = MTGD + N1-N2-1                                            UCL76JAN
       MS = QBMS(J)
       IF (ML+MS.NE.NU)  GO TO 33
       DO 35  K=N1,N2
        JD = JTGD(K)
  35    DC(JD+I) = DC(JD+J)
  36   L = I
       QBML(L) = ML
       QBMS(L) = MS
       DO 37  I=1,NF
        QLML(I,L) = QLML(I,J)
  37    QLMS(I,L) = QLMS(I,J)
  33   CONTINUE
      DO 38  K=N1,N2
       MTGD = L-JA+1 + MTGD
       IF (MTGD.GT.MXD)  GO TO 38                                       UCL76JAN
       JD = MTGD - L
       DO 32  J=JA,L
        IF (NB.NE.0)  GO TO 32
        I = JTGD(K)
        DD = DC(J+I)
  32    DC(J+JD) = DD
  38   JTGD(K) = JD
  39  JB = L
      IF (NB.EQ.0)  GO TO 100
C     NORMAL RETURN (NB=0) FOR M.EQ.1 (AFTER 2ND ENTRY, THROUGH 30);
      IF (N2.LT.N1)  GO TO 88
C     IN CASES MGE3=T OR KF.GT.KCUT: RETURN (NB=0) IF NO TERMS SL IN KF.UCL74DEC
      IF (MTGD.GT.MXD)  GO TO 100
C     AS PROBLEM TOO LARGE FOR VCC ARRAY DC(MXD).
C
C
C  VCC BY SIMULTANEOUSLY DIAGONALIZING  L**2 AND S**2  (IN SR VCE)       VCU
C
      NB = ND
      IF (NB.GT.MT)  GO TO 100
C     AS BUFFER ARRAYS DA,DU,DV,DL,DS,NO TOO SMALL (NB.GT.0); AUGMENT MT74DC84MY
      IF (QCL0.LT.QCL)  QCL0 = QCL
      IF (QCS0.LT.QCS)  QCS0 = QCS
      IF (MSEQS)  GO TO 88
C     NO VCC'S WILL BE COMPUTED IN 'DIMENSION CHECK ONLY'
      ML = QCL
      IF (M.GT.1)  QCL = 0
  85  MS = QCS
  86  NB = 0
      DO 51  J=JA,JB
       IF (QBML(J).NE.ML)  GO TO 51
       IF (QBMS(J).NE.MS)  GO TO 51
       DO 60 I=N1,N2
        K=JTGD(I)
  60    DC(J+K) = 0. !'05Jan12 oscb
       NB = NB + 1
       NO(NB) = J
  51   CONTINUE
      IF (NB.EQ.0)  GO TO 89
C
      CALL  VCE( QLML,QLMS,QBML,QBMS , DA,DU,DV,DL,DS,NO , MXS,MT,ME )
C       THIS CALL CAN BE REPLACED BY THE WHOLE BODY OF SR VCE.
      DO 81  L=1,NB
       DO 82  J=N1,N2
        NRJ = JTGD(J)
        QL0 = QTGL(J)
        QS0 = QTGS(J)
C       IDENTIFY L'TH TERM, RESULTING FROM DIAGONALIZING S*(S+1) AND
C       L*(L+1) FOR (MS,ML)/2, WITH ONE OF THE TERMS J=N1,N2
        IF (   ( (QS0+2)*QS0 - DS(L) )**2
     *       + ( (QL0+2)*QL0 - DL(L) )**2 .GT.NB*1.E-7 )  GO TO 82
C       AND CROSS OUT THE EXHAUSTED TERM
        QTGS(J) = QS0 + 1
C       SET UP VCC (EIGENV OF DIAGON.) IN APPROPRIATE LOCATION OF DC:
        DO 83  I=1,NB
         JD = NO(I) + NRJ
  83     DC(JD) = DU(I,L)
        MSEQS = QTGD(J).LT.0
        QTGD(J) = ABS(QTGD(J))
cM      IF (MSEQS)  QTGD(J) = -QTGD(J)
        IF (MSEQS .OR. QTGD(J).GT.1)  GO TO 81
C       ESTABLISH PROPER PHASES WITH PREVIOUS (MS,ML); FOR DEGENERATE
C       SL DO SO AFTER THE LAST TERM, QTGD=1, HAS BEEN FOUND;
C       NOTE HOW THE (IF-)LOOPS FOR MS AND ML ARE NESTED: STEP DOWN S
C       WITHIN EACH ML=CONST COMPLEX, AND APPLY L- ONLY IF MS = S
        MSEQS = MS.EQ.QS0
        N4 = J
        N3 = N4
        GO TO 91
  82    CONTINUE
       GO TO 81
C      ONLY IN CASE MGE3=T OR KF.GT.KCUT; SEE COMPLETENESS CHECK IN DO84
  99   N3 = N3 - 1
  91   IF (N3.LE.N1)  GO TO 79
       IF (QTGD(N3-1).GT.1)  GO TO 99
  79   DI = (QS0+MS+2)*(QS0-MS)
       IF (MSEQS)  DI = (QL0+ML+2) * (QL0-ML)
       DO 92  I=1,NB
        JD = NO(I)
        DD = 0.0
        DO 93  J=N3,N4
         NI = JTGD(J) + JD
         DD = DC(NI)**2 + DD
  93     DC(NI) = 0.0
        IF (DD.EQ.0.0)  GO TO 92
        DO 94  J=JA,JB
         K=0
         IF (MSEQS)  K=2
         IF (QBML(J)-K.NE.ML)  GO TO 94
         IF (QBMS(J)+K-2.NE.MS)  GO TO 94
         DD = 0.0
         DO 95  K=N3,N4
          NI = JTGD(K)+J
  95      DD = DC(NI)**2 + DD
         IF (DD.EQ.0.0)  GO TO 94
         MP = 0
         KP = 0
         DO 97  NI=1,NF
          KP = KP+NI
          DO 98  K=1,NF
           IF (QLML(K,J).NE.QLML(NI,JD))  GO TO 98
C          IF (QLMS(K,J).NE.QLMS(NI,JD) .OR. QCG(K,KF).NE.QCG(NI,KF))
           IF (QCG(K,KF)*QLMS(K,J).NE.QCG(NI,KF)*QLMS(NI,JD))  GO TO 98 UCL78JUN
           KP = KP-K
           GO TO 97
  98       CONTINUE
          IF (MP.NE.0)  GO TO 94
          MP = NI
  97      CONTINUE
C        SLATERSTATES J AND JD DIFFER IN ONE INDIVIDUAL SET, IN POSITION
C        KP AND MP; ENSURE THAT THE PAIR DOES NOT DIFFER IN NL:
         NI = QCG(KP,KF)
         IF ( QCG(MP,KF).NE.NI )  GO TO 94
         DD = (1+QLMS(KP,J)) * 2
         IF (MSEQS)  DD = (QL(NI)+QLML(KP,J))*(QL(NI)-QLML(MP,JD))
         DD = (1-MOD(MP+KP,2)*2) *  SQRT(DD/DI)
         DO 96  K=N3,N4
          NI = JTGD(K) + JD
  96      DC(NI) = DD * DC(NI+J-JD) + DC(NI)
  94     CONTINUE
C       SIGN ONLY NEEDS TO BE ESTABLISHED IF L'TH TERM SL NOT DEGENERATE
        IF (N4.NE.N3)  GO TO 92
        IF (ABS(DC(NRJ+JD)).GT.1.E-4)  GO TO 90
  92    CONTINUE
       GO TO 81
  90   DD = DC(NRJ+JD)/DU(I,L)
       IF (ABS(ABS(DD)-1.0).GT.STOL)  GO TO 100
C      VCC TOO INACCURATE;
       DO 80  I=1,NB
        JD = NO(I) + NRJ
  80    DC(JD) = DD * DU(I,L)
  81   CONTINUE
C     RESTORE 2*S-ARRAY, WHICH HAS BEEN USED FOR MARKING:
      DO 84  J=N1,N2
       IF ((QTGS(J)/2)*2.NE.QTGS(J)-NU)  GO TO 29
       IF (QTGL(J).LT.ABS(ML))  GO TO 84
       IF (QTGS(J).LT.ABS(MS))  GO TO 84
       WRITE(6,10)  J, MS,ML,NB, (DS(I),DL(I),I=1,NB)
       GO TO 100
  29   QTGS(J) = QTGS(J) - 1
  84   CONTINUE
  89  IF (MGE3)  GO TO 87
C     NORMAL RETURN FOR M.GE.3
      MS = MS - 2
      IF (MS+QCS) 87,86,86
  87  ML = ML - 2
      IF (ML+QCL) 88,85,85
  88  NB = 0
      IF (M.EQ.1)  GO TO 30
C     CANCEL AUXILIARY SLATER STATES AND COEFFICIENTS BEFORE RETURNING;
  100 RETURN
  10  FORMAT(/75H VCE FAILS -- EIGENVALUES INACCURATE - CHECK FOR ENOUGH
     C ROTATIONS IN JACORD
cY   C ROTATIONS IN NAGLIB
cZ   C ROTATIONS IN NAGMK4
     *,';   PRINTING I,MS,ML,N (4*S*(S+1),4*L*(L+1)):'/4I5,
     * (T21,10F10.5))
C     NORMAL RETURN FOR M.NE.1
C    KF.GT.KCUT(.GT.0):  ONLY THOSE TERMS RETAINED THAT SERVE AS CORRE-
C          LATION TERMS TO TERMS OF PREVIOUS CONFIGURATIONS KF.
C   M.EQ.0: ALL VCC FOR ALL COMPLETE TERMS I OF CONFIG C  STORED IN DC
C           PROVIDED KCUT=0 IS SPECIFIED (WHICH DEFAULTS TO KCUT.GE.KF)
C           OTHERWISE RESTRICTIONS ON MS APPLY: SEE LOOP DO33.
C           COLFS MAY HAVE TO BE OPENED FOR FS-COLLISION PROBLEMS.
C   M.EQ.1: ONLY VCC FOR SLATSTATES WITH /ML=MS/=MIN OF ALL TERMS K OF C
C   M.EQ.2: ONLY VCC FOR SLATSTATES WITH ML=0,MS=MIN OF ALL TERMS K OF C
C   M.GE.3: ONLY SLSTATES AND VCC WITH ML=L,MS=S OF TERM 2S=QCS0,2L=QCL0
C   M.LE.-3: ANY ML=L-1 ALSO INCLUDED (KCUT IGNORED FOR IABS(M).GE.3)
C   M.EQ.-1,M.EQ.-2 EQUIV +1,2 FOR ML,MS.LT.0, BUT ALL -,-.GT.0 RETAINED
C     NOTE: AT THE BEGINNING FOR ANY M STORAGE FOR ALL SLATER STATES
C     REQUIRED, AND FOR M=1 SOME VCC BUFFER IN DC (SEE LOOP 33).
C   CODE OF UNSUCCESSFUL RETURNS (NB.NE.0):
C   NB=-5: TOO MANY CONFIGURATIONS   -  NOT USED
C      -4: TOO MANY ELECTRONS; AFFECTS QLMS,QLML
C      -3: TOO MANY SLATER STATES; "  " AND QBMS,QBML
C      -2: TOO MANY TERMS; AFFECTS QTGS,QTGL,QTGD,JTGD
C      -1: TOO MANY VCC; AFFECTS DC(MXD)
C      .GT.MT: BUFFER ARRAYS DA,DU,DV,DL,DS,NO TOO SMALL
C      .GT.0: NUMERICAL TROUBLE - ACCURACY.
       END
      SUBROUTINE  VCE(QLML,QLMS,QBML,QBMS, DA,DU,DV,DL,DS,NO, MXS,MT,ME)
C
C    --- COMPUTES NB SIMULTANEOUS O.N. EIGENVECTORS DU(N,K),K=1,NB
C    WITH EIGENVALUES DS(K)/4 AND DL(K)/4 OF TOTAL SPIN S AND ORBITAL L,
C    FROM A COMPLETE SET OF NB SLATER STATES J (=NO(N),N=1,NB), TO PAIRS
C    BIG MS,ML = QBMS/2,QBML/2 OF A CONFIGURATION KF WITH NF ELECTRONS;
C    TWICE LITTLE L,MS,ML OF I'TH ELECTRON  QL(QCG(I,KF)),QLMS,+L(I,J).
C  INPUT: NB,NO,QLML,QLMS,QBML,QBMS, KF,NF,QCG,QL; MXS,MT,ME
C  OUTPUT: DU,DL,DS;    WORKING ARRAYS: DV,DA (DU=DV*DA IN MODE JACORD)
C     REFERENCE: EQU'S 19-25 IN COMPUTER PHYS. COMMUN. 8(1974)270-306.
C
cM    IMPLICIT INTEGER*2 (Q)
cS   C        ,INTEGER*2 (I-L,N)
      INTEGER  QLML,QLMS,QBML,QBMS, QCG,QL, QS0,QL0
      DOUBLE PRECISION  DD,DEY, DA,DU,DV,DS,DL, TOL,EPS
      LOGICAL MSEQS
      DIMENSION QLML(ME,MXS),QLMS(ME,MXS), NO(MT), QBML(MXS),QBMS(MXS),
     C  DU(MT,MT),DL(MT),DS(MT),DV(MT,MT),DA(MT,MT)
cY   C  DU(MT,MT),DL(MT),DS(MT),DV(MT,MT),DA(MT),TAU( 450),WRK( 450)
cZ   C  DU(MT,MT),DL(MT),DS(MT),DV(MT,MT),DA(MT)
      COMMON MXX,NF,KF,NB
cZ   *  /NAGPAR/ TOL,EPS,MFAIL
     C  /DBD2/ DEY(15), QCG(54, 60),QL(15),QN(15)
C     CONDITIONS: KF.LE.MAXCF, NF.LE.ME.LE.MXEL0, NB.LE.MT, NO.LE.MXS   UCL77AUG
      DATA STOL/3.0E-8/
cY   * , MFAIL/0/
cQ    STOL=1.E-4
C
cY    MB = NB
cZ    MB = NB                                                           QL-NAG76
      MSEQS = .TRUE.
      DO 60  M12=1,2
       DO 61  K=1,NB
        J = NO(K)
        DO 69  I=1,NB
  69     DS(I) = 0.0
        DS(K) = ((M12-1)*QBML(J) + (2-M12)*QBMS(J))**2                  UCL76AUG
        DO 62  I=1,NF
         N3 = QCG(I,KF)
         NI = QLMS(I,J)
         JD = 2
         IF (MSEQS)  GO TO 65
         NI = QLML(I,J)
         JD = (QL(N3)+2)*QL(N3) - NI*NI
  65     DS(K) = JD + DS(K)
         DO 64  L=1,NF
          IF (L.EQ.I)  GO TO 64
          N4 = QCG(L,KF)
          DO 63  JD=1,NF
           QLML(JD,1) = QLML(JD,J)
  63       QLMS(JD,1) = QLMS(JD,J)
          IF (MSEQS)  GO TO 53
          QLML(I,1) = NI-2
          KG = (QL(N3)+NI) * (QL(N3)-NI+2)
          QL0 = QLML(L,J)
          QLML(L,1) = QL0+2
          KP = (QL(N4)-QL0) * (QL(N4)+QL0+2)
          GO TO 67
  53      QLMS(I,1) = NI-2
          KG = (1+NI) * (3-NI)
          QS0 = QLMS(L,J)
          QLMS(L,1) = QS0+2
          KP = (1-QS0) * (3+QS0)
  67      IF (KG.LE.0 .OR. KP.LE.0)  GO TO 64
          DD = KG*KP
          DD = SQRT(DD)
          DO 55  JD=1,NF
           KG = QCG(JD,KF)
           IF (N3.NE.KG .AND. N4.NE.KG)  GO TO 55
           DO 56  KP=JD,NF
            IF (QCG(KP,KF).NE.KG)  GO TO 56
            IF (KP.EQ.JD)  GO TO 56
            NRJ = QLML(KP,1)
            QS0 = QLMS(JD,1)
            QL0 = QLML(JD,1)
            IF (MSEQS)  GO TO 57
             IF (QL0.GE.NRJ)  GO TO 58
             QLML(JD,1) = NRJ
             QLML(KP,1) = QL0
             GO TO 59
   57        IF (KP-JD.NE.1)  GO TO 56
C            ASSUMING SLATER STATES IN SLATER ORDER -
   58        IF (QL0.NE.NRJ)  GO TO 56
             IF (QLMS(KP,1)-QS0)  56,64,59
   59       QLMS(JD,1) = QLMS(KP,1)
            QLMS(KP,1) = QS0
            DD = - DD
   56       CONTINUE
   55      CONTINUE
          DO 66  KG=1,NB
           JD = NO(KG)
           DO 68  KP=1,NF
            IF (QLML(KP,JD).NE.QLML(KP,1))  GO TO 66                    UCL77AUG
            IF (QLMS(KP,JD).NE.QLMS(KP,1))  GO TO 66
   68       CONTINUE
           DS(KG) = DS(KG) + DD
           GO TO 64
   66      CONTINUE
   64     CONTINUE
   62    CONTINUE
        DO 61 L=1,NB
         IF (.NOT.MSEQS)  GO TO 61                                      UCL76AUG
         IF (ABS(DS(L)).LT.STOL)  DS(L) = 0.0
   61    DU(L,K) = DS(L)
C      MATRIX S**2 (IF M12=1) OR L**2 IN DU; TAS CH.VII.4.8(P.221IN1964)
       IF (MSEQS)  GO TO 75
       DO 72  L=1,NB
        DO 71 I=1,NB
         DS(I) = 0.0
         DO 71 K=1,NB
  71      DS(I) = DV(K,I)*DU(K,L) + DS(I)
        DO 72 I=1,NB
  72     DU(I,L) = DS(I)
       DO 74  I=1,NB
        DO 73 L=1,NB
         DS(L) = 0.0
         DO 73 K=1,NB
  73      DS(L) = DU(I,K)*DV(K,L) + DS(L)
        DO 74 L=1,NB
         IF (ABS(DS(L)).LT.STOL)  DS(L) = 0.0
  74     DU(I,L) = DS(L)
  75   CALL JACORD( NB , .TRUE. , DU , DA , MT )
C       SR. F01AJF TRANSFORMS A SYMMETRIC MATRIX DU (3RD ARGUMENT -
C                  PRESERVED IF UNEQUAL 7TH) TO TRIDIAGONAL FORM
cZ75   CALL F01AJF(MB,TOL,DU,MT,DA,DS,DU,MT)
C                PASSED ON ARE (DA,DS,DU) = (DIAGONAL, SUBDIAGONAL,
C                                     HOUSEHOLDER TRANSFORMATION MATRIX)
cY75   CALL F08FEF('U',MB,DU,MT,DA,DS,TAU,WRK,MW,MT)
cY     CALL F08FFF('U',MB,DU,MT,TAU,WRK,MW,MT)
cZ     CALL F02AMF(MB,EPS,DA,DS,DU,MT,MFAIL)
C       SR. F02AMF DIAGONALIZES A  SUITABLE  MATRIX (RESULTS DA AND DU).
cY     CALL F08JEF('V',MB,DA,DS,DU,MT,WRK,MFAIL)
       DO 78  K=1,NB
        DS(K) = 0.0
        DO 77  I=1,NB
cZ       DD = DU(I,K)
cY       DD = DU(I,K)
         DD = DA(I,K)
         IF (ABS(DD).LT.STOL)  DD = 0.0
         IF (.NOT.MSEQS)  GO TO 76
         DV(I,K) = DD
         GO TO 77
  76     DS(K) = DD*DL(I)*DD + DS(K)
cZ       DU(I,K) = DD
cY       DU(I,K) = DD
         DA(I,K) = DD
  77     CONTINUE
  78    CONTINUE
       MSEQS = .FALSE.
       DO 60  K=1,NB
cZ60    DL(K) = DA(K)
cY60    DL(K) = DA(K)
  60    DL(K) = DU(K,K)
C
      DO 70 I=1,NB
       DO 54 K=1,NB
cZ      DA(K) = 0.0
cZ      DO 54 J=1,NB
cZ54     DA(K) = DV(K,J)*DU(J,I) + DA(K)
cZ     DO 70 K=1,NB
cZ70    DU(K,I) = DA(K)
cY      DA(K) = 0.0
cY      DO 54 J=1,NB
cY54     DA(K) = DV(K,J)*DU(J,I) + DA(K)
cY     DO 70 K=1,NB
cY70    DU(K,I) = DA(K)
        DD = 0.0
        DO 52 J=1,NB
  52     DD = DV(I,J)*DA(J,K) + DD                                      UCL76AUG
  54    DU(I,K) = DD
  70   CONTINUE
      RETURN
      END
      SUBROUTINE  ALGEB2( DC,QLML,QLMS,QBML,QBMS,JYI,JYF, MAXST,MAXEL )  ALGEB2
C
C     -- DEALS WITH THE PROBLEMS DESCRIBED IN SECTION 3.2 OF E&N:
C     IT CALCULATES THE (PURELY) ALGEBRAIC COEFFICIENTS FOR EACH NONVAN-
C     ISHING ENERGY MATRIX ELEMENT, ASSUMING ELECTROSTATIC INTERACTION;
C     FURTHERMORE REDUCED ELECTR MULTIPOLE MATRIX ELEMENTS ARE COMPUTED
C
cM    IMPLICIT INTEGER*2 (Q)
cS   C        ,INTEGER*2 (I-L,N)
      IMPLICIT INTEGER (Q)
      LOGICAL  BVC, LP, SKP,  AM
cM    LOGICAL  BVC, LP, SKP
cM    LOGICAL*1 AM
      PARAMETER (MXD31=4+1,MXD32=MXD31*MXD31, MXD13=78*3)
      CHARACTER*9 CTERM(2)
      DOUBLE PRECISION  DD,DVC, DRK,DEY, DC,DFS, VCC,VCA
      DIMENSION QLML(MAXEL,MAXST), QBML(MAXST), JYI( 60), DC(1750000)
     2        , QLMS(MAXEL,MAXST), QBMS(MAXST), JYF( 60), AM( 19000)
      COMMON  MAXGR, NF, KF,KG, JA,JB,JAP,JBP, ND1,NDP1, ND2,NDP2, NI
     C /TERMS/ KM,NSL0, NSL( 60),NFI(1225),NFK(1225),
     *    NFQ(1225),NAD(0: 61500),QPI( 60),QSI( 60),QLI( 60)
     *  /MQVC/ MAXDC,MD,KCUT,QMCL,QMCS,NEL(15, 60)
     *  /OUTP/ MPRINT,MKUTS(2),KDUM,LCE1,LCE2 /NXRL/IRLM,IRK,IRKM, IRK0
     C  /DXRL/ DRK( 513000), IRL,NRK( 513000), QRL(5, 11000)
     *  /QTG/ MTGD,NXLL,NTG(0: 60),JTGD(1725), QCP( 60),
     *     QTGS(1725),QTGL(1725),QTGD(1725)
     *  /DBD2/ DEY(15),QCG(54, 60), QL(15), QN(15)
     *  /CFCT/BVC,MXLL,VCA(MXD32,MXD32,MXD31) /CCLSH/NW,NNL(MXD13)
      COMMON /COMFAC/ DFS( 64),MAXD
      DATA  MAXSL/ 60/, MAXAD/ 61500/, MAXTM/1225/,
     C      MAXCL/78/,  MAXL/4/, MAXDI/290/,  MG/-6/
     *      CTERM/'DIAGONAL ','CORE TERM'/
      MVC(M,MA) = ( (M+2)*M/2 + MA )/2 + 1
      IRKM= 513000
      IRLM= 11000
C
      KM = NXLL
      MM = JYF(KM)
      IOS = JYI(1)
C     CODE QLMS AND QLML INTO ONE ARRAY (TO SAVE STORAGE)
      IF (NW.EQ.0)  GO TO 8
      DO 9 I=1,NW
   9   NNL(I+MAXCL) = (NNL(I+2*MAXCL)+1)/2 + NNL(I+MAXCL)
   8  DO 7 J=IOS,MM                                                     COR76FEB
       DO 7  I=1,NF
   7    QLML(I,J) = ( QLMS(I,J)+1 )/2 + QLML(I,J)
C
C     RETABULATE THE NCI=NTG(KM) TERMS CASL OF THE KM CONFIGURATIONS
C     ACCORDING TO TOTAL S,L,KPC(=PARITY  0,2 FOR EVEN,ODD); ONE OBTAINS
C     NSL0 BLOCKS OF LENGTH NSL(N), WITH QSI(N)=2S,QLI(N)=2L,QPI(N)=KP;
C
      PRINT 400
      NCI = 0
      NSL0 = 0
      N = 0
      QCL = QMCL
  51   QCS = QMCS
  52    KCP = 0
  53     NC = 0
         DO 63  K=1,KM
          IF (QCP(K).NE.KCP)  GO TO 63
          NG = NTG(K-1) + 1
          NT = NTG(K)
          IF (NT.LT.NG)  GO TO 63
          DO 64  I=NG,NT
           IF (QTGL(I).NE.QCL)  GO TO 64
           IF (QTGS(I).NE.QCS)  GO TO 64
           NC = NC + 1
           NCI = NCI + 1
           LP = NCI.GT.MAXTM
           ND = NSL0 + 1
           IF (MPRINT.GE.-1)  PRINT 180,  NCI, QCS,QCL,KCP, K,I, ND
           IF (LP)  GO TO 64
           NFQ(NCI) = ND
           NFK(NCI) = K
           NFI(NCI) = I
  64       CONTINUE
  63      CONTINUE
         IF (NC.EQ.0)  GO TO 54
         IF (NC.GT.MAXDI)  PRINT 196, NC,MAXDI
         BVC = ND.GT.MAXSL
         N = ((NC+1)*NC)/2 + N
         NSL0 = ND
         IF (BVC)  GO TO 54
         QLI(ND) = QCL
         QSI(ND) = QCS
         QPI(ND) = KCP
         NSL(ND) = NC
  54     KCP = KCP + 2
         IF (KCP.LE.2)  GO TO 53
        QCS = QCS - 2
        IF (QCS.GE.0)   GO TO 52
       QCL = QCL - 2
       IF (QCL.GE.0)  GO TO 51
       IF (MPRINT.LT.-1)  PRINT *, NCI,' TERMS ALTOGETHER.'
C
C
C     SET UP STRUCTURE (COEFFICIENTS) OF ENERGY MATRIX IN SL COUPLING  -UCL76FEB
C     THIS SECTION SHOULD BE STUDIED TOGETHER WITH (COMMENTS IN) SR FLGL
C
      J=2
      IF(MPRINT.GE.0) J=1
      PRINT 150, (CTERM(I),I=J,2)
      PRINT 160,  MAXAD, MAXSL, MAXTM,MAXTM, IRKM,IRLM, MAXD
      LP = LP .OR. BVC
      JOS = 0
      IF (LP)  JOS = -1
      J = N+1
      IF (J.GT.MAXAD)  GO TO 91                                         79/09/16
      IF (LP)  GO TO 94
      MXLL = -1
      NXLL = -1
      SKP = MPRINT.LT.MG
      IF (SKP)  GO TO 50                                                UCL77JAN
      DO 41  K=1,MAXGR
       IF (DEY(K).EQ.0.0)  GO TO 41
       IF (QL(K).GT.MXLL)  MXLL = QL(K)
  41   CONTINUE
      NXLL = MXLL                                                       UCL75MAR
      BVC = MXLL.LE.2*MAXL
      IF (.NOT.BVC)  MXLL = 2*MAXL
      M1 = 0
  46   M2 = 0
  45    MK = ABS(M1-M2)
  44     DVC = VCC(M1,M2,MK,0,0,0,DFS,MAXD)/(MK+1)
         ML1 = -M1
  42      MB1 = MVC(M1,ML1)
          ML2 = -M2
  43       MB2 = MVC(M2,ML2)
           DD = 0.0
           MLK = ML1 + ML2
           IF (ABS(MLK).GT.MK)  GO TO 47
           DD = VCC(M1,M2,MK, ML1,ML2,MLK, DFS,MAXD) * DVC
  47       MLK = MK/4 + 1
           VCA(MB1,MB2,MLK) = DD
           ML2 = ML2 + 2
           IF (ML2.LE.M2)  GO TO 43
          ML1 = ML1 + 2
          IF (ML1.LE.M1)  GO TO 42
         MK = MK + 4
         IF (MK.LE.M1+M2)  GO TO 44
        M2 = M2 + 2
        IF (M2.LE.MXLL)  GO TO 45
       M1 = M1 + 2
       IF (M1.LE.MXLL)  GO TO 46
C
  50  LP = MPRINT.GT.0
      KCP = NF - (NF/2)*2
      JOS = 1
      IRK = 0
      IRL = 0
      NAD(0) = 0
      AM(1) = .FALSE.
      N = 0
      IF (NW.GT.0)  N = - 1
C     DRK(K),K=1,NAD(0) WILL BE THE COEFFICIENTS TO THE CLOSED SHELL
C     CONFIGURATION C0 - IT CONTRIBUTES TO ALL DIAGONAL <T|H|T>, EJN-EQ6
C     CHOICE OF ML,MS ACCORDING TO TIME OPTIMUM AND STATES AVAILABLE
      QML = 0
      QMS = KCP
      NT = 0
C     EXPAND THE NSL0 SUBMATRICES SLP = QSI(K)+1,QLI(K)/2,1-QPI(K)
      DO 61  K=1,NSL0
       NC = NSL(K)
       IF ((MD+1)/2.EQ.1)  GO TO 58
       QMS = QSI(K)
       QML = QLI(K)
  58   DO 57  J=IOS,MM
  57    AM(J) =  QBML(J).NE.QML .OR. QBMS(J).NE.QMS
C 56   DO 55  ND1=1,NC -- FOR CLAUDIO'S FE X (403 TERMS)
  56   DO 68  ND1=1,NC
        ND = ND1 + NT
        KF = NFK(ND)
        II = NFI(ND)
        ND2 = JTGD(II)
        JA = JYI(KF)
        JB = JYF(KF)
        DO 55  NDP1=1,ND1
         NG = NDP1 + NT
         KG = NFK(NG)
         II = NFI(NG)
         NDP2 = JTGD(II)
         JAP = JYI(KG)
         JBP = JYF(KG)
         NI = NF
         IF(N.LT.0)  NI = 0
         CALL  FLGL( DC , QLML,AM , DFS,MAXST,MAXD,MAXEL )
         N = N + 1
         IF (IRL.GT.IRLM)  JOS = -1                                     UCL76SEP
         IF (IRK.GT.IRKM)  JOS = 0
         IF (JOS.LE.0)  GO TO 67
         IF (.NOT.LP)  GO TO 59
         IF (IRK.LT.IRK0)  GO TO 59
         PRINT 120,  N, K, ND,NG, IRK,IRL, (NRK(I),DRK(I),I=IRK0,IRK)
  59     NAD(N) = IRK
         IF (N.EQ.0)  GO TO 56
  55     CONTINUE
        IF(LP) GO TO 68
        IF(NCI.LT.100) GO TO 68
        IF(MOD(ND+0,20).NE.0) GO TO 68
        IF(ND.EQ.NCI) GO TO 68
        PRINT 120,  N, K, ND,NG, IRK,IRL
  68    CONTINUE
  61   NT = NT + NC
      MM = IRL + IRK-IRK0
      IF (AM(1))  PRINT 195, MM                                         UCL77AUG
      IF (LP)  GO TO 65
  67  PRINT 120,  N,NSL0, ND,NG, IRK,IRL
      IF (JOS)  93,92,66
  66  PRINT 900,  MPRINT
      GO TO 17
C     RESULTS
C     DRK(K),K=(NAD(N-1)+1),NAD(N) = STRUCTURE COEFFICIENTS,
C     AND NRK(K) = SLATER INTEGRAL ADRESSES L, OF THE N'TH ENERGY MATRIX
C     ELEMENT; (T|H|T') IS N-NUMBERED IN REDUCED TRIANGULAR ORDER - COM- ALGEB2
C     PARE THE FIRST THREE COLUMNS OF THE COEFFICIENT TABLE, IT REVEALS
C     MOST FEATURES. THE FOUR ELECTRON ARGUMENTS (1,2,3..FOR 1S,2S,2P..)
C     OF THE L'TH SLATER INTEGRAL ARE IN QRL(1-4,L), QRL(5,L)=2*LAMBDA.
C     QRL(5,L)=-1 INDICATES A NONTRIVIAL, OFF-DIAGONAL ONE-BODY INTEGRAL
C
C     PRINT SLATER INTEGRAL (ADRESS REFERENCE) LIST
  65  IF (IRL.EQ.0)  GO TO 17
      PRINT 300
      DO 62  L=1,IRL
  62   PRINT 700,  L,  (QRL(I,L), I=1,5)
C
C
C     WORK OUT REDUCED ELECTRIC MULTIP.MATRIX ELEMENTS - OR PUT NAD(N)=0 ALGEB2
C     IF AVAILABLE STORAGE INSUFFICIENT OR TOO FEW SLATERSTATES(MD.GT.0)
C
  17  IF (MPRINT.EQ.MG)  GO TO 10                                       UCL76SEP
      IF(MPRINT.LT.0) THEN
       PRINT 500
      ELSE
       PRINT 600
      ENDIF
      J = N + NCI
      IF (J.GT.MAXAD)  GO TO 91
      DD = 1.                                                           UCL77JAN
      IOS = IRK
      DO 11  ND1=1,NCI
       KF = NFK(ND1)
       II = NFI(ND1)
       ND2 = JTGD(II)
       JA = JYI(KF)
       JB = JYF(KF)
       NC = NFQ(ND1)
CTEST  DO 25  NDP1=1,NCI
       DO 25  NDP1=1,ND1
        ND = NFQ(NDP1)
        IF (QSI(ND).NE.QSI(NC))  GO TO 25
        IF (QPI(ND).EQ.QPI(NC)) THEN
         IF(LCE2.LT.0) GO TO 25
         MK = 0
        ELSE
         IF(LCE1.LT.0) GO TO 25
         MK = -2
        ENDIF
        KG = NFK(NDP1)
        J = 0
        DO 13  K=1,MAXGR
         I = NEL(K,KG) - NEL(K,KF)
         J = I*I + J                                                    UCLFEB74
         IF (J.GT.2)  GO TO 25
  13     CONTINUE
        II = NFI(NDP1)
        NDP2 = JTGD(II)
        JAP = JYI(KG)
        JBP = JYF(KG)
        M1 = QLI(NC)
        M2 = QLI(ND)
        IF (M1+M2.EQ.0 .AND. MK.EQ.0)  GO TO 26
  12    MK = MK + 4
  26    IF (ABS(M1-M2).GT.MK)  GO TO 12
        IF (M1+M2.LT.MK)  GO TO 25
C       ...24  FIND A NONVANISHING MULTIPOLE MATRIX ELEMENT
        K = 0
        IF (MD.LE.0)  KCP = QSI(NC)
        MB1 = M1
  21    MB2 = M2
  22    MLK = MB1 - MB2
        ML2 = -MB2
        DVC = VCC( M1,M2,MK , MB1,ML2,MLK , DFS,MAXD )
        IF (DVC.EQ.0.0)  GO TO 23
        IF (MD.LE.0)  GO TO 24
        IF (MB1+MB2.EQ.0)  GO TO 24
        K = 1
  23    MB2 = MB2 - 2
        IF (MB2.GE.0)  GO TO 22
        MB1 = MB1 - 2
        IF (MB1.GE.0)  GO TO 21
        IF (MD*K.LE.0)  GO TO 25
        IF(NAD(N+1).EQ.0) GO TO 25
        PRINT 700,  MB1, ND1,NDP1
        PRINT 800
        NAD(N+1) = 0
        GO TO 25
  24    II = IOS
        L = IOS + 1
        DO 15  J=JA,JB
         IF (QBMS(J).NE.KCP)  GO TO 15
         IF (QBML(J).NE.MB1)  GO TO 15
         DO 16  JD=JAP,JBP
          IF (QBMS(JD).NE.KCP)  GO TO 16
          IF (QBML(JD).NE.MB2)  GO TO 16
          QCS = 0
          QCL = 0
          IF (JD.EQ.J)  GO TO 27
          DO 18  I=1,NF
           QCS = QCS + I
           DO 19  K=1,NF
            IF (QCG(K,KG).NE.QCG(I,KF))  GO TO 19
            IF (QLML(I,J).NE.QLML(K,JD))  GO TO 19
            QCS = QCS - K
            GO TO 18
  19        CONTINUE
           IF (QCL.NE.0)  GO TO 16
           QCL = I
  18       CONTINUE
          GO TO 20
  27      QCL = QCL + 1
          QCS = QCL
  20      NG = QCG(QCL,KF)
          NT = QCG(QCS,KG)
          M1 = QL(NG)
          M2 = QL(NT)
          IF (M1+M2.LT.MK)  GO TO 28                                    UCL77JAN
          IF (ABS(M1-M2).GT.MK)  GO TO 28
          IF (SKP)  GO TO 40
          ML1 = ((QLML(QCL,J)+100)/2)*2 - 100
          ML2 = ((QLML(QCS,JD)+100)/2)*2 - 100
          ML2 = -ML2
C         MLK = ML1 + ML2
          IF (BVC)  GO TO 48
          IF (M1.LE.MXLL .AND. M2.LE.MXLL)  GO TO 48
          DD =   VCC( M1,M2,MK,  0 , 0 , 0  , DFS,MAXD )
     C         * VCC( M1,M2,MK, ML1,ML2,MLK , DFS,MAXD ) / (MK+1)
          GO TO 49
  48      I = MVC(M1,ML1)
          K = MVC(M2,ML2)
          MM = MK/4+1
          DD = VCA(I,K,MM)
  49      DD = (-1)**((MK-ML2)/2+QCL+QCS) * DC(J+ND2) * DC(JD+NDP2)      ALGEB2
     C         *  SQRT( REAL((M1+1)*(M2+1)) ) * DD
          IF (DD.EQ.0.0)  GO TO 28
  40      K = (NG-1)*MAXGR + NT-1                                       UCL77JAN
          IF (II.LT.L)  GO TO 30
          DO 29  I=L,II
           IF (NRK(I).NE.K .AND. NRK(I).NE.(NT-1)*MAXGR+NG-1)  GO TO 29 UCL74JUL
           DRK(I) = DRK(I) + DD
           GO TO 28
  29       CONTINUE
  30      II = II + 1
          IF (II.GT.IRKM)  GO TO 92
          NRK(II) = K
          DRK(II) = DD
  28      IF (JD.NE.J)  GO TO 32                                        UCL77FEB
          IF (QCS.LT.NF)  GO TO 27
  32      IF (.NOT.SKP)  GO TO 16                                       UCL77FEB
          IOS = II
          IF (IOS.GE.L)  GO TO 31
  16      CONTINUE
  15     CONTINUE
        IF (II.LT.L)  GO TO 25
        DO 14  I=L,II
         DD = DRK(I)
cP       IF (ABS(DD).LT.1.E-5)  GO TO 14
         IF (DABS(DD).LT.1.E-7)  GO TO 14
         IOS = IOS + 1
         DRK(IOS) = (-1)**((QLI(ND)-MB2)/2)*SQRT(REAL(MK+1))*DD / DVC
         NG = NRK(I)/MAXGR + 1
         NT = NRK(I) - (NG-1)*MAXGR + 1
         NRK(IOS) = (NDP1-1)*MAXGR*MAXGR + NRK(I)                       UCL74JUL
         J = MK/2
         IF (.NOT.LP)  GO TO 14
         PRINT 700,  JOS, ND1,NDP1,NG,NT,IOS, DRK(IOS), DD,DVC,MB1,MB2,J ALGEB2
  14     CONTINUE
        IF (IOS.LT.L)  GO TO 25                                         UCL77FEB
  31    JOS = JOS+1
  25    CONTINUE
       IF(LP) GO TO 11
       IF(MOD(ND1+0,100).EQ.0 .OR. ND1.EQ.NCI)
     * PRINT 700, JOS, ND1,ND1, MG,MG, IOS                              QUB92MAR
  11   NAD(ND1+N) = IOS
      IF (LP)  GO TO 90
      PRINT 900, MPRINT
      GO TO 90
  10  NAD(N+1) = 0
      PRINT 1000
  90  RETURN
C
  120 FORMAT(/1X,I5,I3,2I4, I7,I5, (T31,6(I6,F11.6)) )
  150 FORMAT(/112H SLATER COEFFICIENTS  F(A,...)  FOR CONSTRUCTING   ( T
     * | H | TP )  =  SUM(F(A,...) * R(A,...));  NCYC=0: COMMON ,2A9)
  160 FORMAT(          I6,I3,2I4,I7,I5,  3X, 69HSTORAGE RESTRICTIONS FOR
     * (MAXAD,MAXSL,MAXTM,MAXTM,MAXRK,MAXRL), MAXD=,I3/ 2X,
     * 28HNCYC GR   T  TP    MNF  MNR ,5(2X,15HI(R)   F(A,...)) )
  180 FORMAT(1X,I3,3I4,25X,3I4)
  190 FORMAT(/45H SR.ALGEB2: STORAGE EXCEEDED  -  CASE SKIPPED)
  191 FORMAT(/22H SR.ALGEB2:  * MAXAD =,I7,24H REQUIRED FOR NAD(MAXAD))
  192 FORMAT(/50H SR.ALGEB2:  * MAXRK TOO SMALL, ARRAYS DRK AND NRK)
  193 FORMAT(/50H SR.ALGEB2:  * MAXRL TOO SMALL, ARRAYS DRL AND QRL)
  194 FORMAT(/20H SR.ALGEB2: * MAXTM=,I3,12H AND  MAXSL=,I2,9H REQUIRED)
  195 FORMAT(/28X,63HWARNING: SHORTAGE OF BUFFER SPACE RESULTS IN EXCESS
     *IVE SCANNING/28X,59H*******  THIS CASE MAY BE FASTER IF YOU CHOOSEUCL77MAR
     * * MAXRL .GT.,I5)
  196 FORMAT(' WARNING: FAILURE EXPECTED IN DIAGON,',I3,'.GT.MAXDI=',I3)
  300 FORMAT(/'   I(R) R( A,  B,   C,  D,  2LBD ) = SLATER-INTEGRALS',5X
     *,'A,B,C,D=1,2,3,..15: 1S,2S,2P,..5G-ORBITAL',8X,14HREFERENCE LIST)
  400 FORMAT(//36H   T, 2S  2L, (P - 0/2 FOR EVEN/ODD),7X,10HCF  NT  GR,
     * 19X,20H**** TERM TABLE ****)
  500 FORMAT(/ 32H   IOSC    T  TP,   B   D,   MNF)
  600 FORMAT(/131H   IOSC    T  TP,   B   D,   MNF, <T||CK||TP> = <T,ML|
     *CK|TP,MLP> / C(L,LP,K;ML,MLP) / SF, 2ML 2MLP     K; SF=(-1)**(LP-M
     *LP)/V(2K+1))
  700 FORMAT(I7, 2(I5,I4),I7, F13.5,2F19.5, 6X,2I4, 5X,1HE,I1)
  800 FORMAT( 38X, 83HNOT ENOUGH SLATER STATES STORED; CHANGE MODE TO -2
     * OR -1 IF RADIATIVE DATA REQUIRED)
  900 FORMAT(/50H *** PRINTING OF COEFFICIENTS BYPASSED -- MPRINT =,I3,
     * ' .LE. 0'/)
 1000 FORMAT(//' SR.ALGEB2: RADIATIVE CALCULATIONS SKIPPED'/12X,30(1H*))
C
C     E R R O R   M E S S A G E S
C
  91  PRINT 191, J
      IF (JOS)  94,99,10
  92  PRINT 192
      IF (JOS.GT.0)  GO TO 10
      IF (IRL.LE.IRLM)  GO TO 96
  93  PRINT 193
  96  IF (MPRINT.EQ.MG-1)  GO TO 90                                     UCL77FEB
      GO TO 99
  94  PRINT 194,  NCI, ND
  99  PRINT 190
      NF = 0
      RETURN
      END
      SUBROUTINE   FLGL( DC , QLMC,AM , DFS,MXS,MT,ME )                  FLGL
C
C     -- EXPANDS THE ENERGY MATRIX ELEMENT <CASL| H |C'A'SL>
C     IN TERMS OF TWO SORTS OF RADIAL INTEGRALS, EQ.1.6,7,8 IN E&N,
C     AND CALCULATES THE COEFFICIENTS AS DESCRIBED IN SECT.3.2 OF E&N
C
C     INPUT: KF,JA&JB ARE INDEX OF CONFIGURATION C, LOWEST AND HIGHEST
C      INDEX OF ITS SLATER STATES J; KG,JAP&JBP ARE ASSOCIATED WITH C';
C      DC(J+ND2) = VCC OF J'TH SLATERSTATE TO TERM SL(J=JA,JA+1,..JB)
C      DC(JD+NDP2)       JD                         (JD=JAP,JAP+1,..JBP)
C      AM(J)=TRUE FOR ALL SLST J WITH TOTAL MS,ML OTHER THAN CONSIDERED.
C      NF VALENCE ELECTRONS, NW CORE ELECTRONS.
C       2*ML , 2*MS OF I'TH ELECTRON IN J'TH SLATER STATE
C                   = QLMC(I,J)   + -1, IF QLMC EVEN
C                   = QLMC(I,J)-1 + +1, IF QLMC ODD
C      QCG(I,K) = G OF I'TH ELECTRON IN K'TH CONF; G=1,2,3.. FOR 1S,2S,
C      2P..  IF NOT REDEFINED, GENERALLY NK=QN(K),LK=QL(K)/2.
C       FOR THE CORE  NNL(I)=G, NNL(I+MAXCL)=QLMC AS ABOVE, (I=1,NW).
C     OUTPUT: COEFFICIENTS DRL(J) AND ARGUMENT-ADRESSES L=NRK(J) STORED
C      SEQUENTIALLY FROM IRK0 ONWARDS; ARGUMENTS QRL(1...5,L)=A,B,C,D,LD
C      TEMPORARILY LISTED IN NEW SECTION OF REF.-LIST FROM NRL00 ONWARDS
C      AT THE END ALL QRL THAT HAD PREVIOUSLY BEEN LISTED ARE CANCELLED.
C     QLMC(K,1) IS USED AS BUFFER (K=1,2,..NF.LE.ME),  AM(1) IS I/O.    UCL77AUG
C
cM    IMPLICIT INTEGER*2 (Q)
cS   C        ,INTEGER*2 (I-L,N)
      INTEGER   QLMC,Q1,Q3,Q4,QRL,QCG,QL,QN
      LOGICAL AM(MXS), BVC, EQCFS,EQTMS, SKP
cM    LOGICAL BVC, EQCFS,EQTMS, SKP                                     UCL77JAN
cM    LOGICAL*1 AM(MXS)
      DOUBLE PRECISION  DDH,DEY,DD,DSJ, DRK, DC, VCC,VCA,DFS
      PARAMETER (MXD31=4+1,MXD32=MXD31*MXD31, MXD13=78*3)
      DIMENSION  QLMC(ME,MXS), Q1(2,2),MM(2,2),Q3(2,2),Q4(2,2)
     1 , NEN(2,2),NEJ(2),NEK(2), MRL(5), DFS(MT)
     2 , QRL(5, 11000), DRK( 513000), NRK( 513000), DC(1750000)
      COMMON  MAXGR, NE, NEK, JA,JB, JAP,JBP, ND1,NDP1, ND2,NDP2, NF
     C /DBD2/ DEY(15),QCG(54, 60),QL(15),QN(15)
     C /CCLSH/NW,NNL(MXD13) /CFCT/ BVC,MXLL,VCA(MXD32,MXD32,MXD31)
     C /DXRL/ DRK, NRL,NRK, QRL  /NXRL/ NRLM, IRK,IRKM, IRK0
      EQUIVALENCE (KF,NEK(1)),(KG,NEK(2)) , (NEN(1,1),N1),(NEN(2,1),N2)
     *  , (MM(1,1),MJ11),(MM(1,2),MJ12), (MRL(5),ML)
      DATA MAXCL/78/
      MVC(M,MA) = ( (M+2)*M/2 + MA )/2 + 1
      SKP = MXLL.EQ.-1
      IRK0 = IRK + 1
      EQCFS = KG.EQ.KF
C
C     RETURN, IF CONFIG KF AND KG DIFFER IN MORE THAN TWO ELECTRONS
C
      IF (EQCFS)  GO TO 56
      DO 50  I=1,NF
  50   QLMC(I,1) = QCG(I,KG)
      K = 0
      DO 51  I=1,NF
       DO 52  L=1,NF
        IF (QLMC(L,1).NE.QCG(I,KF))  GO TO 52                           UCL77AUG
        QLMC(L,1) = 0
        GO TO 51
  52    CONTINUE
       K = K + 1
       IF (K.GT.2)  GO TO 90
  51   CONTINUE
C
C     COMPUTE COEFFICIENTS A AND B (SEE E+N SECTION 3.2, DO55 AND DO57
C                 ARE THE TWO SUMMATIONS OVER SLATER STATES IN EQ.3.17).
C
  56  NRL00 = NRL
CEVTL IF (AM(1))  NRL00 = 0
         DD = 1.
      EQTMS = NDP1.EQ.ND1
      DO 55  J=JA,JB
       IF (AM(J))  GO TO 55
       NEJ(1) = J
       IF (EQCFS)  JBP = J
       DO 57  JD=JAP,JBP
        IF (AM(JD))  GO TO 57
        DDH = DC(J+ND2) * DC(JD+NDP2)
        NEJ(2) = JD
        NK = 0
        NU = -NW
        IF (.NOT.EQCFS)  GO TO 66
        IF (JD.EQ.J)  GO TO 75
        DDH = DC(J+NDP2) * DC(JD+ND2) + DDH
  66    IF (NF.EQ.0)  GO TO 57
        IF (DDH.EQ.0.0)  GO TO 57
C       CALCULATE NK - THE NUMBER OF INDIVIDUAL SETS IN WHICH SLATER
C       STATE JD DIFFERS FROM J; THE PHASE FACTOR THAT RESULTS FROM
C       THE REMAINING NF-NK SETS WILL BE ABSORBED INTO DDH:
        MU = 0
        DO 58  I=1,NF
         DO 59  L=1,NF
          IF (QLMC(L,JD).NE.QLMC(I,J))  GO TO 59
          IF  (QCG(L,KG).NE.QCG(I,KF))  GO TO 59
          LP = L
          GO TO 58
  59      CONTINUE
         NK = NK+1
         IF (NK.GT.2)  GO TO 57
         NEN(1,NK) = I
         MU = I + MU
         LP = 0
  58     QLMC(I,1) = LP
        K = 0
        DO 60 L=1,NF
         DO 61 I=1,NF
          IF (QLMC(I,1).EQ.L)  GO TO 60                                 UCL77AUG
  61      CONTINUE
         K = K+1
         NEN(2,K) = L
         MU = L + MU
         IF (K.EQ.NK)  GO TO 74
  60     CONTINUE
  74    DDH = (1-2*MOD(MU,2))*DDH                                       UCL77MAR
C
        IF (NK.EQ.2)  GO TO 72
C       NOW NK=1, WHICH IMPLIES NDP1.NE.ND1
        ML = QCG(N1,KF)
        MU = QCG(N2,KG)
        IF (QL(MU).NE.QL(ML))  GO TO 75
        IF (.NOT.SKP)  DD = DDH                                         UCL77MAR
        IF (MU.LT.ML)  GO TO 86
        LP = ML
        ML = MU
        MU = LP
  86    MRL(1) = ML                                                     UCL75MAY
        MRL(2) = -0
        MRL(3) = MU
        MRL(4) = -0
        ML = - 1
        GO TO 87
  75    IF (DDH.EQ.0.0)  GO TO 57
        IF (EQTMS)  GO TO 68
        IF (.NOT.EQCFS)  GO TO 68
        NU = 0
  68    NU = NU + 1
        IF (NU.GT.NF)  GO TO 67                                         UCL77FEB
        NEN(1,2) = NU
        IF (NK.NE.0)  GO TO 71
        ND = NU
        IF (ND*NF.LT.0)  ND = 0
  69    ND = ND + 1
        IF (ND.GT.NF)  GO TO 68
        NEN(1,1) = ND
  71    IF (NEN(1,1).EQ.NEN(1,2))  GO TO 65
  72    DO 73  L=1,2
C               =1 FOR SLATER STATES J (OF CONFIG KF), =2 FOR JD (OF KG)UCL76FEB
         I = L
         DO 73  K=1,2
C                =1 FOR FOR FIRST PAIR OF ELECTRON STATES, =2 FOR SECONDUCL76FEB
          IF (NK.LT.K)  I = 1
          KP = NEN(I,K)
          IF (KP.GT.0)  GO TO 731
           KP = KP + NW
           LP = NNL(KP)
           MU = NNL(KP+MAXCL)
           GO TO 732
  731     LP = NEJ(I)
          MU = QLMC(KP,LP)
          LP = NEK(I)
          LP = QCG(KP,LP)
  732     ML = ( (QL(LP)+MU)/2 )*2 - QL(LP)
          Q4(L,K) = ( MU - ML )*2 - 1
          Q3(L,K) = ML
          MM(L,K) = QL(LP)
  73      Q1(L,K) = LP
        KP = 0
CEQU    MJ11 = Q2(1,1   )
CEQU    MJ12 = Q2(1,   2)
        MM11 = - Q3(1,1 )
        MM12 = - Q3(1,2 )
        MV11 = MVC(MJ11,MM11)
        MV12 = MVC(MJ12,MM12)
  77     IF (SKP)  GO TO 49                                             UCL77MAR
         IF (Q4(2,1+KP).NE.Q4(1,1))  GO TO 76
  49     MJ21 = MM(2,KP+1)
         MJ22 = MM(2,2-KP)
         MU = MIN(MJ11+MJ21,MJ12+MJ22)
         ML = MAX(ABS(MJ11-MJ21),ABS(MJ12-MJ22))
         IF (.NOT.EQTMS .AND. KP+NK+ML.EQ.0)  ML = 4
         IF (ML.GT.MU)  GO TO 76                                        UCL77MAR
         IF (SKP)  GO TO 48
         MM21 = Q3(2,KP+1)
         MMD1 = MM21 + MM11
         MM22 = Q3(2,2-KP)
         MMD2 = MM12 + MM22
         K = MAX(ABS(MMD1),ABS(MMD2))
         IF (K.GT.ML)  ML = ((K+2-ML)/4)*4 + ML
        IF (ML.GT.MU)  GO TO 76
        DSJ =  SQRT(REAL((MJ11+1)*(MJ12+1)*(MJ21+1)*(MJ22+1)))*REAL(
     *         (1-MOD(ABS(MM22-MM11),4)) * (1-2*KP)) * DDH
        MV21 = MVC(MJ21,MM21)
        MV22 = MVC(MJ22,MM22)
C       REORDER A,B,C,D IN AS MUCH FALLING ORDER AS SYMMETRY ALLOWS FOR  FLGL
  48    L = 0
        K = 0
        IF ( Q1(2,2-KP).GT.Q1(1,2) )  K = 2
        I = 0
        IF ( Q1(2,1+KP).GT.Q1(1,1) )  I = 2
  62    MRL(1+I+L) = Q1(1,1)
        MRL(3-I+L) = Q1(2,1+KP)
        MRL(2+K-L) = Q1(1,2)
        MRL(4-K-L) = Q1(2,2-KP)
        L = 1
        IF (MRL(2).GT.MRL(1))  GO TO 62
C
  78     LP = ML/4 + 1
         IF (SKP)  GO TO 87                                             UCL77JAN
         IF (BVC)  GO TO 41
          IF (MJ11.GT.MXLL)  GO TO 42
          IF (MJ21.GT.MXLL)  GO TO 42
  41     DD = VCA(MV11,MV21,LP)
         IF (BVC)  GO TO 44
         GO TO 43
  42      DD =   VCC( MJ11,MJ21,ML,   0, 0, 0,  DFS,MT ) / (ML+1)        FLGL
     *         * VCC( MJ11,MJ21,ML, MM11,MM21,MMD1, DFS,MT )
  43      IF (MJ22.GT.MXLL)  GO TO 45
          IF (MJ12.GT.MXLL)  GO TO 45
  44     DD = VCA(MV22,MV12,LP) * DD
         GO TO 80
  45      DD =   VCC( MJ22,MJ12,ML,   0, 0, 0,  DFS,MT ) / (ML+1)
     *         * VCC( MJ22,MJ12,ML, MM22,MM12,MMD2, DFS,MT ) * DD        FLGL
  80     IF (DD.EQ.0.0)  GO TO 70
         DD = DD*DSJ
  87     L = NRL00+1
CEQU     MRL(5) = ML
         IF (NRL.LT.L)  GO TO 81
  53     DO 63  I=L,NRL
          DO 64  K=1,5
           IF (MRL(K).NE.QRL(K,I))  GO TO 63
  64       CONTINUE
          LP = I
          IF (IRK.LT.IRK0)  GO TO 82
          DO 83  K=IRK0,IRK
           IF (NRK(K).NE.LP)  GO TO 83
           DRK(K) = DD + DRK(K)
           GO TO 84
  83       CONTINUE
          GO TO 82
  63      CONTINUE
  81     LP = NRL+1
         NRL = LP
CEXT     IF (LP.GT.NRLM)  RETURN
         IF (LP.LE.NRLM)  GO TO 54      ! EXT75MAY
         IF (L.EQ.1)  GO TO 90
         AM(1) = .TRUE.                 ! UCL77AUG
C        TRY WITHOUT BUFFER SPACE IN QRL (COSTS MORE SEARCHING TIME):
         L = 1
         NRL = LP-1
         GO TO 53
  54     DO 79  K=1,5
  79      QRL(K,LP) = MRL(K)
  82     IRK = IRK + 1
         IF (IRK.GT.IRKM)  GO TO 90
         DRK(IRK) = DD
         NRK(IRK) = LP
  84     IF (ML.LT.0)  GO TO 68
CTEST    PRINT '(4I5,4I3,F12.5)',  J,JD,LP, MRL,DD
  70     ML = ML + 4
         IF (ML.LE.MU)  GO TO 78
  76     KP = KP + 1
         IF (KP.EQ.1)  GO TO 77
  65    IF (NK-1)  69,68,67             ! UCL77FEB
C
  67    IF (.NOT.SKP)  GO TO 57         ! UCL77FEB
        IF (EQTMS)  GO TO 89            ! UCL77MAR
        GO TO 55
  57    CONTINUE
  55   CONTINUE
C
C
C     ELIMINATE COEFFICIENTS /DRL/.LT.1.E-7 AND ARGUMENTS QRL THAT HAVE
C     BEEN LISTED BEFORE IN THE REFERENCE LIST
C
      IF (IRK.LT.IRK0)  GO TO 90
  89  K = IRK0-1
      KP = 0
      DO 91  I=IRK0,IRK
       JD = NRK(I)
cP     IF (ABS(DRK(I)).GE.1.E-6)  GO TO 97
       IF (DABS(DRK(I)).GE.1.E-7)  GO TO 97
       IF (JD.GT.NRL00)  KP = KP+1
       GO TO 91
  97   K = K + 1
       DRK(K) = DRK(I)
       LP = JD
       IF (JD.LE.NRL00)  GO TO 92
       LP = JD-KP
       IF (NRL00.EQ.0)  GO TO 94
       DO 95  L=1,NRL00
        DO 96  J=1,5
         IF (QRL(J,JD).NE.QRL(J,L))  GO TO 95
  96     CONTINUE
        KP = KP+1
        LP = L
        GO TO 92
  95    CONTINUE
  94   DO 93  J=1,5
  93    QRL(J,LP) = QRL(J,JD)
  92   NRK(K) = LP
  91   CONTINUE
      NRL = NRL-KP
      IRK = K
  90  RETURN
      END
      SUBROUTINE ALGEB3(DC,QLML,QBML,QBMS,JYI,JYF,MAXST,MAXEL)
C      -- DEALS WITH THE CALCULATION  OF THE ALGEBRA OF THE FINE
C      STRUCTURE INTERACTIONS (SPIN-ORBIT,RESIDUAL MUTUAL-SPIN-ORBIT AND
C      SPIN-SPIN).
cM    IMPLICIT INTEGER*2 (Q)
cS   C        ,INTEGER*2 (I-L,N)
      INTEGER QLML,QBML,QBMS,QLI,QSI,QPI,QRLP,QSS,QMCL,QMCS
      INTEGER SJ,LJ,JACT,QMJ,QML,QMS, KUTSS
      LOGICAL LF,BVC,LX
      DOUBLE PRECISION DVC,VCB,DC,DFS,DD, DRKP, VCC,DVCL1, VCA,DA
      PARAMETER (MXD31=4+1, MXD32=MXD31*MXD31)
      DIMENSION QLML(MAXEL,MAXST), QBML(MAXST), QBMS(MAXST), DC(1750000)
     1 , JYI( 60), JYF( 60), NAM( 19000)
      COMMON  MAXGR, NF, KF,KG, J1,J2,J1P,J2P, IRS0,MQSS, DSS(500000),
     *   MSS(500000),QSS(5, 5000),NL,NSMAX,IRS,IRSM,NADR(523000)
     * /NXRL/ IRLSO,IRK,IRKSO,IRK0   /OUTP/MPRINT,KUTSS,MKUT,LCUT(3)
     C /TERMS/ KM,NSL0, NSL( 60),NFI(1225),NFK(1225),
     *    NFQ(1225),NAD(0: 61500),QPI( 60),QSI( 60),QLI( 60)
     C /MQVC/ MAXDC,MD,KCUT,QMCL,QMCS,NEL(15, 60)
     C /QTG/ MTGD,NXLL,NTG(0: 60),JTGD(1225)
     X     ,QCP( 60),QTGS(1725),QTGL(1725),QTGD(1725)
     C /JSPOR/ NJO,NRR(3100),NT(  38),JJ(3100),NGR(3100)
     C /COEFF/ DRKP( 550000),QRLP(2,5500),IRLP,NRKP( 550000),NJD(523000)
     C /COMRES/ DVCL1,JACT,QMJ,MJL1,MJS1, NJ2,NJP2, LX,NRL00,NL00, MXLL,
     C   VCA(MXD32,MXD32,MXD31), VCB(MXD32,MXD32,MXD31), BVC
      COMMON /COMFAC/DFS( 64),MAXD
      DATA MAXD/ 64/, LEVEN,MEVEN,LODD,MODD/1H+,4HEVEN,1H-,4H ODD/,
     * MAXLV,MAXDK,MXADJ,MAXJG,MAXLL/3100,572,523000,  38,4/
  67  FORMAT(//' SR.ALGEB3:  TOO MANY LEVELS,',I5,10H.GT.MAXLV=,I4,
     * 28H - OR TOO MANY (J,P) GROUPS,,I4,10H.GT.MAXJG=,I3)   ! UCL76/99
  77  FORMAT(50H SIZE OF AN SLJ SUBMATRIX  TOO LARGE IN SR.ALGEB3,, I5,
     C 10H.GT.MAXDK=,I4,30H. MAY FAIL LATER IN SR.DIAGFS./)   ! RUB99OCT
 100  FORMAT(/97H NOT ENOUGH VCC'S AVAILABLE FOR CALCULATION OF RELATIVI
     *STIC CORRECTIONS: CHANGE MODE TO 1,-1 OR 0)
 180  FORMAT(4I5,A1,2I5)
 181  FORMAT(34X,7HJGROUP=,I2,7H:   2J=,I2,3X,A4,7H PARITY,I6,7H LEVELS)
 244  FORMAT(I5,':',7X,4I5,I7)
 245  FORMAT(51X,I5,':',4X,4I5,I7)
  400 FORMAT(//31X,24H**** LIST OF LEVELS ****/
     C        /31H   LV   2S   2L   2J    CF   IT)
  110 FORMAT(3I6,I7,I6,(T32,I6,F12.6))
  130 FORMAT(3I6,I7,I6,45X,2I6)
 1202 FORMAT(57X,3I6,I7,I6,(T89,3(I5,F9.4)))
 1203 FORMAT(/' STORAGE EXCEEDED IN SR.RES: INCREASE  * MXRSS OR MAXMI')
 1210 FORMAT(/' STORAGE EXCEEDED IN SR.SPOR: AUGMENT  * MXSOC OR MXSOI')
 2001 FORMAT(//36H SPIN-ORBIT PARAMETER REFERENCE LIST/5H I(Z),7X,
     C 40HZETA(     A    B)= SPIN-ORBIT PARAMETERS/ (I5,13X,2I5))
 2011 FORMAT(//45H REFERENCE LIST OF MAGNETIC INTEGRALS N AND V
     C        /6H INDEX,5X,34HN(    A    B    C    D   2LBD+200),7X,
     C 5HINDEX,2X,34HV(    A    B    C    D   2LBD+100))      ! 80/03/08
 3050 FORMAT(//6X,37HALGEBRA OF THE SPIN-ORBIT INTERACTION,15X,
     C 43HALGEBRA OF THE SPIN-SPIN, MUTUAL SPIN-ORBIT/68X,
     C 33HAND SPIN-OTHER-ORBIT INTERACTIONS, 6X,7HKUTSS =,I3,1H(,I2,1H)/
     *31H MXADJ MAXLV MAXLV  MXSOC MXSOI,27X,30HMXADJ MAXLV MAXLV  MXRSS
     * MAXMI/3I6,I7,I6,4X,20HSTORAGE RESTRICTIONS,2X,3I6,I7,I6/4X,2HNP,
     * 4X,2HLV,3X,3HLVP,5X,2HCN,3X,3HIND,2X,4HI(Z),6X,6HC(A,B),12X,2HNP,
     * 4X,2HLV,3X,3HLVP,5X,2HCN,3X,3HIND,2(3X,11HI(Y) X(A-D)),5H ....)
 3055 FORMAT( /59H STORAGE EXCEEDED IN ALGEB3: NUMBER OF MATRIX ELEMENTS
     * NP =,I7,10H.GE.MXADJ=,I6/29X,'BP CALCULATION WILL BE SKIPPED')
 3056 FORMAT(//68H *** PRINTOUT OF COEFFICIENTS C, D AND E SUPPRESSED BY
     * MPRINT .LE. 0)
      MVC(MLX,MLY) = ((MLX+2)*MLX/2 + MLY)/2 + 1
C     IF IABS(MD).GT.1 NOT ENOUGH VCC'S ARE  AVAILABLE FOR CALCULATING
C     FINESTRUCTURE INTERACTIONS.
      NJO = 0
      IF(ABS(MD).GT.1) GO TO 101
      IRSM=500000
      IRKSO= 550000
      NSMAX= 5000
      IRLSO=5500
      NP = 0
      LF = .FALSE.
C     THE FOLLOWING SECTION SETS UP THE STATES ACCORDING TO THEIR
C     J-VALUES: J = TOTAL ANGULAR MOMENTUM.
      PRINT 400
      NCI = NTG(KM)
      NJJ = 0
      JACT = QMCL+QMCS
  69   KPI = 0
  70    N0 = 0
        IF(KPI.EQ.0) THEN
         LPAR=LEVEN
         MPAR=MEVEN
        ELSE
         LPAR=LODD
         MPAR=MODD
        ENDIF
C       DO LOOP TO FIND NUMBER OF LEVELS WHICH CAN RESULT IN GIVEN J
        DO 63 IT = 1,NCI
         I = NFQ(IT)
         LJ = QLI(I)
         SJ = QSI(I)
         IF (QPI(I).NE.KPI)  GO TO 63
         IF (ABS(LJ-SJ).GT.JACT .OR. LJ+SJ.LT.JACT) GO TO 63
C        NDJ IS A VARIABLE WHICH IS THESAME FOR ALL LEVELS GIVING SAME J
         NDJ = NJO+1
         NJJ = NJJ+1
         N0 = N0 +1
         KG = NFK(IT)                                          ! JORG 38
         IF (MPRINT.GE.-1)  PRINT  180, NJJ,SJ,LJ,JACT,LPAR, KG,IT
         LF = LF.OR.NJJ.GT.MAXLV
         IF(LF) GO TO 63
         NRR(NJJ) = IT
         JJ(NJJ)=JACT
         NGR(NJJ)=NDJ
 63      CONTINUE                                              ! JORG 40
         IF (N0.EQ.0) GO TO 68
         NJO = NDJ
         NP = ((N0+1)*N0)/2 + NP
         PRINT 181, NDJ, JACT,MPAR, N0
         IF (MPRINT.GE.0) PRINT 180
         IF (N0.GT.MAXDK) PRINT 77, N0,MAXDK
         LF = LF.OR.NJO.GT.MAXJG
         IF (LF) GO TO 68
         NT(NDJ) = N0
 68     KPI = KPI+2
        IF(KPI.EQ.2) GO TO 70
       JACT = JACT-2
       IF(JACT.GE.0) GO TO 69
         IF(.NOT.LF) GO TO 76
         PRINT 67,NJJ,MAXLV,NJO,MAXJG
  76     IF(NP.LT.MXADJ) GO TO 66                              !*DIPOLE*
         PRINT 3055,NP,MXADJ
         GO TO 90
  66  IF (LF)  GO TO 90
      NDJ = NP                                                 !   77OCT
      IF(MPRINT.LT.0) PRINT '(66X,I6,8H IN ALL.)', NJJ
C
C     CALCULATE ALGEBRAIC COEFFICIENTS DLBD AND STORE THEM IN ARRAY VCB
C     (AND RECOMPUTE VCA, SEE ALGEB2); COEFFICIENTS DLBD HAVE THE FORM
C         C(L1,L2,L,0,0,0)*C(L1,L2,KT,ML1,ML2,MLK), WHERE KT = L+1 AND
C     MLK = ML1+ML2, AND WHERE THE C'S ARE CLEBSCH-GORDAN COEFFICIENTS.
      MXLL = NXLL
      IF (MXLL.LT.0)  GO TO 50                                ! UCL77FEB
      BVC = MXLL.LE.2*MAXLL
      IF (.NOT.BVC)  MXLL = 2*MAXLL
      M1 = 0
  46   M2 = 0
  45    MK = ABS(M1-M2)
  44     MKT = MK+2
         DVC = VCC(M1,M2,MK,0,0,0,DFS,MAXD)                   ! EINU1128
         ML1 = -M1
  42      MB1 = MVC(M1,ML1)
          ML2 = -M2
  43       MB2 = MVC(M2,ML2)
           DA = 0.0
           DD = 0.0
           MLK = ML1 + ML2
           IF (ABS(MLK).GT.MKT)  GO TO 47
           DD = VCC(M1,M2,MKT,ML1,ML2,MLK, DFS,MAXD) * DVC
           IF (ABS(MLK).GT.MK)  GO TO 47
           DA = (VCC(M1,M2,MK, ML1,ML2,MLK, DFS,MAXD)/(MK+1)) * DVC
  47       MLK = MK/4 + 1
           VCA(MB1,MB2,MLK) = DA
           VCB(MB1,MB2,MLK) = DD
           ML2 = ML2 + 2
           IF (ML2.LE.M2)  GO TO 43
          ML1 = ML1 + 2
          IF (ML1.LE.M1)  GO TO 42
         MK = MK + 4
         IF (MK.LE.M1+M2)  GO TO 44
        M2 = M2 + 2
        IF (M2.LE.MXLL)  GO TO 45
       M1 = M1 + 2
       IF (M1.LE.MXLL)  GO TO 46                              ! EINU1147
C
C        CALCULATE THE ALGEBRA OF THE FINESTRUCTURE INTERACTIONS, I.E.
C        THE COEFFICIENTS C,D,AND E.
  50   IF (MPRINT.LE.0)  PRINT 3056                           ! UCL76SEP
       KPI = 0
       MKT = KUTSS
       IF(KUTSS.EQ.0) MKT=KCUT                                ! '87JUN12
       IF(KUTSS.EQ.0.AND.KCUT.LE.0) MKT=KM
       IF(KUTSS.EQ.-9) MKT=-KM                                ! QUB88FEB
       IF(KUTSS.EQ.-1) MKT=0
       PRINT 3050, MKT,KUTSS, MXADJ, MAXLV, MAXLV, IRKSO, IRLSO,
     *                        MXADJ, MAXLV, MAXLV,  IRSM, NSMAX
      NL=0
      NCJ=0
      IRK=0
      IRS = 0
      IRLP=0
      NP=0
      J1 = 2
      DO 103 K=1,NJO
       N0 = NT(K)
C      N0 IS THE NUMBER OF LEVELS IN A GIVEN BLOCK HAVING THE SAME J VAL
       DO 115 NJ1=1,N0
        NJ=NJ1+NCJ
        IT=NRR(NJ)
        JACT=JJ(NJ)
C       QMJ = TWICE AZIMUTHAL COMPONENT OF J
        QMJ = JACT
        IF (MD.GT.0)  QMJ = JACT - (JACT/2)*2
        MACT = JACT
        KF=NFK(IT)
        JA = JYI(KF)
        JB = JYF(KF)
        NDJ = NDJ+1
        IF (NDJ.LE.MXADJ)  NJD(NDJ) = -N0
        I = NFI(IT)
        NJ2 = JTGD(I)
        I = NFQ(IT)
        LJ = QLI(I)
        SJ = QSI(I)
        DO 114 NJP1=1,NJ1
         NJG=NJP1+NCJ
         ITP=NRR(NJG)
         KG=NFK(ITP)
         NP = NP+1
C        FIND NUMBER MK/2 OF ELECTRON PAIRS IN WHICH CONFIG'S DIFFER
         MK = 0
         DO 580 I=1,MAXGR
          MLK = NEL(I,KG)-NEL(I,KF)
          MK = ABS(MLK) + MK
          IF (MK-4)  580,590,113
  590     IF (MKT.GE.0)  GO TO 113                        ! UCL75MAR
  580     CONTINUE
         IRK0=IRK+1
         NRL00=IRLP
         IRS0=IRS+1
         NL00=NL
         I = NFI(ITP)
         NJP2=JTGD(I)
         JAP = JYI(KG)
         JBP = JYF(KG)
         I = NFQ(ITP)
         MJL1=QLI(I)
         MJS1=QSI(I)
         IF (MJS1+SJ.EQ.0)  GO TO 113
         IF (MJL1+LJ.EQ.0)  GO TO 113
         QMS = SJ
 611   QML = QMJ-QMS
       LX = QMS.NE.-SJ .AND. QML.NE.LJ
       IF (QML.LT.-LJ)  GO TO 616                         ! UCL75JAN
C      NAM(I) IS CONSTRUCTED SO THAT IT CAN BE USED TO SELECT INITIAL
C                   AND FINAL STATES HAVING THE CORRECT ML,MS.
       J2 = 1
       DO 602 I=JA,JB
        IF (QBML(I).NE.QML .OR. QBMS(I).NE.QMS) GO TO 602 !! LOG OUT
        J2 = J2+1
        NAM(J2) = I
 602    CONTINUE
       IF (J2.LT.J1)  GO TO 616
       DVCL1 = VCC(LJ,SJ,JACT,QML,QMS,QMJ,DFS,MAXD)       ! SPOR
       J2P = J2
       DO 612 I=JAP,JBP
        IF (QBML(I)+QBMS(I).NE.QMJ)  GO TO 612            !! LOG OUT
        IF (ABS(QBMS(I)-QMS)-2)  603,604,612
 603    IF (MK.EQ.0)  GO TO 612
 604    J2P = J2P+1
        NAM(J2P) = I
 612    CONTINUE
C      CALCULATE THE ALGEBRAIC CONTRIBUTION TO THE MATRIX ELEMENT.
       J1P = J2+1
       IF (MK-2)  605,606,613
 605   J1P = 2
 606   IF (J2P.LT.J1P)  GO TO 613
       IF ((IRK+1-IRK0)*NXLL.LT.0)  GO TO 621             ! UCL77FEB
       CALL SPOR(DC,QLML,QBML,QBMS,DFS,MAXST,MAXD,MAXEL,NAM,KPI)
C      SR.SPOR RETURNS A NEGATIVE ERROR PARAMETER KPI IF DIMENSIONS
C      MXSOC AND/OR IRLSO EXCEEDED.
       IF(KPI.NE.0) GO TO 619
 621   IF (NF.EQ.1)  GO TO 616                            ! UCL77FEB
 613   IF (MKT.LT.0)  GO TO 614                           ! 75MR88FE
       IF (MK.NE.0)  GO TO 616
C      MATRIX ELEMENTS OF RESIDUAL MUTUAL SPIN-ORBIT AND SPIN-SPIN
C      INTERACTIONS BETWEEN DIFFERENT CONFIGURATIONS ARE NEGLECTED.
 614   IF (KF.GT.ABS(MKT))  GO TO 616
       IF (KG.GT.ABS(MKT))  GO TO 616
       DO 622 I=JAP,JBP
        IF (QBML(I)+QBMS(I).NE.QMJ)  GO TO 622            !! LOG OUT
        IF (ABS(QBMS(I)-QMS).NE.4)  GO TO 622
        J2P = J2P+1
        NAM(J2P) = I
 622    CONTINUE
       IF (J2P.LT.J1P)  GO TO 616
       IF ((IRS+1-IRS0)*NXLL.LT.0)  GO TO 616             ! UCL77FEB
       CALL RES(DC,QLML,QBML,QBMS,DFS,MAXST,MAXD,MAXEL,NAM,KPI) !LOG OUT
       IF(KPI.NE.0) GO TO 619
 616   QMS=QMS-2
       IF (LX)  GO TO 611
C      IF LX=.TRUE. THE TRANSFORMATION TO THE J,MJ REPRESENTATION IS NOT
C      YET COMPLETE.
         IF (MPRINT.LE.0) GO TO 113
C        PRINT THE ALGEBRAIC COEFFICIENTS OF THE SPIN-ORBIT
C        MATRIX ELEMENT UNLESS THEY ARE ZERO
         IF(IRK.LT.IRK0) GO TO 617
         PRINT 110,  NP,NJ,NJG,IRK,IRLP, (NRKP(I),DRKP(I),I=IRK0,IRK)
 617     IF(IRS.LT.IRS0) GO TO 113
         PRINT 1202,  NP,NJ,NJG,IRS,NL,  (MSS(I),DSS(I),I=IRS0,IRS)
 113     NJD(NP)=IRK
C        NJD IS THE ADDRESS ARRAY WHICH GIVES THE POSITION OF THE LAST
C        SPIN-ORBIT PARAMETER ASSOCIATED WITH AN M.E. (J,MJ|SO|JP,MJP).
 114     NADR(NP)=IRS
        IF (MPRINT) 618,619,115
 618    IF (MOD(NJ+0,25).NE.0 .AND. NJ.NE.NJJ) GO TO 115
 619    PRINT 130, NP,NJ,NJG, IRK,IRLP, IRS,NL
        IF(KPI) 99,115,991
 115    CONTINUE
 103   NCJ = N0+NCJ
      QBML(1) = NCJ
      MQSS = NP
C
      IF (MPRINT.LE.0) GO TO 620
       IF (IRLP.LE.0)  GO TO 620
C      NUMBER THE SPIN-ORBIT PARAMETERS BY LABELLING THEIR ARGUMENTS
       PRINT 2001,  (L,(QRLP(K,L),K=1,2),L=1,IRLP)        ! UCL76SEP
       IF (NL.LE.0)  GO TO 620
       PRINT 2011
       DO 692 L=1,NL
        IF (QSS(5,L).LE.197) GO TO 682                    ! 80/03/08
        PRINT 244,  L,(QSS(K,L),K=1,5)
        GO TO 692
 682    PRINT 245,  L,(QSS(K,L),K=1,5)
 692    CONTINUE
       GO TO 620
C
 101  PRINT 100
      GO TO 620
  99  PRINT 1210
      GO TO 90
  991 PRINT 1203
  90  NJO = -1                                            ! UCL75JUL
 620  RETURN
      END
      SUBROUTINE SPOR(DC,QLMC,QBML,QBMS,DFS,MXS,MT,ME,NAM,IZY)
C     -- EVALUATES ALGEBRAIC CONTRIBUTIONS TO THE SPIN-ORBIT MATRIX
C     ELEMENTS.
cM    IMPLICIT INTEGER*2 (Q)
cS   C        ,INTEGER*2 (I-L,N)
      LOGICAL  LX, BVX
      INTEGER JACT,QMJ
      INTEGER QBMS,QBML,QCG,QN,QL,QRLP,QLMC,QLML1,QLMS1
      DOUBLE PRECISION DC,DEY,DFS, DVCL1,DVC,DDH,DD, DRKP, VCC, VCX
      PARAMETER (MXD31=4+1,MXD32=MXD31*MXD31)
      DIMENSION QLMC(ME,MXS),QBML(MXS),QBMS(MXS), DC(1),DFS(MT),NAM(MXS)
      COMMON MAXGR,NF,KF,KG,JA,JB,JAP,JBP     /NXRL/ IRLM,IRK,IRKM,IRK0
     C /COMRES/ DVCL1,JACT,QMJ,MJL1,MJS1, NJ2,NJP2, LX,NRL00, NL00,MXLL,
     C   VCX(MXD32,MXD32,MXD31,2), BVX
     C /COEFF/ DRKP( 550000),QRLP(2,5500),IRLP,NRKP( 550000),NXX(523000)
     C /DBD2/ DEY(15),QCG(54, 60),QL(15),QN(15)
      NRL01=NRL00+1
      MML1 = 1
C
C      IN LOOPS 64,65 SCAN THROUGH SLATER STATES IN INITIAL AND
C      FINAL STATES RESP., AND CALCULATE CONTRIBUTIONS DUE TO EACH PAIR
       DO 64 J1=JA,JB
        L1 = NAM(J1)
       DO 65 J2=JAP,JBP
        L2 = NAM(J2)
       IF (QBML(L2).EQ.MML1)  GO TO 68
       MML1=QBML(L2)
       MAUX=QBMS(L2)
       DVC = VCC(MJL1,MJS1,JACT,MML1,MAUX,QMJ, DFS,MT) * DVCL1
C      CALCULATE TRANSFORMATION COEFFICIENT
C       FROM THE LS,ML,MS REPRESENTATION TO THE J,MJ REPRESENTATION
  68   DDH = DC(L1+NJ2)*DC(L2+NJP2) * DVC
       IF (ABS(DDH).LT.1.E-8) GO TO 65
       NK = 0
        N1 = 0
        IF (L2.EQ.L1)  GO TO 88
C       DIAGONAL ELEMENTS ARE TREATED IN STATEMENTS 88+, 87-, 85+.
C
C       NOW COMPARE INITIAL AND FINAL SLATERSTATES AND SELECT ONLY THE
C       ONES WHICH DIFFER IN ONE SET OF QUANTUM NUMBERS
        DO 66 ICG2=1,NF
         N1 = ICG2+N1
         DO 67 ICG1=1,NF
          IF (QLMC(ICG1,L1).NE.QLMC(ICG2,L2))  GO TO 67
          IF (QCG(ICG1,KF).NE.QCG(ICG2,KG))  GO TO 67
          N1 = N1-ICG1
          GO TO 66
  67      CONTINUE
         IF (NK.NE.0)  GO TO 65
C        SLATER STATES L1 AND L2 DIFFER IN MORE THAN NK=1 ELECTRON PAIR.
         NK = 1
         N2 = ICG2
  66     CONTINUE
C       L1 AND L2 DIFFER IN ONE PAIR, IN POSITIONS NUMBERED N1 AND N2
        GO TO 87
C
  88    N1 = N1+1
        IF (N1.GT.NF)  GO TO 69                                         UCL77FEB
C       N2 = N1
  87    ICG1 = QCG(N1,KF)
        LP = QL(ICG1)
        IF (LP.EQ.0)  GO TO 82
C      S-STATES GIVE NO SPIN-ORBIT CONTRIBUTIONS.
C     FIND THE AZIMUTHAL COMPONENTS OF L AND S FOR THE INDIVIDUAL ELECT- SPOR
C      -RONS,WHOSE NUMBERS ARE N1,N2.
       MAUX = QLMC(N1,L1)
       QLML1 = ((MAUX+100)/2)*2-100
       QLMS1 = (MAUX-QLML1)*2-1
       DD = QLMS1*QLML1
       ICG2 = ICG1
       IF (NK.EQ.0)  GO TO 85
       ICG2 = QCG(N2,KG)
       IF (QL(ICG2).NE.LP)  GO TO 65
C      M.E. IS ZERO IF THE L-VALUES OF THE TWO ELECTRONS DIFFER.
       IF (QLMC(N2,L2).EQ.MAUX)  GO TO 86
C      NOW PROCEED FOR (L+).(S-) OR (L-).(S+) RATHER THAN (L0).(S0)
C      QLML2=((100+QLMC(N2,L2))/2)*2 -100
C      QLMS2=(QLMC(N2,L2)-QLML2)*2-1
C      QLMS2+QLML2 = QLMS1+QLML1 FOR NK=0,1
       MAUX = QLMS1+QLML1
       DD =  SQRT(REAL((LP-MAUX+1)*(LP+MAUX+1)))
  86   IF (((N1+N2)/2)*2.NE.N1+N2)  DD = -DD
       IF (ICG2.LE.ICG1)  GO TO 85
       MAUX = ICG2
       ICG2 = ICG1
       ICG1 = MAUX
C
  85   DD = DDH*DD/4.
       IF (MXLL.EQ.-1)  DD = 1.                                         *TRYOUT*
       L=IRLP+1
       IF (L.LE.NRL01)  GO TO 81                                        UCL77FEB
C      IN STATEMENT 81 IRLP IS INCREASED BY 1
       DO 72 J=NRL01,IRLP
       IF (QRLP(1,J).NE.ICG1)  GO TO 72
       IF (QRLP(2,J).NE.ICG2)  GO TO 72
       DO 83 K=IRK0,IRK
       IF(NRKP(K).NE.J) GO TO 83
       DRKP(K) = DRKP(K)+DD
       GO TO 82
 83    CONTINUE
       GO TO 81
 72     CONTINUE
C      CANNOT FIND AN OLD SET OF ARGUMENTS EQUAL TO THE NEW SET, SO
C     MUST START CONSTRUCTING A NEW COEFFICIENT
 81   IRLP = L
       IRK = IRK+1
       IF(IRK.GT.IRKM) GO TO 1
       IF(L.GT.IRLM) GO TO 1
       QRLP(1,L) = ICG1
       QRLP(2,L) = ICG2
       NRKP(IRK) = L
       DRKP(IRK)=DD
  82   IF (NK.EQ.0)  GO TO 88
C      NK.EQ.1 FOR STATES WHICH DIFFER IN ONE SET OF ONE-ELECTRON
C      QUANTUM NOS, THE NECESSARY TERM HAS ALREADY BEEN EVALUATED,
C      THEREFORE PROCEED TO NEXT PAIR OF SLATER STATES.
  69   IF (MXLL.NE.-1)  GO TO 65
       IF (IRK.GE.IRK0)  GO TO 89                                       UCL77FEB
   65  CONTINUE
 64    CONTINUE
C      IF THE COEFFICIENTS OF THE SPIN-ORBIT PARAMETERS IN THE MATRIX
C      ELEMENT HAVE NOT BEEN COMPLETELY CALCULATED RETURN - SPOR WILL
C      BE CALLED AGAIN, FOR DIFFERENT (MS,ML) GIVING THE SAME MS+ML=QMJ.
        IF(LX) RETURN
C
C      IF THE MATRIX ELEMENT HAS BEEN CALCULATED CLEAR THE ARRAY  DRKP
C      OF ZEROS AND ADJUST NRKP.
      IF (IRK.LT.IRK0)  RETURN
  89  K = IRK0-1
      N1 = 0
      DO 90 I=IRK0,IRK
cP     IF ( ABS(DRKP(I)).LT.1.0E-5)   GO TO 90
       IF (DABS(DRKP(I)).LT.1.0E-6)   GO TO 90
       K = K+1
       DRKP(K) = DRKP(I)
       N2 = NRKP(I)
       LP = N2-N1
       IF (NRL00.EQ.0)  GO TO 93
       DO 94 L=1,NRL00
        DO 95 J=1,2
         IF (QRLP(J,N2).NE.QRLP(J,L))  GO TO 94
  95     CONTINUE
        LP = L
        GO TO 91
  94    CONTINUE
  93   N1 = N1-1
       DO 92 J=1,2
  92    QRLP(J,LP) = QRLP(J,N2)
  91   NRKP(K) = LP
  90   N1 = N1+1
      IRLP = IRLP-N1
      IRK = K
      RETURN
C
 1    IZY = -1
      RETURN
      END
      SUBROUTINE RES(DC,QLML,QBML,QBMS,DFS,MXS,MT,ME,NAM, IZX)
C     --- CALCULATES ALGEBRA OF THE MATRIX ELEMENTS OF THE SPIN-SPIN,
C      MUTUAL SPIN-ORBIT AND SPIN-OTHER ORBIT INTERACTION
C      BETWEEN A PAIR OF STATES OF THE TYPE |CBSLJ MJ), WHERE C =
C      CONFIGURATION, B = DEGENERACY PARAMETER OF TERM S,L AND J, MJ =
C      TOTAL ANGULAR MOMENTUM AND ITS AZIMUTHAL COMPONENT.   ROUTINE
C      WRITTEN BY MICHAEL JONES.  REFERENCES: JONES,M., J.PHYS.B:ATOM.
C      MOLEC.PHYS. VOL. 4(1971),
cM    IMPLICIT INTEGER*2(Q)
cS   C        ,INTEGER*2(I-L,N)
      INTEGER  QMJ, QLML,QBML,QBMS,QCG,Q1,Q2,Q3,Q4,QL,QSS
cM    INTEGER JACT,L1,L2,L3,L4,QMJ
      LOGICAL LN,LH,LOG,LK,LMM,BVC,LX, SKP,SPN
      DOUBLE PRECISION DDR,DDR1,DDR2,DVCL1,DFS,VCA,VCB,VCC,
     C    VC,VK,DDH,DC,DSJ,DD1,DV1,DV2,DV3,DD, DEY
      PARAMETER (MXD31=4+1,MXD32=MXD31*MXD31)
      DIMENSION QLML(ME,MXS), DC(1), QCG(54, 60), NEN(2,2)
     C , NES(2), QN(15), QL(15), DFS(MT), DSS(500000)
     C , MSS(500000), QSS(5, 5000), NAM(MXS), VK(2,3), JSS(4)
     C , Q1(2,2), Q2(2,2), Q3(2,2), Q4(2,2), QBML(MXS), QBMS(MXS), VC(2)
      COMMON MAXGR,NF,NEK(2),JA,JB,JAP,JBP, IRS0,MGAP,
     C   DSS,MSS,QSS,NL,NSMAX,IRS,IRSM  /DBD2/ DEY(15),QCG,QL,QN
     C /COMRES/ DVCL1,JACT,QMJ,MJL1,MJS1, NJ2,NJP2, LX,NRL00,NL00, MXLL,
     C   VCA(MXD32,MXD32,MXD31), VCB(MXD32,MXD32,MXD31), BVC
      DATA VK(1,2),DV3/2*999./
       MVC(MLX,MLY) = ((MLX+2)*MLX/2 + MLY )/2 + 1
      SKP = MXLL.EQ.-1
       KF=NEK(1)
       KG=NEK(2)
      NL01=NL00+1
      DO 110 J1=JA,JB
       J = NAM(J1)
       NES(1)=J
       DO 120 J2=JAP,JBP
        JD = NAM(J2)
        ML=QBML(JD)
        MU=QBMS(JD)
C     EVALUATE THE TRANSFORMATION COEFFICIENTS FOR THE TRANSFORMATION
C     (L,S,MS,ML) TO (L,S,J,MJ)
        DDH=DC(J+NJ2)*DC(JD+NJP2)*DVCL1 *
     *      VCC(MJL1,MJS1,JACT,ML,MU,QMJ,DFS,MT)
        IF(DABS(DDH).LT.1.0E-6) GO TO 120                               UCL77FEB
cP      IF(ABS(DDH).LT.1.0E-5) GO TO 120
        NES(2)=JD
        NK=0
C       NOW COMPARE INITIAL AND FINAL SLATER STATES AND SELECT ONLY THE
C       ONES WHICH DIFFER IN NK= TWO, ONE, OR NO SETS OF QUANTUM NUMBERS   79FEB
        MEN = 0
        IF (JD.EQ.J)  GO TO 75
C     FIND THE POSITIONS OF THE ELECTRONS WITH DIFFERING QUANTUM NUMBERS SPOR
C     STORE THESE IN THE ARRAY NEN
C       ---
        DO  22 I=1,NF
         KB = QLML(I,J)
         KC = QCG(I,KF)
         DO  23 L=1,NF
          IF (QLML(L,JD).NE.KB)  GO TO 23
          IF  (QCG(L,KG).NE.KC)  GO TO 23
          LP = L
          GO TO 22
  23      CONTINUE
         NK = NK+1
         IF (NK.GT.2)  GO TO 120
         NEN(1,NK) = I
         MEN = I + MEN
         LP = 0
  22     QLML(I,1) = LP
        K = 0
        DO 20 L=1,NF
         DO 21 I=1,NF
          IF (QLML(I,1).EQ.L)  GO TO 20                                 UCL77AUG
  21      CONTINUE
         K = K+1
         NEN(2,K) = L
         MEN = L + MEN
         IF (K.EQ.NK)  GO TO 75                                         UCL77MAR
  20     CONTINUE
C       ---
 75     I=0
 240    I=I+1
        IF(I.GT.NF) GO TO 13                                            UCL77FEB
       IF(NK.EQ.1.AND.I.EQ.NEN(1,1)) GO TO 240
        K=0
 250    K=K+1
       IF(K.GE.I.AND.NK.EQ.0) GO TO 240
        DO 750 K2=1,2
        KP = I
        IF(NK.EQ.0.AND.K2.EQ.2) KP=K
        DO 750 K1=1,2
        NI = K1                                                         D.ABBOTT
COR     KX=NEK(K1) ,  KY=NES(K1)        CORR -- D.ABBOTT/JILA1976JAN26
C     THE ELECTRON LABELLED BY (K1,K2) BELONGS TO THE CONFIGURATION KX
C     AND TO THE SLATER STATE KY. K1=NO. OF ELECTRON WITHIN A PAIR AND
C     K2=NO. OF PAIR.
        IF (NK-1)  752,753,754
  753   IF (K2.EQ.1)  GO TO 754                                         UCL76FEB
        NI = 1                                                          (ABBOTT)
        GO TO 752
  754   KP = NEN(K1,K2)
  752   KX = NEK(NI)                                                    D.ABBOTT
        KY = NES(NI)
        IH=QCG(KP,KX)
        MU=QLML(KP,KY)
        ML=((100+MU)/2)*2-100
        Q1(K1,K2)=QL(IH)
        Q2(K1,K2)=IH
        Q3(K1,K2)=ML
  750   Q4(K1,K2)=(MU-ML)*2-1
        NI = 0                                                          UCL77FEB
        KC=0
  78    KB=0
C       ---- INITIALIZE DATA FOR LAMBDA-LOOP
 265    L1=Q1(1,1+KC)
        L2=Q1(1,2-KC)
        IF (L1+L2.EQ.0)  GO TO 14                                       *TRYOUT*
        L3=Q1(2,1+KB)
        L4=Q1(2,2-KB)
        IF (L3+L4.EQ.0)  GO TO 14                                       *TRYOUT*
       MU = MIN(L1+L3,L2+L4)
       MLAM2 = MAX(ABS(L1-L3),ABS(L2-L4))
       MLAM0 = MLAM2 - 4
       IF (MLAM2.GT.0)  MLAM2 = MLAM0                                   NUR75MAR
       IF (MLAM2.GT.MU)  GO TO 76                                       UCL75APR
        JSS(1+KC) = Q2(1,1)
        JSS(2-KC) = Q2(1,2)
        JSS(3+KB) = Q2(2,1)
        JSS(4-KB) = Q2(2,2)
        ML1=Q3(1,1+KC)
        ML2=Q3(1,2-KC)
        ML3=Q3(2,1+KB)
        ML4=Q3(2,2-KB)
       LOG = JSS(2).LE.JSS(1) .OR.JSS(3).NE.JSS(2) .OR.JSS(4).NE.JSS(1) UCL75APR
C          = FALSE  FOR EXPLOITING  N(B,A;A,B)=N(A,B;B,A) WHEN B.LT.A.
       DSJ = SQRT(REAL((L1+1)*(L2+1)*(L3+1)*(L4+1))) *  REAL(
     C         MOD(ABS((KB+KC+MEN)*2+MLAM2-ML1-ML2),4)-1 ) * DDH        UCL77MAR
        IF (SKP)  GO TO 48
        MDIFF1=ML1-ML3
        MDIFF2=ML2-ML4
        NI = MIN(ABS(MDIFF1),ABS(MDIFF2))
         M1=Q4(1,1+KC)
         M2=Q4(1,2-KC)
         M3=Q4(2,1+KB)
         M4=Q4(2,2-KB)
        MD1=M1-M3
        MD2=M2-M4
       MST = MD1 + MD2
        DV1=VCC(1,2,1,M3,MD1,M1,DFS,MT)
        DV2=VCC(1,2,1,M4,MD2,M2,DFS,MT)
       DD1 = -VCC(2,2,4,MD1,MD2,MST,DFS,MT)*DV1*DV2*0.670820393375D0    N'89OCT4
cP     DD1 = -VCC(2,2,4,MD1,MD2,MST,DFS,MT)*DV1*DV2*0.670820393375
       M1 = MVC(L1,-ML1)
       M2 = MVC(L2,-ML2)
       M3 = MVC(L3,ML3)
       M4 = MVC(L4,ML4)
       SPN = .TRUE.
       DDR1 = 0.0
       DDR2 = 0.0
       IF (MD2.NE.0)  GO TO 47                                          UCL77FEB
       SPN = .FALSE.
       DDR1 = DV1
       DDR2 = DV1+DV1
  47   IF (MD1.NE.0)  GO TO 267
       DDR1 = DV2+DV2 + DDR1
       DDR2 = DV2 + DDR2
  48   SPN = .FALSE.
C      ----- BEGIN OF LAMBDA-LOOP (INNER LOOP)
 267   MLAM = MLAM2
      IF(MLAM.GT.MU) GO TO 76
       DSJ = -DSJ
  40   MLAM2 = MLAM0 + 2
       MLAM1 = MLAM2 + 2
       VK(1,1) = VK(1,2)
       VK(1,2) = VK(1,3)
       VK(2,1) = VK(2,2)
       VK(2,2) = VK(2,3)
       VK(1,3) = 0.
       VK(2,3) = 0.
       DV1 = DV2
       DV2 = DV3
       DV3 = 0.0
       IF (MLAM1.LT.NI)  GO TO 59                                       UCL77MAR
       LMM = MOD(MU-MLAM0,4).NE.0
       IF(LMM) GO TO 59
        LH = L1+L3.LT.MLAM1                                             UCL75APR
        LN = L2+L4.LT.MLAM1
        LK = MLAM0.LT.0 .OR. MLAM0.NE.MLAM
       DD = 1.
       IF (SKP)  GO TO 59                                               UCL77FEB
        KP = MLAM1/4
        K1 = KP+1
C      LABELS 50-55 SERVE THE N-CASE MLAM=-2 (51-55 ALSO MLAM0.LT.MLAM)
       IF(BVC) GO TO 41
       IF(L1.GT.MXLL) GO TO 42
       IF(L3.GT.MXLL) GO TO 42
  41   IF (LK)  GO TO 51
       VC(1)   = VCB(M1,M3,KP)
       IF (LH)  GO TO 53                                                UCL75APR
  51   VK(1,3) = VCA(M1,M3,K1)
       GO TO 53
  42   IF (LK)  GO TO 52
       VC(1)   = VCC(L1,L3,MLAM0,  0,  0,  0, DFS, MT)
     C          *VCC(L1,L3,MLAM2,-ML1,ML3,-MDIFF1,DFS,MT)
       IF (LH)  GO TO 53
  52   VK(1,3) = VCC(L1,L3,MLAM1,  0,  0,  0, DFS, MT)/ REAL(MLAM1+1)
     C          *VCC(L1,L3,MLAM1,-ML1,ML3,-MDIFF1,DFS,MT)
  53   IF(BVC) GO TO 44
       IF(L2.GT.MXLL) GO TO 45
       IF(L4.GT.MXLL) GO TO 45
  44   IF (LK)  GO TO 54
       VC(2)   = VCB(M2,M4,KP)
       IF (LN)  GO TO 59                                                UCL75APR
  54   VK(2,3) = VCA(M2,M4,K1)
       GO TO 46
  45   IF (LK)  GO TO 55
       VC(2)   = VCC(L2,L4,MLAM0, 0,  0,  0,  DFS, MT)
     C          *VCC(L2,L4,MLAM2,-ML2,ML4,-MDIFF2,DFS,MT)
       IF (LN)  GO TO 59
  55   VK(2,3) = VCC(L2,L4,MLAM1, 0,  0,  0,  DFS, MT) / REAL(MLAM1+1)
     C          *VCC(L2,L4,MLAM1,-ML2,ML4,-MDIFF2,DFS,MT)
  46   IF (LH)  GO TO 59
       DV3=VCC(MLAM1,MLAM1,2,MDIFF1,MDIFF2,-MST,DFS,MT)*VK(1,3)*VK(2,3)
  59   MLAM0 = MLAM2
       IF (MLAM0.LE.MLAM)  GO TO 40
       IF (MLAM1.LT.NI)  GO TO 267
C      --------
C NOW  MLAM2 = MLAM + 2
C AND  MLAM1 = MLAM + 4
       IF(LMM) GO TO 60
       DDR = 0.
       ML = MLAM+200                                                    80/03/08
       IF (LK) GO TO 66
       IF (ABS(L4-L2).GT.MLAM)  GO TO 64
       IF (LH)  GO TO 62
       IF (SKP)  GO TO 70
C      FOLLOWING STATEMENT: SPIN-SPIN; THEREAFTER: MUTUAL SPIN-ORBIT.   82/07/29
       DDR = SQRT(REAL((MLAM+5)*MLAM1*(MLAM+3)*MLAM2*(MLAM+1))) *
     C  VCC(MLAM1,MLAM,4,MDIFF1,MDIFF2,-MST,DFS,MT)*VK(1,3)*VK(2,1)*DD1
       IF (SPN)  GO TO 68
       MD2 = (MLAM2-L4+L2)*(MLAM2-L2+L4)*(L2-MLAM+L4)                   UCL77FEB
       IF (MD2.EQ.0)  GO TO 62
CORWE  IF(MLAM2.LT.IABS(L2-L4)) GO TO 4503-*4502                        UCL75MAR
       DDR = DDR - VCC(MLAM1,MLAM2,2,MDIFF1,MDIFF2,-MST,DFS,MT)
     C     *  SQRT(REAL((MLAM1+L2+L4)*(MLAM+5)*MD2) / REAL(
     C                (MLAM+1)*MLAM1*32)) * DDR2 * VC(2)*VK(1,3)        2ND V2
  62   IF (SPN)  GO TO 267
       IF (ABS(L3-L1).GT.MLAM)  GO TO 64                                UCL75APR
       MD1 = (MLAM2-L3+L1)*(MLAM2-L1+L3)*(L3-MLAM+L1)                   UCL77FEB
       IF (MD1.EQ.0)  GO TO 63
       IF (SKP)  GO TO 70
       DDR = SQRT(REAL((MLAM1+L1+L3)*MD1)/(32*MLAM2)) * VC(1)*VK(2,1)
     C        * DDR1 *VCC(MLAM2,MLAM,2,MDIFF1,MDIFF2,-MST,DFS,MT) + DDR 1ST V2
  63   IF (MLAM.EQ.0)  GO TO 64
       IF (SKP)  GO TO 70
C      DDR = DDR + SQRT(REAL((MLAM+1)*MLAM)/ REAL(64*MLAM2)) * REAL(    +88SEP06
       DDR = DDR - SQRT(REAL((MLAM+1)*MLAM)/ REAL(64*MLAM2)) * REAL(    RE020514
     C      (L1*(L1+2)-L3*(L3+2)-MLAM*MLAM2)) * DDR1 * DV1              1ST V3
  64   IF (LH)  GO TO 68                                                     APR
       IF (LN)  GO TO 68
  66   IF (SPN)  GO TO 267                                              UCL77FEB
       IF (SKP)  GO TO 70
C      POSITIVE SIGN OF BOTH 1ST AND 2ND V3 REPRODUCES MICHAEL'S TABLE2 JPB 1971
C SEP  DDR =  -SQRT(REAL((MLAM1+1)*(MLAM1+2))/REAL(64*MLAM1)) * REAL(   89SEP09
       DDR =  -SQRT(REAL((MLAM1+1)*(MLAM1+2))/REAL(64*MLAM1)) * REAL(   RESTO'02
     C      (L2*(L2+2)-L4*(L4+2)-(MLAM1+2)*MLAM1)) * DDR2 * DV3 + DDR   2ND V3
  68   DD = DDR*DSJ
       GO TO 69
  60   IF (SPN)  GO TO 267
       ML = MLAM+100                                                    80/03/08
       IF (SKP)  GO TO 70
       DD =  SQRT(REAL(((MLAM2+1)*MLAM2*MLAM1)/4)) * DV2 * DDR1 * DSJ       V1
  69   IF (ABS(DD).LT.1.E-5)  GO TO 267
C      --------
  70   L = NL+1                                                         UCL77FEB
       IF (L.GT.NSMAX)  GO TO 1
       QSS(5,L) = ML
       DO 79 K1=1,4
        KP = K1
        IF (LMM)  GO TO 79
        IF (LOG)  GO TO 79
        KP = K1-2
        IF(KP.LE.0) KP=K1+2
  79    QSS(K1,L) = JSS(KP)                                             UCL75APR
       IF(NL.EQ.NL00) GO TO 300
       DO 270 KP=NL01,NL
        DO 271 K1=1,5
         IF(QSS(K1,KP).NE.QSS(K1,L))  GO TO 270
 271     CONTINUE
        LP = KP
        IF(IRS.LT.IRS0) GO TO 301
        DO 272 K1=IRS0,IRS
         IF(MSS(K1).NE.LP) GO TO 272
         DSS(K1) = DSS(K1) + DD
         GO TO 267
 272     CONTINUE
        GO TO 301
 270    CONTINUE
 300   NL=L
       LP=L
 301   IRS=IRS+1
       IF(IRS.GT.IRSM) GO TO 1
       MSS(IRS)=LP
       DSS(IRS)=DD
       GO TO 267
C      ----- END OF LAMBDA-LOOP
  76    IF(KB.EQ.0) GO TO 80
        IF(KC.NE.0) GO TO 78                                            UCL77FEB
        KC=1
        GO TO 265
  80    KB=1
        IF(KC.EQ.0) GO TO 265                                                APR
  14    IF(NK-1) 250,240,13
  13    IF (.NOT.SKP)  GO TO 120                                        UCL77FEB
        IF (IRS.LT.IRS0)  GO TO 120                                     UCL77MAR
        IF (KF-KG)  110,89,110                                          *TRYOUT*
 120    CONTINUE
 110    CONTINUE
  96   IF(LX) RETURN
C
C     CLEAR THE ARRAY OF ZEROS AND ADJUST MSS(K) ACCORDINGLY
      IF(IRS.LT.IRS0) RETURN
  89  K = IRS0-1                                                        UCL77FEB
      KP=0
      DO 90 I=IRS0,IRS
       IF (ABS(DSS(I)).LT.2.0E-3) GO TO 90
       K=K+1
       DSS(K)=DSS(I)
       JD=MSS(I)
       LP=JD-KP
       IF(NL00.EQ.0) GO TO  92
       DO 94 L=1,NL00
        DO 99  J=1,5
         IF (QSS(J,JD).NE.QSS(J,L))  GO TO 94                           UCL75APR
  99     CONTINUE
        LP=L
        GO TO 91
  94    CONTINUE
  92   KP=KP-1
       DO 93 J=1,5
  93    QSS(J,LP)=QSS(J,JD)
  91   MSS(K)=LP
  90   KP=KP+1
      NL=NL-KP
      IRS=K
      RETURN
C
   1  IZX = 1
      RETURN
      END
      SUBROUTINE ALGEB4(DC,QLMC,QBML,QBMS,JYI,JYF,MAXST,MAXEL)          UCL77MAR
C                WORKS OUT RADIATIVE M2, BP M1, AND BP E1VEL ALGEBRA
cM    IMPLICIT INTEGER*2(Q)
cS   C        ,INTEGER*2(I-L,N)
      IMPLICIT INTEGER (Q)
      INTEGER QLML1,QLML2,QLMS1,QLMS2, QLML1P,QLMS1P,QLML2P,QLMS2P      79NV77OC
cS   C      , LL,LR,LM, LLP,LRP,  LA,LB,LC,LD,LE,LF,LG, LO, LAM
      DOUBLE PRECISION DVC,DDH,DC,DFS,DD,DRKP,VCC,VCL1,VC12,SJS, CLTM
     C  , VCL, PHS0,DD1,DD2, DDS, DL1,DL2, DC1,DC2, VC1,  SQ300
     C  , SQ1O3,SQ2O3,SQ10O3, D2C0, D2C2,D2C3,D2C4,D2C5, D2C6J, DEY
      CHARACTER TYPE*2
      PARAMETER (NC0=(4+2)*3, MXD13=78*3, SQ300=1.732050808,
     *  SQ1O3=.5773502691896, SQ2O3=.8164965809277, SQ10O3=1.825741858)
      LOGICAL LPT, LX1,LX2,  DEBUG,DEBUG1, MSKIP,OSKIP, E1CASE
      DIMENSION QLMC(MAXEL,MAXST), QBML(MAXST),QBMS(MAXST), DC(1750000)
     1 , JYI( 60), JYF( 60), NAM( 19000)
     4 , VC1(NC0), QLIT(10),IGAM(5),CLTM2(200),ILAM(200), CLTM(   9)
      EQUIVALENCE (MCTO,MLK), (CLTM2(1),CLTM(1))
      COMMON  MAXGR, NF,KF0,KG0, JX,JY,JXP,JYP, IRS0,MQSS, DSS(500000),
     *   MSS(500000),QSS(5, 5000),NL000,NL,IRS,IRSM,NAD(523000)
     C /TERMS/ KM,NSL0, NSL( 60),NFI(1225),NFK(1225),
     *  NFQ(1225),NADSL(0: 61500),QPI( 60),QSI( 60),QLI( 60)
     C /MQVC/ MAXDC,MD,KCUT,QMCL,QMCS,NEL(15, 60)
     C /QTG/MTGD,NXLL,NTG(0: 60),JTGD(1225),QX( 60),QY(1725,3)
     C /DBD2/ DEY(15), QCG(54, 60),QL(15),QN(15)
     C /COEFF/DRKP( 550000),QRLP(2,5500),IRLP0,NRKP( 550000),NJD(523000)
     C /JSPOR/ NJO,NRR(3100),NT(  38),JJ(3100),NGR(3100)
     C /COMFAC/ DFS( 64),MT /OUTP/ MPRINT,MKUTSS,QCUT,
cM   *  QDUM,
     *  KDUM,LCE1,LCE2  /CCLSH/ NW,NNL(MXD13)
      DATA MXSOC,MXSOI/ 550000,5500/,MXRSS,MAXMI/500000, 5000/, MG/-6/
     C , MAXCL/78/,  DEBUG1,DEBUG /.FALSE.,.FALSE./,  MXADJ/523000/
     C , QLIT/1H0,1H1,1H2,1H3,1H4,1HF,1HS,1HQ,1HW,1HX/, IPL,IGP/1H+,1H /80/08/16
C
      IF (NJO.LE.0)  GO TO 90
C     BECAUSE ALL I.C. CALCULATIONS HAVE BEEN SWITCHED OFF.
      IF (LCE2.EQ.-9) GO TO 90
      IF (MPRINT.EQ.MG)  GO TO 98
C     BECAUSE ON INPUT RADIATIVE CALCULATIONS HAVE BEEN SUPPRESSED.
      LPT=MPRINT.GT.0
      KUT = KCUT
      DO 19 I=1,7
       IF (QLIT(I).NE.QCUT)  GO TO 19
       IF (I-6)  16,17,18
  16   KUT = I-1
       GO TO 20
  18   KUT = MKUTSS
  19   CONTINUE
      IF (KUT)  90,17,20
  17  KUT = KM
  20  PRINT 600, KUT,QCUT
      NCI = QBML(1)
      N = MQSS
      J = N + NCI
cS    IF (NCI*MXSOI.GT.32767)  GO TO 96                                 79/11/20
      IF (J.GT.MXADJ)  GO TO 91
      IRK = NJD(N)
      IRLP = IRLP0
      IRLP1 = IRLP+1
      IRS00 = IRS
      NL = NL000                                                        80/02/01
      NL001 = NL+1                                                      79/11/18
      DO 79 J=1,NC0
       LL = (J/2)*2
       LM = LL-2
       IF (LL.NE.J)  LM = LL+2
  79   VC1(J) = VCC(LL,2,LM, 0,0,0, DFS,MT)                             77/10/21
      MXLL = 0                                                          **TEMP**
      DO 11  ND1=1,NCI
       IT = NRR(ND1)
       KF = NFK(IT)
       II = NFI(IT)
       ND2 = JTGD(II)
       JL1 = JYI(KF)
       JL2 = JYF(KF)
       NC = NFQ(IT)
       MJL1 = QLI(NC)
       MJS1 = QSI(NC)
       MJJL = JJ(ND1)
       JA = 2
C TST  DO 25  NDP1=1,NCI
       DO 25  NDP1=1,ND1
        IF (NDP1.EQ.ND1 .AND. NJD(ND1+N).EQ.-1)  GO TO 25
        MJJR = JJ(NDP1)
        MLAM = 0
        ITP = NRR(NDP1)
        ND = NFQ(ITP)
        E1CASE = QPI(ND).NE.QPI(NC)                                     82/08/04
  426   MLAM = MLAM+2
         IF (MJJR+MJJL.GE.MLAM .AND. ABS(MJJR-MJJL).LE.MLAM) GO TO 427
         IF (E1CASE.AND.MLAM.LT.4) GO TO 426 ! i.e. trying case M2
         GO TO 25
  427   MJL2 = QLI(ND)
        MJS2 = QSI(ND)
C**     MPAR = ...       MORE SELECTION RULES   *************
        KG = NFK(ITP)
        MSKIP = KG.GT.KUT .AND. KF.GT.KUT                               80/08/16
        OSKIP = KF.GT.KUT .OR. KG.GT.KUT
        IF(E1CASE) OSKIP=MSKIP                                          TMP82AUG
        IF (QCUT.NE.QLIT(8) .AND. QCUT.NE.QLIT(9))  MSKIP = OSKIP
        IF (ITP.NE.IT .AND. MSKIP)  GO TO 25
C           ITP.NE.IT SECURES ORDINARY M1-ALGEBRA FOR ALL TRANSITIONS.  80/08/15
C       FIND NUMBER MK/2 OF ELECTRON PAIRS IN WHICH KF AND KG DIFFER    79/11/19
        MK = 0
        II = 4
        IF(E1CASE) II = 2
        DO 13  K=1,MAXGR
         MLK = NEL(K,KG) - NEL(K,KF)
         MK = ABS(MLK) + MK
         IF (MK.GT.II)  GO TO 25
  13     CONTINUE
        II = NFI(ITP)
        NDP2 = JTGD(II)
        JR1 = JYI(KG)
        JR2 = JYF(KG)
C       ...24  FIND A NONVANISHING MULTIPOLE MATRIX ELEMENT
        K = 0
        MJ1 = MJJL
  21    MJ2 = MJJR
  22    MLK = MJ1 - MJ2
        ML2 = -MJ2
        DVC = VCC( MJJL,MJJR, MLAM, MJ1,ML2,MLK , DFS,MT )
        IF (DVC.EQ.0.0)  GO TO 23
        IF (MD.LE.0)  GO TO 24
        IF (MJ1.LE.1 .AND. MJ2.LE.1)  GO TO 24                          77/10/16
        K = 1
  23    MJ2 = MJ2 - 2
        IF (MJ2.GE.0)  GO TO 22
        MJ1 = MJ1 - 2
        IF (MJ1.GE.0)  GO TO 21
        IF (MD*K.LE.0)  GO TO 25
        PRINT 800
        GO TO 97
C----   BEGIN TAKE OUT
  24    IRK0 = IRK+1
        NRL00 = IRLP                                                    UCL77APR
        NRL01 = NRL00+1
        IRS0 = IRS+1
        NSL00 = NL
        NSL01 = NSL00+1                                                 79/11/18
        MS1 = MJS1
C DBG   II = '0'; IF(DEBUG) PRINT 400,     IRK,ND1,NDP1, MJJL,MJJR      *DEBUG1*
  30     ML1 = MJ1-MS1
         LX1 = MS1.NE.-MJS1 .AND. ML1.NE.MJL1
         IF (ML1.LT.-MJL1)  GO TO 40
         JB = 1
         DO 31 I=JL1,JL2
          IF (QBML(I).NE.ML1)  GO TO 31
          IF (QBMS(I).NE.MS1)  GO TO 31
          JB = JB+1
          NAM(JB) = I
  31      CONTINUE
         IF (JB.LT.JA)  GO TO 40
         VCL1 = VCC(MJL1,MJS1,MJJL, ML1,MS1,MJ1, DFS,MT)
C
         MS2 = MJS2
  32      ML2 = MJ2-MS2
          LX2 = MS2.NE.-MJS2 .AND. ML2.NE.MJL2
          IF (ML2.LT.-MJL2)  GO TO 39                                   COR77OCT
          IF (ABS(MS2-MS1).GT.2)  GO TO 39
C RDD     IF (ABS(ML2-ML1).GT.4)  GO TO 39
          JAP = JA
          JBP = JB
          IF (MK.EQ.0 .AND. ML2.EQ.ML1 .AND. MS2.EQ.MS1)  GO TO 41
          JAP = JB+1
          DO 35 I=JR1,JR2
           IF (QBML(I).NE.ML2)  GO TO 35
           IF (QBMS(I).NE.MS2)  GO TO 35
  34       JBP = JBP+1
           NAM(JBP) = I
  35       CONTINUE
  37      IF (JBP.LT.JAP)  GO TO 39
  41      DD2 = VCC(MJL2,MJS2,MJJR, ML2,MS2,MJ2, DFS,MT)
          VC12 = VCL1*DD2                                               *LAST+2*
          IF (VC12.EQ.0.0)  GO TO 39
C DBG     IF(DEBUG1)PRINT700,MK,MS1,ML1,MS2,ML2,IRK,DVC, VCL1,DD2,JA,JBP*DEBUG2*
C TMP     IF (IABS(ML2-ML1).GT.2)  GO TO 39
C
C     IN LOOPS 64,65 SCAN THROUGH SLATER STATES IN INITIAL AND
C     FINAL STATES RESP., AND CALCULATE CONTRIBUTIONS DUE TO EACH PAIR.
      DO 64 J1=JA,JB
       L1 = NAM(J1)
       DO 65 J2=JAP,JBP
        L2 = NAM(J2)
C       CALCULATE TRANSFORMATION COEFFICIENT FROM THE LS,ML,MS
C       REPRESENTATION TO THE J,MJ REPRESENTATION.
        DDH = DC(L1+ND2)*DC(L2+NDP2) * VC12
        IF ( ABS(DDH).LT.1.E-8) GO TO 65
        NK = 0
        N2 = 0
C
C       NOW COMPARE INITIAL AND FINAL SLATER STATES AND SELECT ONLY THE
C       ONES WHICH DIFFER IN NK = 0, 1, OR 2 SETS OF QUANTUM NUMBERS
        MU = 0
        DO 74 I=1,NF
         N2P = QLMC(I,L1)
         ICG2 = QCG(I,KF)
         DO 73 L=1,NF
          IF (QLMC(L,L2).NE.N2P)  GO TO 73
          IF (QCG(L,KG).NE.ICG2)  GO TO 73
          LP = L
          GO TO 74
  73      CONTINUE
         NK = NK+1
         IF (NK-2)  75,76,65
  75     N1 = I
  76     N1P = I
         MU = I+MU
         LP = 0
  74     QLMC(I,1) = LP
        IF (NK.EQ.0)  GO TO 88                                          80/01/29
        DO 70 L=1,NF
         DO 71 I=1,NF
          IF (QLMC(I,1).EQ.L)  GO TO 70
  71      CONTINUE
         N2P = L
         MU = L+MU
         IF (N2.NE.0)  GO TO 87
C TMP    IF (N2.NE.0)  GO TO 65
         N2 = N2P
         IF (NK.EQ.1)  GO TO 87
C        L1 AND L2 DIFFER IN ONE PAIR, IN POSITIONS NUMBERED N1 AND N2
  70     CONTINUE
C
  88    N2 = N2+1
        IF (N2.GT.NF)  GO TO 69
        N1 = N2
  87    ICG1 = QCG(N1,KF)
        ICG2 = QCG(N2,KG)
C       FIND THE AZIMUTHAL COMPONENTS OF L AND S FOR THE INDIVIDUAL
C       ELECTRONS, WHOSE NUMBERS ARE N1,N2.
      LR=QL(ICG2)
      LL=QL(ICG1)
       LAM = QLMC(N2,L2)
       QLML2 = ((LAM+100)/2)*2-100
       QLMS2 = (LAM-QLML2)*2-1
       LAM = QLMC(N1,L1)
       QLML1 = ((LAM+100)/2)*2-100
       QLMS1 = (LAM-QLML1)*2-1
        IF (E1CASE)  GO TO 49                                           TMP82AUG
        IF (QLIT(10).EQ.QCUT)  GO TO 49                                 80/8/15-
        IF (MSKIP)  GO TO 49
        IF ((QCUT.EQ.QLIT(8) .OR. NC.NE.ND) .AND. OSKIP)  GO TO 49      FE12AU16
        LAM = NF
        IF (NK-1)  43,44,46
  43    LAM = N1
  44    N1P = -NW
  45    N1P = N1P+1
        IF (N1P.GT.0)  GO TO 77                                         80/01/29
         KP = N1P+NW
         ICG1P = NNL(KP)
         ICG2P = ICG1P
         MA = NNL(KP+MAXCL)
         MC = MA
         GO TO 78
  77    IF (N1P.GT.LAM)  GO TO 49
        IF (N1P.EQ.N1)  GO TO 45
        N2P = QLMC(N1P,1)                                               80/01/29
C TST   ICG1P = QCG(N1P,KF);  ICG2P = ICG1P
C TST   MA = QLMC(N1P,L1);    MC = MA;         GO TO 78
  46    ICG1P = QCG(N1P,KF)
        ICG2P = QCG(N2P,KG)
        MA = QLMC(N1P,L1)
        MC = QLMC(N2P,L2)                                               80/01/28
  78    QLML2P = ((MC+100)/2)*2-100
        QLMS2P = (MC-QLML2P)*2-1
        QLML1P = ((MA+100)/2)*2-100
        QLMS1P = (MA-QLML1P)*2-1
        LLP = QL(ICG1P)
        LRP = QL(ICG2P)
        KP = 1
  47    KO = 1
  66    LO = ABS(LL-LR)
        IF (LO.GT.6)  GO TO 67
        I1P = ABS(LLP-LRP)
C       ETC.............
        ILAM(200) = 9999
C +-+   +++++++++++++++++++++++++++++++++++++++
C       CLAUDE, INSERT HSC.CZMAGADD.FORT HERE
C       CLTM2(199) = DDH*KO*KP;  ILAM(199) = -9999
        KTERM = 200                                                     79/11/25
        MTEST2 = QLMS1 - QLMS2
        MTES2P = QLMS1P - QLMS2P
      IF (MTEST2.NE.0.AND.MTES2P.NE.0)  GO TO 67                        UPD80JAN
      MX = -MTEST2-MTES2P
      MTEST1 = QLML1 - QLML2
      MTES1P = QLML1P - QLML2P
      MP1 = QLML1+QLML2 + QLML1P+QLML2P
      DDS = 0.0
      IF(MTES2P.NE.0) GO TO 203
CC    DDS = .5773502691896
      DDS = -SQ1O3
CC          - '''             TO ABSORB FACTOR (-1)**(-QLMS1-QLMS2)     80/07/23
      IF(QLMS1+QLMS2.NE.0) GO TO 202
      DDS = SQ2O3
  202 IF(QLMS1.GT.0) DDS=-DDS
      IF(MTEST2.NE.0) GO TO 204
  203 DD = -SQ1O3
      IF(QLMS1P+QLMS2P.NE.0) GO TO 205
      DD = SQ2O3
  205 IF(QLMS1P.GT.0) DD=-DD
      DDS = DD + DDS
  204 I2P = LLP+LRP
      LP = LL+LR
      LA = LO
  255 D2C2 = VCC(LR,LA,LL,0,0,0,DFS,MT)                                 UPD80FEB
      ID = LA+2
      IC = ABS(LA-2)
      LB = MAX(LA-2,LO)                                                 MR-CJZ80
  256 IF (LB.GT.LP)  GO TO 206                                          80/03/18
      IF (ABS(MTEST1).GT.LB)  GO TO 207
      D2C3 = VCC(LL,LB,LR,-QLML1,MTEST1,-QLML2,DFS,MT)
      IF (MX.NE.0)  GO TO 208
C JJJ DD    = SJS(LA,2,LB,LR,LL,LR,DFS,MT) *                            80/08/09
C JJJC         DSQRT(DFLOAT((LA+1)*(LB+1)*(LR+2)*(LR+1)*LR*3))          *TMPTST*
      LM = LA+2                                                         80/08/10
      IF(LA-LB) 231,232,233
  232 D2C6J = 0.0                                                       CL&W80JL
      IF(LA.EQ.0) GO TO 208                                             CLAUDE80
      D2C6J =((LL+2)*LL-(LR+2)*LR-LM*LA)*SQRT(((LA+1)*3)/REAL(LM*LA*4)) CJZ&WE80
      GO TO 220
  231 D2C6J = -SQRT(((LR+LL+LA+4)*(LR-LL+LM)*(LM+LL-LR)*(LR+LL-LA)*3) /
     C REAL(8*LM))                                                      CLAUDE8+
      GO TO 220
  233 D2C6J = SQRT(((LR+LL+LM)*(LR-LL+LA)*(LA+LL-LR)*(LR+LL-LA+2)*3) /
     C REAL(8*LA))                                                      CLAUDE80
  220 CONTINUE
C JJJ IF (DABS(D2C6J-DD).GT.1.E-4)  PRINT 888, LL,LR,LA,LB, D2C6J, DD   *TMPTST*
C 888 FORMAT( '  *** LL,LR,LA,LB: SJS ***  ',4I4,2F10.5)                *TMPTST*
  208 LC = I1P
  257 D2C4 = VCC(LRP,LC,LLP,0,0,0,DFS,MT)
      IB = LC+2
      IA = ABS(2-LC)
      LD = LC
C 258 IF(LD.LT.I1P.OR.LD.GT.I2P) GO TO 209                              CLAUDE80
      IF (ABS(MTES1P).GT.LD)  GO TO 209
      D2C5 = VCC(LLP,LD,LRP,-QLML1P,MTES1P,-QLML2P,DFS,MT)
      IF(LB.NE.LA) GO TO 240
      IF (DDS.EQ.0.0)  GO TO 240                                        80/02/10
      IF (LA.NE.LC)  GO TO 252
      IF (MTEST1.NE.-MTES1P)  GO TO 252                                 *80/2/X5
      KTERM = KTERM-1
      IF(KTERM.LE.0) GO TO 99
      CLTM2(KTERM) = (MOD(ABS(MTEST1),4)-1) * DDS*D2C2*D2C3*
C     CLTM2(KTERM) = (1-MOD(IABS(MCTO+MTEST1),4)) * DDS*D2C2*D2C3*      CJZ80JUL
     C              D2C4*D2C5*SQ300
      ILAM(KTERM) = LA                                                  -TYPE  3
  252 LF = IA
      MA = MTEST1-MX
      DD = -1
      IF (LC.EQ.0)  GO TO 238
      DD = (MOD(LC,4)-1)/SQRT(REAL(LC+1))
      LM = (LC+1)*(LC-1)
      MC = -600                                                         ITYPE  1
      GO TO 250
  238 LM = -(LC+1)*(LC+3)
      MC =  600                                                         ITYPE  2
  250 IF (ABS(LF-LA).NE.2)  GO TO 237
      KTERM = KTERM-1
      IF(KTERM.LE.0) GO TO 99
      II = (LA-LF+2)/4+LF
      KK = (LC-LF+2)/4+LF
C     NOTE: (-1)**((LA+LC)/2)=+1, BECAUSE M1-TRANSITIONS CONSERVE PARITY80/08/13
      CLTM2(KTERM) = ((MOD(ABS(MX-MP1),4)-1)*LM*2)*D2C2*D2C3*D2C4*D2C5* CJZ+WE80
CLD+  CLTM2(KTERM) = 1.154700538   * LM  *  D2C2*D2C3*D2C4*D2C5*        CJZ80JUL
CLAUDE, SECTION 'MX.NE.0' BUG FREE I HOPE, SINCE JULY 23. WERNER AUG80
     C                DDS * VCC(LF,2,LA,MA,MX,MTEST1,DFS,MT) * VC1(II)  80FEBMAR
     C               * DD * VCC(LC,LF,2,MTES1P,MA,MCTO,DFS,MT)*VC1(KK)
C     VC1(II)=VCC(LF,2,LA,0,0,0,DFS,MT);+VC1(KK)*DD*SQR(3)=VCC(LC,LF,2,.MAR80JUL
      ILAM(KTERM) = SIGN(LC,MC)+MC
  237 LF = LF+4
      IF(LF.LE.IB) GO TO 238
C --- IF(MTEST2.NE.0.OR.MTES2P.NE.0)    I.E.
  240 IF (MX.NE.0)  GO TO 209
      IF (MJS2.NE.MJS1)  GO TO 209
      IF (LB+LC.EQ.0)  GO TO 209
      IF (ABS(LC-LB).GT.2)  GO TO 209
      D2C0 = ((MOD(ABS(MTES1P+MP1),4)-1)*2) *  SQRT(REAL((LC+1)*3))*
     C     VCC(LC,2,LB,-MTES1P,MCTO,MTEST1,DFS,MT) * D2C2*D2C3*D2C4*D2C5 80JUL22
      LE = IA
  210 DC1 = SJS(2,2,2,LE,LD,LB,DFS,MT)                                  80/03/19
      DL1 = 1/SQRT(REAL(LE+1))
      KK = (LC-LE+2)/4+LE
      LF = IC
  264 II = (LA-LF+2)/4+LF
      DD1 = VC1(II)*VC1(KK) * DC1 * D2C0                                80FB20MR
C     VC1(II)=VCC(LF,2,LA,0,0,0,DFS,MT), (KK)=VCC(2,LE,LC,0,0,0,DFS,MT)
C EVT IF (DD1.EQ.0.)  GO TO 268
      DC2 = SJS(2,2,2,LA,LB,LF,DFS,MT)                                  CLD80JUL
      DL2 = SQRT(REAL(LF+1))
      LG = ABS(2-LE)
      IF(LE.EQ.0) GO TO 262
      LM = (LE+1)*(LE-1)
      MC = - 500 - LE                                                   ITYPE  5
      MA = -600 - LE+2                                                  ITYPE  4
      GO TO 261
  262 LM = -(LE+1)*(LE+3)
      MC = LE+2 + 700                                                   ITYPE  -
      MA = LE+2 + 600                                                   ITYPE  -
  261 IF (ABS(LG-LF).NE.2)  GO TO 260
      IF (KTERM.LT.5)  GO TO 99                                         UPD80JAN
      I = (LF-LG+2)/4+LG
      K = (LE-LG+2)/4+LG
C     VCC(2,LG,LF,0,0,0,DFS,MT)=VC1(I);VCC(LE,LG,2,..)=(MOD(LE,4)-1)*
C                                                      VC1(K)*DL1*SQR(3)
      DD = LM*SJS(LE,LG,2,LF,LB,2,DFS,MT) *DD1* VC1(I)*VC1(K)*DL1 * DL2 CLAUDE80
      KTERM = KTERM-1
      CLTM2(KTERM) = D2C6J*DC2*DD                                         CLAUDE
CLAUDE, I REINTRODUCED, NOW THROUGH D2C0, A PHASE FACTOR (-1)**MP1 WHICH80/08/15
C#**** YOU HAD THROWN OUT WITH PHS0 IN JULY. PLEASE CLARIFY. WERNER 80AUG
      ILAM(KTERM) = MA
      IF (LB.NE.LA)  GO TO 260
      KTERM = KTERM-1
      CLTM2(KTERM) = DD *1.4142133562                                   CJZ&WE80
      ILAM(KTERM) = MC
  260 LG = LG+4
      IF(LG.LE.LE+2) GO TO 262
      IF (LF.NE.LE)  GO TO 268
C     NOTE: LF= LC-2 AND LC+2 (SUBJECT TO .GE.LA-2, .LE.LA+2, SEE IC ID)
C           LE= LC-2 AND LC+2; THUS ALWAYS ONE MATCH FOR LF IN SET LE.  80/08/12
      KTERM = KTERM-1
      CLTM2(KTERM) = DC2 * D2C6J * DD1
      ILAM(KTERM) = -400 - LF                                           ITYPE 10
      IF (LB.NE.LA)  GO TO 268
      KTERM = KTERM-1
      CLTM2(KTERM) = DD1*1.4142133562
      ILAM(KTERM) = -300 - LF                                           ITYPE 11
  268 LF = LF+4
      IF(LF.LE.ID) GO TO 264
      LE = LE+4
      IF(LE.LE.IB) GO TO 210
CQ219 IF (MX.NE.0)  GO TO 209
C       ARCHIVED HSC.CZDIRAFS.MAR80.DATA OF MARCH 15TH DOES NOT YET MAKE
C       USE OF PARTICLE SYMMETRY PROPERTIES - HAS OLD BULKY CODE.
CO209 LD = LD+2
CO    IF(LD.LE.IB) GO TO 258
  209 LC = LC+4
      IF(LC.LE.I2P) GO TO 257
  207 LB = LB+2
      IF(LB.LE.ID) GO TO 256
  206 LA = LA+4
      IF(LA.LE.LP) GO TO 255
C +-+   +++++++++++++++++++++++++++++++++++++++
  201   PHS0 = (1-MOD((MU+KO+KP)*2,4))*DDH                              80JANFEB
        CLTM2(200) = 0.0                                                80/01/30
C TST   CLTM2(200) = (1-MOD(MJJR-MJ2,4))*DVC/(17.320508*PHS0)
        DO 214 K=KTERM,200
         DD = CLTM2(K)
         IF (DD.EQ.0.0)  GO TO 214
         LM = ILAM(K)
         MC = (ABS(LM)+2)/100
C XXX    IF(MC.NE.0) DD = DD+DD
C XXX    CLAUDE HAS NOW ABSORBED FACTORS 2 INTO CLTM2  -- 1980 JULY     80/07/16
         KK = 0
         II = 0
C-TST    IF (MC.GT.4)  GO TO 277
         IF (LM.LT.0)  GO TO 274
         IF (MC.GT.0)  GO TO 277
         IF (ICG1.LE.ICG2)  GO TO 277
  274    LM = ABS(LM)
  275    II = 1-II
  277    IGAM(1+II+KK) = ICG1
         IGAM(2-II+KK) = ICG1P
         IGAM(3+II-KK) = ICG2
         IGAM(4-II-KK) = ICG2P
         IF (KK.NE.0)  GO TO 279
C TST    IF (LM.EQ.9999)  GO TO 279
         IF (IGAM(1).LT.IGAM(3))  GO TO 279
         KK = 2
         IF (MC.NE.0)  GO TO 278
         IF (IGAM(4).LT.IGAM(3))  GO TO 275
  278    IF (MOD(MC,2).EQ.0)  GO TO 277
C EVT    ADD CODE TO REDUCE NUMBER OF INTEGRALS INVOLVING A DERIVATIVE
  279    IGAM(5) = LM
         L = NL+1
         IF (L.LE.NSL01)  GO TO 286
         LP = NSL01
  280    DO 272 J=LP,NL
          DO 172 I=1,5
           IF (QSS(I,J).NE.IGAM(I))  GO TO 272
  172      CONTINUE
          IF (IRS.LT.IRS0)  GO TO 284
          DO 283 I=IRS0,IRS
           IF (MSS(I).NE.J)  GO TO 283
           DSS(I) = DD*PHS0 + DSS(I)
           GO TO 214
  283      CONTINUE
  284     L = J
          GO TO 281
  272     CONTINUE
  286    IF (L.LE.MAXMI)  GO TO 285
         IF (LP.EQ.NL001)  GO TO 95
         LP = NL001
         GO TO 280
  285    NL = L
         DO 180 I=1,5
  180     QSS(I,L) = IGAM(I)
  281    IRS = IRS+1
         IF (IRS.GT.MXRSS)  GO TO 94
         MSS(IRS) = L
         DSS(IRS) = DD*PHS0
  214    CONTINUE
  67    II = ICG1P
        ICG1P = ICG1
        ICG1 = II
        LM = LLP
        LLP = LL
        LL = LM
        KK = QLML1P
        QLML1P = QLML1
        QLML1 = KK
        KK = QLMS1P
        QLMS1P = QLMS1
        QLMS1 = KK
        KO = KO-1
        IF (KO.GE.0)  GO TO 66
  48    II = ICG2P
        ICG2P = ICG2
        ICG2 = II
        LM = LRP
        LRP = LR
        LR = LM
        II = QLML2P
        QLML2P = QLML2
        QLML2 = II
        II = QLMS2P
        QLMS2P = QLMS2
        QLMS2 = II
        KP = KP-1
        IF (KP.GE.0)  GO TO 47
        IF (NK-1)  45,45,65
  49   IF (NK.GT.1)  GO TO 65
       IF (ABS(LL-LR).GT.4)  GO TO 82
       MTEST2 = QLMS1-QLMS2
       MTEST1 = QLML1-QLML2
       DD = 0.
       IF (MXLL.EQ.-1)  DD = 1.
       DO 120 K=1,8
  120   CLTM(K) = DD
C DBG  IF (DEBUG1)  PRINT 700, NK, L1,L2, LL,LR                         *DEBUG1*
C
C
C CCC DDS = VCC(1,2,1,-QLMS1,MTEST2,-QLMS2,DFS,MT)                      77/11/14
      DDS = SQ1O3
      IF (QLMS1+QLMS2.NE.0)  GO TO 133
      DDS = SQ2O3
  133 IF (QLMS1.GT.0)  DDS = -DDS
      MC = 1 - ABS(MCTO)
      LP = 1
      IF (E1CASE)  GO TO 137                                            82/08/04
      LAM = (LL+2)*LL
      IF (MSKIP)  GO TO 127                                             79/03/12
      IF (LL+LR.EQ.0)  GO TO 150
      MA = 1-ABS(MTEST2)
      DD = VCC(LR,4,LL, 0,0,0, DFS,MT)
      DL2 = VCC(LL,4,LR, -QLML1,MTEST1,-QLML2, DFS,MT)
      DC2 = VCC(2,4,2, MTEST2,MTEST1,MCTO, DFS,MT) *(MC*MA)             77/11/14
      CLTM(2)= -((LAM-(LR+2)*LR+24)) * DL2*DD*DC2*DDS*0.114108866D0     SGN24,CL
cP    CLTM(2)= -((LAM-(LR+2)*LR+24)) * DL2*DD*DC2*DDS*0.114108866       SGN24,CL
      CLTM(3) = -((LAM-(LR+2)*LR-24)) * DL2*DD*DC2*DDS*0.114108866D0    C7/12/78
cP    CLTM(3) = -((LAM-(LR+2)*LR-24)) * DL2*DD*DC2*DDS*0.114108866      C7/12/78
      CLTM(4) = -DL2*DD*DC2*DDS*SQ10O3
      CLTM(5) = CLTM(4)
C *** CLTM(1) = .......                    TERM  LM = MIN0(LL,LR)+2
      DL1 = 4
      LM = LL+2
      IF (LR-LL)  132,131,130
  132 LM = LR+2
      DC1 =  (LM-2)*LM
      DD1 =  (LM+3)*5
      DD2 =   LM-1
      GO TO 129
C 131 DL1 = 6
  131 DL1=12
      DC1 = -(LM+2)*(LM-2)                                              77/11/24
      DD1 =  (LM-3)*(LM-2)*15
      DD2 =  (LM-1)* LM   * 2                                           77/11/24
      GO TO 129
  130 DC1 =  (LM+2)*(LM+4)                                              77NV79MR
      DD1 =  (LM-1)*5
      DD2 =   LM+3
  129 II = (LM-LL+2)/4 + LL
      KK = (LR-LM+2)/4 + LM
      CLTM(1) = VC1(II) * VC1(KK) *
C TST CLTM(1) = VCC(LL,2,LM,0,0,0, DFS,MT) * VCC(LM,2,LR,0,0,0, DFS,MT)*
C TST*          SJS(LL,LM,2,2,2,LM,DFS,MT) * SJS(LM,LR,2,2,2,LR,DFS,MT)*
C TST*          SJS(LL,LR,4,2,2,LM,DFS,MT) * ((LM+1)*30) * DC2*DL2*DDS* *2,MAR79
C TST*          SQRT(REAL((LR+2)*LR*(LL+1)*(LM+2)*LM))  +  CLTM(1)
     *           SQRT(DD1/DD2) * DC2*DL2*DDS * DC1/DL1  + CLTM(1)       77/11/28
      IF (LR.NE.LL)  GO TO 103
      IF (LM.LT.LL)  GO TO 128
      LM = LL-2
      IF (LM.EQ.0)  GO TO 128
C *** CLTM(1) = .......  +  CLTM(1)        TERM  LM = LL-2=LR-2
      DC1 = -(LM+4)* LM
      DD1 =  (LM+5)*(LM+4)*15
      DD2 =  (LM+3)*(LM+2)* 2
      GO TO 129
  127 LP = 8
      IF(MTEST2.NE.0) GO TO 150                                         79/03/12
  128 IF (ABS(MTEST1).GT.2)  GO TO 103
  137 DL1 = VCC(LL,2,LR, -QLML1,MTEST1,-QLML2, DFS,MT)                  77/11/14
      IF (E1CASE)  GO TO 141                                            82/08/04
      IF (MSKIP)  GO TO 149
  141 DC1 = VCC(2,2,2, MTEST2,MTEST1,MCTO, DFS,MT)
      IF (E1CASE)  GO TO 42
      DD1 = SQRT(REAL(LAM)/6)
      DD2 = SQRT(REAL((LL+LR-2)*(LL+LR+6))/24)*(MA*DD)
C     CLTM(2) = (DD1*MA - DD2) * DL1 * DC1  +  CLTM(2)
C     CLTM(3) = -(DD1*MC + DD2) * DL1 * DC1  +  CLTM(3)
       DD =     (DD1*MA - DD2)*DL1*DC1*MC*DDS                           C7/12/78
      CLTM(3) = DD + CLTM(3)
      CLTM(2) = CLTM(2) - DD
      IF(MTEST2.NE.0) GO TO 150
  149 CLTM(8) = (MOD(ABS(QLMS1+QLMS2),4)-1)*MC*SQRT(REAL(LAM/4))*DL1
  150 IF(MTEST1.NE.0) GO TO 126
      DD = DDS * SQ300
      CLTM(8) = CLTM(8) + DD
      IF (MSKIP)  GO TO 126                                             79/03/12
      CLTM(4) = CLTM(4) + DD/3
      CLTM(5) = CLTM(4) - DD
      IF (LL.NE.0)  CLTM(1) = (LAM   *DD)/12  + CLTM(1)
C OUT IF (QN(ICG2).NE.QN(ICG1))  GO TO 126
      CLTM(6) = DD
  126 IF (DEBUG)  PRINT 104, CLTM(6),CLTM(8)                            *DEBUG2*
  103 MX = 8
      KTERM = 8
      CLTM(7) = CLTM(5)
      PHS0 = (1-MOD((N1+N2)*2+QLMS1+QLMS2,4)) * DDH                     77/10/18
        GO TO 38
C +++   BEGIN OF ONE-BODY SECTION FOR PARITY CHANGING TRANSITIONS
  42    IF (MLAM.GT.2) THEN ! case M2
         DD1 = VCC(LL,2,LR,0,0,0,DFS,MT)
         IF (DD1.EQ.0.) GO TO 82
         DD = 0.
         IF (QLMS2.EQ.QLMS1) THEN ! contribution {C[1] x l[1]}[2] /DD1
          DD = -VCC(LR,4,LL,QLML2,MLK,QLML1,DFS,MT)
     *        * SJS(LL,LR,4,2,2,LR,DFS,MT)
     *        * SQRT(REAL(5*(LR+1)*LR/2*(LR/2+1)))
         ENDIF ! and contribution {C[1] x 3s[1]}[2]/DD1:
         MQL = QLML1-QLML2
         MQS = QLMS1-QLMS2
         DD = -VCC(LR,2,LL,QLML2,MQL,QLML1,DFS,MT)
     *         * VCC(1,2,1,QLMS2,MQS,QLMS1,DFS,MT)
     *         * VCC(2,2,4,MQL,MQS,MLK,DFS,MT) * .866025404 * 3.  +  DD
         IF (DD.EQ.0.) GO TO 82 ! (or 69?)
         CLTM(9) = DD*DD1
         PHS0 = DDH ! n.b. VC12 already in DDH, but couple LSJ, not SLJ!
     *    *(1-MOD((N1+N2)*2+MJL1+MJS1+MJJL+MJL2+MJS2+MJJR,4))
     *    * (sqrt(real(10))*2)/3
         LP = 9
         KTERM = 9
        ELSE ! case E1vel
         KTERM = 1
         II = (LL-LR+2)/4+LR
         CLTM(1) = DC1*DDS*DL1*VC1(II)*2.449489743D0
cP       CLTM(1) = DC1*DDS*DL1*VC1(II)*2.449489743
         PHS0 = MC * DDH
        ENDIF
C +++
  38  DO 114 K=LP,KTERM
       DD = CLTM(K)*PHS0
       IF (DD.EQ.0.0)  GO TO 114
       MA = K*MAXGR+ICG1
       MC = K*MAXGR+ICG2
       IF (ICG1.GE.ICG2)  GO TO 124
       IF (K/2.EQ.1)  GO TO 124
       MA = MC
       MC = MC-ICG2+ICG1
  124  MX = MX-1
       L = IRLP+1
       IF (L.LE.NRL01)  GO TO 86
       II = NRL01
  80   DO 72 J=II,IRLP
        IF (QRLP(1,J).NE.MA)  GO TO 72
        IF (QRLP(2,J).NE.MC)  GO TO 72
        IF (IRK.LT.IRK0)  GO TO 84
        DO 83 I=IRK0,IRK
         IF(NRKP(I).NE.J) GO TO 83
         DRKP(I) = DRKP(I)+DD
         GO TO 114
  83     CONTINUE
  84    L = J
        GO TO 81
  72    CONTINUE
C      CANNOT FIND AN OLD SET OF ARGUMENTS EQUAL TO THE NEW SET, SO
C      MUST START CONSTRUCTING A NEW COEFFICIENT
  86   IF (L.LE.MXSOI)  GO TO 85
       IF (II.EQ.1)  GO TO 93
       II = 1
       GO TO 80
  85   IRLP = L
       QRLP(1,L) = MA
       QRLP(2,L) = MC
  81   IRK = IRK+1
       IF(IRK.GT.MXSOC) GO TO 92
       NRKP(IRK) = L
       DRKP(IRK)=DD
  114  CONTINUE
  82     IF (NK.EQ.0)  GO TO 88
C        NK.EQ.1 FOR STATES WHICH DIFFER IN ONE SET OF ONE-ELECTRON
C        QUANTUM NOS, THE NECESSARY TERM HAS ALREADY BEEN EVALUATED,
C        THEREFORE PROCEED TO NEXT PAIR OF SLATER STATES.
  69     IF (MXLL.NE.-1)  GO TO 65
         IF (MX.NE.0)  GO TO 65
         IF (IRK.GE.IRK0)  GO TO 39                                     79NV77OC
  65     CONTINUE
  64    CONTINUE
C
C         IF .T. COMPUTE FOR DIFFERENT (MS,ML) GIVING THE SAME MS+ML=MJ      OCT
  39      MS2 = MS2-2
          IF (LX2)  GO TO 32
C
  40     MS1 = MS1-2
         IF (LX1)  GO TO 30
C
C       INSERT ARRAY CLEARING PARAGRAPHS HERE (LX1 AND LX2)
C
        PHS0 = (1-MOD(MJJR-MJ2,4))*SQ300/DVC
        II = IGP
C.TST.  IF(LPT) PRINT 400,   IRS, NSL00,NL
        IF (IRK.LT.IRK0)  GO TO 15
C       IF THE MATRIX ELEMENT HAS BEEN CALCULATED CLEAR THE ARRAY  DRKP
C       OF ZEROS AND ADJUST NRKP.
        K = IRK0-1
        N1 = NRL00
        DO 190 I=IRK0,IRK
cP       IF ( ABS(DRKP(I)).LT.1.0E-5)   GO TO 190
         IF (DABS(DRKP(I)).LT.1.0E-6)   GO TO 190
         K = K+1
         DRKP(K) = DRKP(I)*PHS0
         N2 = NRKP(I)
         IF (N2.LE.NRL00)  GO TO 191                                    80/01/28
         IF (NRL00.EQ.IRLP0)  GO TO 193                                 UCL77APR
         DO 194 L=IRLP1,NRL00
          DO 195 J=1,2
           IF (QRLP(J,N2).NE.QRLP(J,L))  GO TO 194
  195      CONTINUE
          N2 = L
          GO TO 191
  194     CONTINUE
  193    N1 = N1+1
         DO 192 J=1,2
  192     QRLP(J,N1) = QRLP(J,N2)
         N2 = N1
  191    NRKP(K) = N2 + (NDP1-1)*MXSOI
         II = IPL
         IF(.NOT.LPT) GO TO 190
           MA = QRLP(1,N2)
           MC = QRLP(2,N2)
           TYPE = '  '
           IF(MC.GT.MAXGR*9) TYPE = 'M2'
           PRINT 700, K, ND1,NDP1, MA,MC, N2, DRKP(K),
     *      MOD(MA,MAXGR),MOD(MC,MAXGR), TYPE
  190    CONTINUE
        IRLP = N1
        IRK = K
C       SIMILARLY, CLEAR TWO-BODY ARRAYS                                79/11/18
  15    K = IRS0-1
        IF (IRS.EQ.K)  GO TO 25
        N1 = NSL00
        DO 290 I=IRS0,IRS
         IF (ABS(DSS(I)).LT.1.E-5)  GO TO 290
         K = K+1
         DSS(K) = DSS(I)*PHS0
         N2 = MSS(I)
         IF (N2.LE.NSL00)  GO TO 291                                    80/01/27
         IF (NSL00.EQ.NL000)  GO TO 293                                 79/11/20
         DO 294 L=NL001,NSL00
          DO 295 J=1,5
           IF (QSS(J,N2).NE.QSS(J,L))  GO TO 294
  295      CONTINUE
          N2 = L
          GO TO 291
  294     CONTINUE
  293    N1 = N1+1
         DO 292 J=1,5
  292     QSS(J,N1) = QSS(J,N2)
         N2 = N1
  291    MSS(K) = N2 + (NDP1-1)*MAXMI
  290    CONTINUE
        NL = N1
        IRS = K
        IF (IRS.LT.IRS0)  GO TO 25
        IF(LPT) PRINT 400,    ND1,NDP1,IRS,NL,(MSS(I),DSS(I),I=IRS0,IRS)
C
C----   END TAKE OUT
  25    CONTINUE
       NAD(ND1+N) = IRS
       IF (MPRINT)  26,12,11
  26   IF (ND1.NE.NCI .AND. MOD(ND1,10).NE.0)  GO TO 11
  12   PRINT 500,  IRK, ND1,ND1,  IRLP,  ND1,ND1,IRS,NL
  11   NJD(ND1+N) = IRK
      IRLP0 = IRLP
      IF (NL.EQ.NL000)  GO TO 90
      IF (LPT) PRINT 300, (L,(QSS(I,L),I=1,5),L=NL001,NL)
  90  RETURN
C
  104 FORMAT(30X,1P,4E16.6,4I5)
  990 FORMAT(/51H SR.ALGEB4: STORAGE EXCEEDED  -  RAD.CORR'S DROPPED)
  991 FORMAT(/22H SR.ALGEB4:  * MXADJ =,I7,23H REQUIRED FOR NADR, NDJ)
  992 FORMAT(/52H SR.ALGEB4:  * MXSOC TOO SMALL, ARRAYS DRKP AND NRKP)
  993 FORMAT(/53H SR.ALGEB4:  * MXSOI TOO SMALL, ARRAYS DRLP1 AND QRLP)
  994 FORMAT(/50H SR.ALGEB4:  * MXRSS TOO SMALL, ARRAYS DSS AND MSS)
  995 FORMAT(/50H SR.ALGEB4:  * MAXMI TOO SMALL, ARRAYS DNL AND QSS)
cS996 FORMAT(/54H SR.ALGEB4: PACKING INHIBITED FOR S.INT*2 - RECOMPILE!)
  300 FORMAT(//' REFERENCE TABLE FOR RADIATIVE MAGNETIC TWO-BODY TERMS'/
     * (4(I14,':',4I3,I5)))
  400 FORMAT(63X,2I6,I7,I6,(T89,3(I6,F8.4)))
  500 FORMAT(2I6,I5,11X,I6, T64,2I6,I7,I6)
  600 FORMAT(//34H    CN    LV  LVP,    B    D,  IND,16X,
     * 15HREL.RAD.ALGEBRA
     *,8X,43HFOR M1  CONFIGURATIONS INCLUDED UP TO  CF =,I2,1H(,A1,1H))
  700 FORMAT(I6,2(I6,I5),I6,F15.5,9X,2I4,4X,A2)
  800 FORMAT(  44X,77HNOT ENOUGH SLATER STATES STORED; CHANGE MODE TO -1
     * IF RADIATIVE DATA REQUIRED)
C
C     E R R O R   M E S S A G E S
C
cS96  PRINT 996
cS    IF (J.LE.MXADJ)  GO TO 97
  91  PRINT 991, J
      GO TO 97
  92  PRINT 992
      GO TO 99
  93  PRINT 993
      IRLP = L
      GO TO 99
  94  PRINT 994
      GO TO 99
  95  PRINT 995
C
  99  PRINT 990
      PRINT 500,  IRK, ND1,ND1,  IRLP,  ND1,NDP1,IRS,NL
C RDD IRS = IRS00
C     ETC   ...
  97  NAD(N+1) = 0
      NJD(N+1) = -1
  98  NL = NL000                                                        77JN87JN
      GO TO 90
      END
      SUBROUTINE MINIM
C     -- CONTROLS THE SECOND, ANALYTIC BRANCH
cM    IMPLICIT INTEGER*2(Q)
cS   C        ,INTEGER*2(I-L,N)
      LOGICAL BPRINT,HFF
      CHARACTER*1 LFREE
      INTEGER QCG,QL,QN
      DOUBLE PRECISION DEY,ADJUST,ADJOLD,DF,DF0,HNS,EXTRE,ACCUR,DQNL,Y
     C ,BUF
      PARAMETER(LEN0=( 999+1)*(15+1)+15*15,MXD13=78*3,
cC   *  MXD24=3*15*15, MXD23=15**2+ 11000+ 97000+1225*4+2,
     *  MXD04=3100*3+  38+1)
      DIMENSION EXTRE(15), ACCUR(15)
      COMMON MAXGR,NF,KVAR,HFF,MP
     C /CRAD/ HNS(10),MNH(10),MJH,MAXRS,JEND(15) /JSPOR/ NJO(MXD04)
     C /DBD2/ DEY(15),QCG(54, 60),QL(15),QN(15)
     C /WEIGHT/ ECO(-1225:1225),WGHT(1225),MECO,INDEXW(1225)
C    C /RADF/ Y,BUF(&MXD22) -- WHEN BUF IN SINGLE PRECISION;
     C /RADF/ BUF(LEN0)  /CCLSH/ NW,NNL(MXD13)
cC   C /TRANS/TRANS(&MXD23),ENR(1225) /REL/REL(MXD24) /EX/DEX(5500)
     C /GENINF/ ADJOLD(15),SCREEN(15),MION,NZION,NPARAM,ITOL,
     C  INCLUD,JPRINT,NGROUP,IZDW
C#   C                      , ENOBS(3100),DELEN(1225),NCOREN,NOBSEN
     C /CADJ/ ADJUST(15),DF0,IEQUAL(15),ICOUNT
C#   C ,IMIN(15) /CUTOUT/LIMLS(2,2),LIMLSJ(2,2), MP   , JRM,ISLAT
     C /CUTOUT/ LSLIM1,LSLIM2  /OUTP/ MPRINT,BPRINT,MPNCH,KUTCA,KDUM(2)
      DATA MXLL,MAXT/15,1225/, ICON/2/, M/ 9/, ITOL0/7/
cQ    ITOL0 = 5
 1003 FORMAT(/' INITIAL OPTIMIZATION PARAMETERS ='/(6F12.5))
C1002 FORMAT(8F10.1)
 1001 FORMAT(/1X,29('*')/' * WARNING: INTRAN SET TO',I3,' *'/1X,29('*'))94OCT19
 1000 FORMAT(/' CASE SKIPPED  AS MXVAR = 15 SHOULD BE',I4)
C1000 FORMAT(33H0ERROR ON Z CARD-  NSCAL.GT.MAXGR,2I4,5X,
C    C 12HCASE SKIPPED/)
  999 FORMAT(24I3)
  998 FORMAT(12F6.2)
  997 FORMAT((8F9.3))
  996 FORMAT(//34H OPTIMIZED VARIATIONAL PARAMETERS:,(T36,6F10.5))
  995 FORMAT(14I5,I1,A1)
C 994 FORMAT(6(I3,F9.0)) --- ECHANGE A 'FREE FORMAT' NICE'93FEVRIER27
  994 FORMAT(6(I5,F9.0))
  993 FORMAT(//35X,60(1H*)/)
  992 FORMAT(/' SR.MINIM REDUCES NEXTRE=',I2,20H TO SCALE FACTOR NO=,I2)
  991 FORMAT(/92H SR.MINIM RESETS INCLUD=0, BECAUSE YOU'VE ANNOUNCED P/Q
     *-INPUT FOR VARIATIONAL ORBITAL GAMMA=,I2)
  990 FORMAT(/49H SR.MINIM RESETS EFFECTIVE NUMBER OF ELECTRONS TO,I4,
     * 34H, BECAUSE YOU'VE SPECIFIED  MRED =,I3)
C
C     NZION = ATOMIC NUMBER Z, MION = TOTAL NUMBER OF ELECTRONS, NPARAM
C     = MAXL+1 - WHERE MAXL IS THE HIGHEST ORBITAL L (IN THE C-INPUT);
C     NGROUP = HIGHEST INDEX GAMMA OF SUBSHELLS NL IN THE CONFIGURATION
C     INPUT; IMAXIT (.GT.0) = NUMBER OF ITERATIVE CYCLES, DEFAULT NSCAL
C     ABS(INCLUD) IS THE NUMBER OF TERMS INCLUDED IN DF, THE VARIATIONAL
C     FUNCTIONAL OF SR.VA04A, USING EQUAL TERM WEIGHTS RATHER THAN INPUT
C     WGHT IF INCLUD.GT.0;  NSCAL = NUMBER OF VARIATIONAL PARAMETERS
C     ITOL GIVES ACCURACY OF S.M. ORBITALS NL - DEL(E)/E.LT.10**(-ITOL);
C     JPRINT CONTROLS THE PRINTING (IN SOME PLACES THROUGH BPRINT).
C
      IPRINT=1
      IF(MPRINT.LT.-2) IPRINT=0
      NORBS = 0
      NPARAM = 0
      NGROUP = MXLL
      IF (NF.LE.0)  GO TO 10
      DO 70 I=1,MAXGR
       IF (DEY(I).EQ.0.)  GO TO 75
       NGROUP = I
       NORBS = NORBS+1
       IF (QL(I).GT.NPARAM) NPARAM=QL(I)
       SCREEN(I) = MIN((QL(I)+1)*QN(I),NW+NF-1)
   75  IF (I.GT.MXLL)  GO TO 70
C TMP  ACCUR(I) = 0.002 -- QUB'91MAY23
       ACCUR(I) = 0.01
       EXTRE(I) = 1.0
C OUT  ADJUST(I) = 1. -- OUT ALONG WITH IF(J.GT.N)GOTO10 IN SR.CALCFX.   86JUN25
   70  CONTINUE
      NPARAM=NPARAM/2 + 1
C     DON'T VARY ADJUST BY MORE THAN 0.10 IN ONE ITERATION STEP IN VA04A
      DESCAL = 10.
      INCLUD = 0
C     IF(NPARAM.LE.MXLL) GO TO 10
      IF(NGROUP.LE.MXLL) GO TO 10
      PRINT 1000, NGROUP
      NF = -1
C
   10 J = 999
      READ 995, J,I,MSCAL,NGRP,IMAXIT,MPRIN0,ITOL,MPNCH,KUTCA,MRED,MQ,
C EVTC         MLSJ, NCLAUD, INTRAN
     C                       INTRAN,LSLIM1,LSLIM2,MECO,LFREE
      IF(J.EQ.0) RETURN
      PRINT 993
      PRINT 995, J,I,MSCAL,NGRP,IMAXIT,MPRIN0,ITOL,MPNCH,KUTCA,MRED
     C         , MQ, INTRAN,LSLIM1,LSLIM2,MECO,LFREE
      IF (J.EQ.999)  STOP
C     AS STANDARD FORTRAN CODE FOR CDC/CRAY END OF INPUT FILE.          DL85AP4
      IZDW = J
      NZION = ABS(J)
C     CLAUDE, THE PRESENT INPUT SHOULD BE THE SAME AS IN THE STANDARD
C     ******  VERSION; BUT NOW YOU MAY INCREMENT NSCAL BY 1000*NEXTRE SO
C             AS TO VARY THE SCALING FOR EACH ORBITAL NL INDEPENDENTLY.
C             MOREOVER, OPTIMIZATION DEFAULT NOW WITH EQUAL TERM WEIGHT!
C     STATISTICAL MODEL SCALING FACTORS ADJUST(K),K=1,NPARAM TO EACH
C     ORBITAL (QN(K),L=QL(K)/2) ARE ASSIGNED TO DISTINCT VARIATIONAL
C     PARAMETERS EXTRE(I=IEQUAL(K)),K=1,NSCAL, WHERE IEQUAL(K) DEFAULTS
C     TO QL(K)/2+1 IN THE ORIGINAL FORM OF THE PROGRAM. NOW IT DEFAULTS
C     TO K IF N=IABS(MSCAL)).GT.1000 (NSCAL=MOD(N,1000). INITIAL VALUES
C     FOR EXTRE WILL BE READ AS BEFORE, BUT ONLY THE FIRST N OPTIMIZED;
C     OVERWRITE IEQUAL THROUGH INPUT AS BEFORE IF THESE ARE NOT ASSOCIA-
C     TED WITH THE FIRST ADJUST'S OR IF YOU WANT A DIFFERENT ASSIGNMENT
C     TO EXTRE. ZUERICH-EXTENSION IMPLEMENTED WHEN EXTRE NEGATIVE, BUT
C     RETAINING THE DAVID LAYZER MODE AS THE DEFAULT CHOICE.  IF MQ.GT.0
C     ORBITAL OUTPUT IN COLALG/IMPACT FORMAT IS GENERATED ON UNIT /MQ/;
C     SUCH OUTPUT WILL BE ORTHO-NORMALIZED (FOR RMATRX) IF MQ.LT.0.     85JUN25
C#       GIVE THE HIGHEST LOWER AND UPPER STATE FOR WHICH TRANSITION
C#       PROBABILITIES ARE REQUIRED- LIM(1,I),LIM(2,I) FOR ALLOWED AND
C#       FORBIDDEN, I=1,2 FOR UPPER AND LOWER INDEX
C#   IF NOBSEN.NE.0 READ OBSERVED ENERGIES IN 1/CM FOR THE FIRST NOBSEN
C#   LEVELS. IF ANY OF THE  I.LT.NOBSEN  ENERGIES IS NOT OBSERVED
C#   READ A NEGATIVE VALUE, THE CALCULATED ENERGY WILL THEN BE RETRIEVED
CLAUDE ********* COMMENT DL'85 EARLY APRIL: CLAUDE, THE CODE IN ZUERICH-
C-CLD DIAGFS USING THIS INPUT LOOKS LIKE AN INCOMPLETE ALTERNATIVE TO
C-  / YOUR CODE - PLEASE CHECK, AS WE KNOW WHAT CORRECTING PHASE SPACE
C-  / FACTORS WITHOUT T.E.C. CAN LEAD TO. ADMITTEDLY SUCH DATA SHOULD BE
C-  / READ IN SR.MINIM, BUT SURELY AS THE LAST PIECE OF INPUT (CONTROLLED
C-  / BY NCLAUD=NCOREN)! ANY SUGGESTIONS - APART FROM SOME REORDERING OF
C-  / INPUT SO AS TO BE IN LINE WITH DIRECTIVES ON STMT 10READ995? WERNER
C#--- READ 999,((LIMLS(I,J),J=1,2),I=1,2),
C#   C ((LIMLSJ(I,J),J=1,2),I=1,2), MQ   ,NCOREN,NOBSEN,INTRAN,JRM,ISLAT
C     GOOD NEW FACILITY, BUT BADLY PLACED AS RELATED TO JPRINT; NEW MLSJ?
      IF (ITOL.EQ.0)  ITOL = ITOL0
C        'INTRAN' MULTIPLIES THE LENGTH OF THE INTEGRATION INTERVALS
C        BY A FACTOR (INTRAN/10.) -- N.B.: SHOULD BE SOME INTEGER POWER
C#    IF (INTRAN.NE.0)                   : OF 2 FOR NUMERICAL REASONS.  DL85AP4
C#   .HNS(1) = (INTRAN * HNS(1))/10. --  SHOULD BE ABSORBED INTO M, AS  89AVR18
      MJH = 0
      IF(INTRAN.NE.0) PRINT 1001, INTRAN
c---  IF(INTRAN.LE.1) GO TO 12
c---  MJH = INTRAN
c---  INTRAN = 0
  12  HNS(1) = (26./NZION)**(1./3.) / 2**(M+INTRAN)
C
C     SKIP IF PREVIOUS INPUT WEIGHTS MAY BE USED (TYPICALLY I=-9999):
C     CAUTION WHEN USING IT WITH INDEXW.LT.0 TO MATCH OBSERVED ENERGIES!
      IF (I.LT.-MAXT)  GO TO 15
      INCLUD = I
      IF (I.GE.0)  GO TO 15
      J = -I
      READ *,  (INDEXW(I),WGHT(I),I=1,J) ! FREE FORMAT, NICE'93FEVRIER27
C#    IF (NCOREN.EQ.0) GO TO 103
C#--- READ 994, (INDEXW(J),WGHT(J),J=1,NCOREN)
      PRINT 994,  (INDEXW(I),WGHT(I),I=1,J)
C#    DO 102 J=1,NCOREN                 N.B.: THE FOLLOWING CONVERSION
C#       JJ = INDEXW(J)                     : IS DONE IN THE STANDARD
C#102    DELEN(JJ) = WGHT(J) / 109737.31    : SUBROUTINE DIAGON ALREADY.
C#103 IF (NOBSEN.EQ.0) GO TO 15
C#--- READ 1002, (ENOBS(J), J=1,NOBSEN)
   15 NSCAL = MOD(ABS(MSCAL),100)
      HFF = MOD(ABS(MSCAL)-NSCAL,1000).NE.0
      J = NORBS
      NEXTRE = ABS(MSCAL)/1000
      IF (NEXTRE.GT.0)  J = NGROUP
      IF (NSCAL.EQ.0)  NSCAL = J
      IF (MSCAL.LE.0)  GO TO 20
C     IF SKIPPED START WITH PREVIOUS VARIATIONAL PARAMS, DEFAULT IN DO70
      IF(LFREE.NE.' ') GO TO 18
      READ 998, (BUF(I),I=1,NSCAL)
      GO TO 20
   18 READ *, (BUF(I),I=1,NSCAL) ! 978 FORMAT(9F8.3) IN HARRY'S CODE
   20 IF (.NOT.HFF)  GO TO 25
      READ 999, (JEND(I),I=1,NGROUP)
      IF (NF.LE.0)  GO TO 40
      PRINT 999, (JEND(I),I=1,NGROUP)
   25 DO 30 I=1,NGROUP
       J = QL(I)/2+1
       IF (NEXTRE.GT.0)  J = I
       IF (HFF .AND. JEND(I).GT.0)  J = JEND(I)
       IF (J.GT.NSCAL)  J = NSCAL
       IF (DEY(I).EQ.0.0)  J = 0
       IEQUAL(I) = J
C ===  TO BE USED AS  ADJUST(I) = EXTRE(IEQUAL(I))  IN CALCFX.
       JEND(I) = 1
       IF (MSCAL.LE.0)  GO TO 30
       EXTRE(I) = BUF(I)
   30  ADJOLD(I) = 0.0
      IF (INCLUD.EQ.0)  GO TO 40
      IF (NEXTRE.EQ.0)  GO TO 35
      IF (NEXTRE.LE.NSCAL)  GO TO 40                                     85AP10
      PRINT 992, NEXTRE,NSCAL
   35 NEXTRE = NSCAL
C#--- READ 999, (IMIN(I),I=1,NSCAL) -: BASICALLY A SUBSTITUTE FOR IEQUAL
C#    PRINT 999, (IMIN(I),I=1,NSCAL) : NEXTRE = NO. OF NONVANISHING "'S.
C
   40 HFF = .FALSE.
      IF (NGRP.EQ.0)  GO TO 50
C     SCREEN RELATES TO THE EIGENVALUE E (IN RYDBERGS) OF THE ONE-
C     PARTICLE FUNCTIONS THROUGH E=-(Z-SCREEN)**2/(N*N); N=PRINCIPAL
C     QUANTUM NUMBER. A GOOD INITIAL VALUE OF SCREEN WILL SPEED UP THE
C     COMPUTATION IN RADWAV. IF NONE KNOWN USE DEFAULT DO70 BY SKIPPING
      READ 997,  (BUF(I),I=1,NGRP)
C     DO NOT ITERATE VARIATIONALLY IF VARIATIONAL ORBITALS USER SUPPLIED
      DO 45 I=1,NGRP
       IF (I.LE.MAXGR)  SCREEN(I) = BUF(I)
       IF (BUF(I).LT.999.)  GO TO 45
       HFF = .TRUE.
C EVT  IF (ABS(MSCAL).GE.1000)  IEQUAL(I) = 0
       IF (IEQUAL(I).GT.NEXTRE)  GO TO 45                                85APR
       IF (I.GT.NGROUP)  GO TO 45
       IF (DEY(I).EQ.0.0)  GO TO 45
       IF (INCLUD.NE.0)  PRINT 991, I
       INCLUD = 0
   45  CONTINUE
      IF (HFF)  PRINT 997, (BUF(I),I=1,NGRP)                            85JUL14
C
   50 JPRINT = MOD(MPRIN0,10)
      DF0 = 0.0
      MAXRS = 0
      ICOUNT = 0
C EVT READ OBSERVED TERM ENERGIES - AFTER INITIALIZATION (J=1,MAXT)DL85AP6/02JUN
      DO 55 I=0,MAXT
       ECO(-I)=0.
   55  ECO(I)=0.
      IF(MECO.GT.0) READ *, MTM, (K,ECO(-K),ECO(K),I=1,MTM)
      IF (NF.LE.0)  GO TO 10
      MION = NW+NF - MRED
      IF (MRED.NE.0)  PRINT 990, MION, MRED
      IF (INCLUD.EQ.0)  GO TO 90
      ICOUNT = -IMAXIT
      BPRINT = JPRINT.GE.5
      IF (IMAXIT.LE.0)  IMAXIT = NEXTRE
      IF (ICOUNT.LT.0)  ICOUNT = 4*NEXTRE*IMAXIT + IMAXIT+2             DL85AP6
      MP = 0
      KVAR = 0
C     OPTIMIZATION  OF INCLUD TERMS (IN NEXTRE PARAMETERS)
      PRINT 1003, (EXTRE(I),I=1,NEXTRE)
C     CALL THE MINIMIZATION SR VA04A - WHICH CALLS FUNCTIONAL-SR CALCFX
      CALL VA04A(EXTRE,ACCUR,NEXTRE, DF,DESCAL,IPRINT,ICON,IMAXIT)
      IF (NF.LE.0)  GO TO 10
      PRINT 996,  (EXTRE(I),I=1,NEXTRE)
      DO 60 I=1,NSCAL
   60  EXTRE(I) = REAL(NINT(100000*EXTRE(I)))*.00001 ! .0001 < '02Sep15
C
C     NO DETAILED PRINTOUT DURING ITERATION, THEREFORE NOW PRINTOUT TO   MINIM
C     MINIMIZING SCALE FACTORS, HAVING ROUNDED THEM TO 5 DECIMALS
C
   90 IF (JPRINT.EQ.3)  JPRINT = -3
      BPRINT = JPRINT.NE.-3
      KVAR = NJO(1)
      IF(IZDW.LT.0) KVAR=9999
      MP = MQ
C EVT MP = ABS(MPNCH)/100
C EVT MPNCH = SIGN(MOD(ABS(MPNCH),100),MPNCH)                           DL85AP8
      CALL CALCFX(NEXTRE,EXTRE,DF)
      IF (NF.LE.0)  GO TO 10
C     COMPUTE FINESTRUCTURE
      IF (NJO(1).LE.0)  GO TO 10
      CALL SOCC
      JPRINT = ABS(MPRIN0)/10
      CALL DIAGFS
C     COMPUTE CASCADE COEFFICIENTS;  BPRINT=.TRUE. RETURNED FROM
C     SR.DIAGFS  IF ARRAYS OF SIZE MXNOR EXCEEDED DURING STORAGE
C     OF ELECTRIC DIPOLE TRANSITION PROBABILITIES
      IF (BPRINT)  GO TO 10
      CALL CASC
C
      GO TO 10
C     NOTE: FOR THE NEXT ISOEL STRUCTURE RUN ONE CAN START WITH THE OLD  MINIM
C      SCALING (PUT MSCAL=-NSCAL) OR SCREENING PARAMETERS (PUT NGRP=0)
C
      END
      SUBROUTINE VA04A (X,E,N,F,ESCALE,IPRINT,ICON,MAXIT)
C       SEE REF.  M.J.D. POWELL, COMP.J.7(1965)303-7,
CMOD    MODIFIED (UCL75SEP-W.E.) SO AS TO ACCEPT A RETURN VALUE NN=0
C        FROM CALCFX(NN,X,F) AS A COMMAND TO QUIT;
C     SR.CALCFX SUPPLIES THE VARIATIONAL FUNCTIONAL F.
cS    IMPLICIT INTEGER*2(I-N)
      DOUBLE PRECISION  A,B,AAA,D,DC,DACC,DDMAG,DDMAX,DMAX,DA,DB,DI,DL
     C       ,FPREV,DD, FA,FB,FC,FI,FP,FHOLD,FKEEP,SUM, W,E,X, F
      PARAMETER (MXD29=(15+3)*15)
      DIMENSION  X(15),E(15), W(MXD29)
CDIR$ NOVECTOR
      DDMAG=0.1*ESCALE
      SCER=0.05/ESCALE
      NFCC=1
      NN = N
      J = NN+1
      JJ = J*NN
      JJJ = JJ+NN
      DO 3 K=J,JJ
    3  W(K)=0.
      ISGRAD=0
      ITERC=0
      IND=0
      INN=0
      K = 0
      DO 4 I=1,NN
       K = K+J
       W(K) = ABS(E(I))
    4  W(I)=ESCALE
CMOD  CALL CALCFX(N,X,F)
      CALL CALCFX(NN,X,F)
      FKEEP = ABS(F)+ABS(F)
    5 ITONE=1
      ITERC = ITERC+1                                                   UCL75SEP
      FP=F
      SUM=0.
      DO 6 I=1,N
    6  W(I+JJ)=X(I)
      IF (NN.EQ.0)  GO TO 77
      IDIRN=NN
      ILINE=1
    7 DMAX=W(ILINE)
      DACC=DMAX*SCER
      D = .1*DMAX
      IF (DDMAG.LT.D)  D = DDMAG                                           79JUN
      DDMAX = 20.*DACC
      IF (DDMAX.GT.D)  D = DDMAX                                           79JUN
      DDMAX = 10.*D
      IF (ITONE.LT.0)  GO TO 71
      DL=0.
      DA=DL
      FA=F
      FPREV=F
      IS=5
    8 DD=D-DL
      DL=D
   58 DO 9 I=1,N
    9  X(I)=X(I)+DD*W(I+IDIRN)
CMOD  CALL CALCFX(N,X,F)
      CALL CALCFX(NN,X,F)
      IF (NN.EQ.0)  GO TO 77                                            UCL75SEP
      NFCC=NFCC+1
      GO TO (10,11,12,13,14,96),IS
   14 IF(F-FA)15,16,24
   16 IF (ABS(D).GT.DMAX) GO TO 18
      D=D+D
      GO TO 8
   18 PRINT 19
   19 FORMAT(5X,44HVA04A MAXIMUM CHANGE DOES NOT ALTER FUNCTION)
      GO TO 20
   15 FB=F
      DB=D
      GO TO 21
   24 FB=FA
      DB=DA
      FA=F
      DA=D
   21 IF (ISGRAD.NE.0)  GO TO 83
   23 D=DB+DB-DA
      IS=1
      GO TO 8
   83 D=0.5*(DA+DB-(FA-FB)/(DA-DB))
      IS=4
      IF((DA-D)*(D-DB).GE.0.) GO TO 8
   25 IS=1
      IF (ABS(D-DB).LE.DDMAX) GO TO 8
   26 IS=1
      DDMAG=DDMAG+DDMAG
      D=DB+ SIGN(DDMAX,DB-DA)
      DDMAX=DDMAX+DDMAX
      IF(DDMAX.GT.DMAX) DDMAX=DMAX
      GO TO 8
   13 IF(F.GE.FA) GO TO 23
   28 FC=FB
      DC=DB
   29 FB=F
      DB=D
      GO TO 30
   12 IF(F.LE.FB) GO TO 28
      FA=F
      DA=D
      GO TO 30
   11 IF(F.GE.FB) GO TO 10
      FA=FB
      DA=DB
      GO TO 29
   71 DL=1.
      DDMAX=5.
      FA=FP
      DA=-1.
      FB=FHOLD
      DB=0.
      D=1.
   10 FC=F
      DC=D
   30 A=(DB-DC)*(FA-FC)
      B=(DC-DA)*(FB-FC)
      IF((A+B)*(DA-DC).GT.0.) GO TO 34
      FA=FB
      DA=DB
      FB=FC
      DB=DC
      GO TO 26
   34 D=0.5*(A*(DB+DC)+B*(DA+DC))/(A+B)
      DI=DB
      FI=FB
      IF(FB.LE.FC) GO TO 44
      DI=DC
      FI=FC
   44 IF (ITONE.LT.0)  GO TO 85
      IF (ABS(D-DI).LE.DACC) GO TO 41
      IF (ABS(D-DI)-0.03* ABS(D)) 41,41,45
   85 ITONE = 0
   45 IF ((DA-DC)*(DC-D).LT.0.) GO TO 47
      FA=FB
      DA=DB
      FB=FC
      DB=DC
      GO TO 25
   47 IS=2
      IF ((DB-D)*(D-DC).LT.0.) IS=3
      GO TO 8
   41 F=FI
      D=DI-DL
      DD=SQRT((DC-DB)*(DC-DA)*(DA-DB)/(A+B))
      DO 49 I=1,N
       IDIRN=IDIRN+1
       X(I)=X(I)+D*W(IDIRN)
   49  W(IDIRN)=DD*W(IDIRN)
      W(ILINE)=W(ILINE)/DD
      ILINE=ILINE+1
      IF (IPRINT.NE.1)  GO TO 51
   50 PRINT 52,ITERC,NFCC,F,(X(I),I=1,N)
   52 FORMAT(/10H ITERATION,I5,I15,16H FUNCTION VALUES,
     1 9X,3HF =,E21.14/(5E24.14))
      IF (IPRINT.GT.1)  GO TO 53
   51 IF (ITONE.LE.0)  GO TO 38
      IF (FPREV-F.LT.SUM) GO TO 94
      SUM=FPREV-F
      JIL=ILINE
   94 IF (IDIRN.LT.JJ) GO TO 7
      IF (IND.NE.0)  GO TO 72
   92 FHOLD=F
      IS=6
      DO 59 I=1,N
   59  W(I+JJ)=X(I)-W(I+JJ)
      DD=1.
      GO TO 58
   96 IF (IND.NE.0)  GO TO 87
      IF (FP.LE.F) GO TO 37
      D=2.*(FP+F-2.*FHOLD)/(FP-F)**2
      IF (D*(FP-FHOLD-SUM)**2.GE.SUM) GO TO 37
   87 J=JIL*N+1
      IF (J.GT.JJ) GO TO 61
      DO 62 I=J,JJ
   62  W(I-N)=W(I)
      DO 97 I=JIL,N
   97  W(I-1)=W(I)
   61 ITONE = -1
      IDIRN=IDIRN-N
      AAA=0.
      DO 65 I=1,N
       AAA = MAX(ABS(W(I+JJ)/E(I)),AAA)
   65  W(I+IDIRN)=W(I+JJ)
      DDMAG=1.
      W(N)=ESCALE/AAA
      ILINE=N
      GO TO 7
   37 AAA=0.
      F=FHOLD
      DO 91 I=1,N
       IF (AAA*ABS(E(I)).LT.ABS(W(I+JJ)))  AAA =  ABS(W(I+JJ)/E(I))
   91  X(I)=X(I)-W(I+JJ)
      GO TO 72
   38 AAA=AAA*(1.+DI)
      IF (IND.EQ.0)  GO TO 72
      INN = 0
      IF (AAA-0.1) 20,20,35
   72 IF (IPRINT.GE.2) GO TO 50
   53 IF (IND.NE.0)  GO TO 88
      IF (AAA.LE.0.1) GO TO 89
      IF (F.LT.FP) GO TO 35
   78 PRINT 80
   80 FORMAT (5X,37HVA04A ACCURACY LIMITED BY ERRORS IN F)
      GO TO 20
   89 IF (ICON.LE.1)  GO TO 20
      IND=2
      IF (INN.GT.0)  GO TO 101
      INN=2
      DO 102 I=1,N
       W(I+JJJ)=X(I)
  102  X(I)=X(I)+10.*E(I)
      FKEEP=F
CMOD  CALL CALCFX (N,X,F)
      CALL CALCFX(NN,X,F)
      NFCC=NFCC+1
      DDMAG=0.
      GO TO 108
   88 IND = 0
   35 ISGRAD=1
      DDMAG = 0.4*SQRT(FP-F)
  108 IF (ITERC-MAXIT) 5,81,81
   77 PRINT 75
   75 FORMAT(/' VA04A ACCEPTS COMMAND FROM CALCFX TO GIVE UP ',24(1H/)/)
      ITERC = ITERC-1
      IF (INN*IND.NE.0)  GO TO 81
      FKEEP = FP
      JJJ = JJ
   81 PRINT 82, ITERC
   82 FORMAT(I5,30H ITERATIONS COMPLETED BY VA04A)
      IF (F.LE.FKEEP) GO TO 20
      F=FKEEP
      DO 111 I=1,N
  111  X(I)=W(I+JJJ)
   20 RETURN
C     ======       IS.GT.0  ON ENTRY IN FOLLOWING OFF-LINE SECTION
  101 FP=FKEEP
      IF (F-FKEEP) 105,78,104
  104 IS = 0
      FP=F
      F=FKEEP
  105 K=JJ+N
      DO 113 I=1,N
       FHOLD = W(I+K)
       IF (IS.NE.0)  GO TO 113
       FHOLD = X(I)
       X(I)=W(I+K)
  113  W(I+JJ) = FHOLD
      JIL=2
      GO TO 92
      END
      SUBROUTINE CALCFX(N,DX,DF)
C
C     CALCFX HAS BEEN WRITTEN ACCORDING TO THE REQUIREMENTS OF SR.VA04A.
C     THE ROUTINE RETURNS THE VARIATIONAL FUNCTIONAL DF; DF DEPENDS UPON
C     N(.LE.MXLL) VARIATIONAL PARAMETERS DX, WHICH ARE INPUT.
C
cS    IMPLICIT INTEGER*2(I-L,N)
      DOUBLE PRECISION  ADJUST,DF0,DF,DX, ECORE,ESUM
      LOGICAL BPRINT
      DIMENSION DX(1)
      COMMON  MAXGR,NF  /OUTP/ MPRINT,BPRINT,MDUM,KDUM(3)
     * /CADJ/ ADJUST(15),DF0,IEQUAL(15),ICOUNT
      DATA MXLL/15/
C     MXLL = SIZE OF PARAMETER ARRAYS, DEFINED IN SR.MINIM
  799 FORMAT(/22H CALCFX-FUNCTIONAL FX=,E15.8,18H, =(E-ECORE0)/2RY=,
     *2E16.9,13X,17HCOUNTDOWN INDEX =,I4/)
  798 FORMAT(/116H SR.CALCFX: PARAMETERS IMAXIT AND NEXTRE ALLOW NO MORE
     * ITERATIVE STEPS -- IT MAY NOT BE SENSIBLE TO RESUME ITERATING)
C
C
C     ASSIGN VALUES DX TO SCALING FACTORS ADJUST(I), OF S,P,D..ELECTRONS
      DO 10 I=1,MXLL
      J=IEQUAL(I)
      IF (J.LE.0)  GO TO 10
C OUT IF (J.GT.N)  GO TO 10                                              85NOV21
      ADJUST(I) = DX(J)
   10 CONTINUE
C
C     UPDATE RADIAL FUNCTIONS
      KPRINT=0
      IF(MPRINT.LT.0) KPRINT=-1
      IF (BPRINT .OR. MPRINT.GE.0) KPRINT=1
      CALL RADIAL(ADJUST,KPRINT)
      IF (NF.LE.0)  GO TO 20
C
C     DIAGONALIZE ENERGY MATRIX;  ESUM + ECORE = DF + DF0
C      ESUM IS THE ENERGY SUM, WITHOUT THE CORE CONTRIBUTION ECORE;
C     IN THE ALTERNATIVE CASE JPRINT=-2 DIAGON RETURNS ESUM=G, ECORE=0
      CALL DIAGON(ECORE,ESUM,ICOUNT)
      IF (NF.LE.0)  GO TO 20
      IF (DF0.EQ.0.0)  DF0 = ECORE
      DF = (ECORE-DF0) + ESUM
C
C     PRINT THE COMPUTED VALUE OF THE FUNCTIONAL
      ECORE = -DF0
      ESUM = DF - ECORE
      IF (MPRINT.GE.-1)  PRINT 799,  DF, ESUM,ECORE, ICOUNT
C
      ICOUNT = ICOUNT-1
      IF (ICOUNT.NE.0)  GO TO 30                                        UCL75SEP
      PRINT 798
  20  N = 0
  30  RETURN
C
      END
      SUBROUTINE WEDDLE (A,B,NH,HN,JH,NDIM)
C     -- INTEGRATES ARRAY A, USING WEDDLE'S RULE -- J.A. BELLING, U.C.L.
      DOUBLE PRECISION  A,B,HN, H,A1
      DIMENSION A(0:NDIM),NH(JH),HN(JH)
      N=1
      B=0.
      DO 8 J=1,JH
      A1=A(N-1)
      J1=NH(J)
      H=HN(J)
      J2=MOD(J1,6)+1
      GO TO (6,1,2,3,4,5),J2
    1 B=B+(19087.D0*A1+65112.D0*A(N)-46461.D0*A(N+1)+37504.D0*A(N+2)-
     1 20211.D0*A(N+3)+6312.D0*A(N+4)-863.D0*A(N+5))/60480.D0*H
cP  1 B=B+(19087.  *A1+65112.  *A(N)-46461.  *A(N+1)+37504.  *A(N+2)-
cP   1 20211.  *A(N+3)+6312.  *A(N+4)-863.  *A(N+5))/60480.  *H
      GO TO 6
    2 B=B+(1139.D0*A1+5640.D0*A(N)+33.D0*A(N+1)+1328.D0*A(N+2)-807.D0*
     1 A(N+3)+264.D0*A(N+4)-37.D0*A(N+5))/3780.D0*H
cP  2 B=B+(1139.  *A1+5640.  *A(N)+33.  *A(N+1)+1328.  *A(N+2)-807.  *
cP   1 A(N+3)+264.  *A(N+4)-37.  *A(N+5))/3780.  *H
      GO TO 6
    3 B=B+(685.D0*A1+3240.D0*A(N)+1161.D0*A(N+1)+2176.D0*A(N+2)-729.D0*
     1 A(N+3)+216.D0*A(N+4)-29.D0*A(N+5))/2240.D0*H
cP  3 B=B+(685.  *A1+3240.  *A(N)+1161.  *A(N+1)+2176.  *A(N+2)-729.  *
cP   1 A(N+3)+216.  *A(N+4)-29.  *A(N+5))/2240.  *H
      GO TO 6
    4 B=B+2.D0*(143.D0*A1+696.D0*A(N)+192.D0*A(N+1)+752.D0*A(N+2)+87.D0*
     1 A(N+3)+24.D0*A(N+4)-4.D0*A(N+5))/945.D0*H
cP  4 B=B+2.  *(143.  *A1+696.  *A(N)+192.  *A(N+1)+752.  *A(N+2)+87.  *
cP   1 A(N+3)+24.  *A(N+4)-4.  *A(N+5))/945.  *H
      GO TO 6
    5 B=B+5.D0*(743.D0*A1+3480.D0*A(N)+1275.D0*A(N+1)+3200.D0*A(N+2)+
     1 2325.D0*A(N+3)+1128.D0*A(N+4)-55.D0*A(N+5))/12096.D0*H
cP  5 B=B+5.  *(743.  *A1+3480.  *A(N)+1275.  *A(N+1)+3200.  *A(N+2)+
cP   1 2325.  *A(N+3)+1128.  *A(N+4)-55.  *A(N+5))/12096.  *H
    6 N=N+J2-1
      J2=J1/6
      DO 8 J1=1,J2
       B=B+(41.D0*(A(N-1)+A(N+5))+216.D0*(A(N)+A(N+4))+27.D0*(A(N+1)
     * +A(N+3))+272.D0*A(N+2))*H/140.D0
cP     B=B+(41.  *(A(N-1)+A(N+5))+216.  *(A(N)+A(N+4))+27.  *(A(N+1)
cP   * +A(N+3))+272.  *A(N+2))*H/140.
    8  N=N+6
      RETURN
      END                                                                WEDDLE
      SUBROUTINE DIFF (A,B,NH,HN,JH)                                    UCL78FEB
C**   SUBROUTINE DIFF1(A,B,NH,HN,JH, L,Z,PB0,QB0)                          77
C       COMPUTES FIRST DERIVATIVE OF ARRAY A INTO ARRAY B, USING 7 POINT
C     LAGRANGE FORMULA - REFERENCE: W.G. BICKLEY, MATH.GAZ.25(1941)19-27
      DOUBLE PRECISION  A,B, HN, F
      DIMENSION A(   1),B(   1),HN(JH),NH(JH)                           86SEP19
C**   REGULAR RADIAL WAVE FUNCTION TO ORBITAL L ASSUMED IF L.GE.0
C**   IF (L.LT.0)  GO TO 5   ---   PB0,QB0,Z,D  ALSO DOUBLE PRECISION
C**   J = L+1  //  F = Z*PB0/J  //  DO 4 K=1,2  //   D = K*HN(1)
C**4   B(K) = ((((J+2)*(Z*F-QB0/2))/(2*J+1)*D - (J+1)*F)*D + J*PB0)*D**L
   5  N = 0
      DO 8 J=1,JH
       F = 1/(60*HN(J))
       NA = N+1
C**    IF (L.GE.0 .AND. N.EQ.0)  GO TO 6
       K = NA
       B(NA) = (-147*A(K)+360*A(K+1) -450*A(K+2) +400*A(K+3) -225*A(K+4)
     *          +72*A(K+5) -10*A(K+6))*F
       B(NA+1) = (-10*A(K) -77*A(K+1)+150*A(K+2)-100*A(K+3) +50*A(K+4)
     *            -15*A(K+5) +2*A(K+6))*F
   6   B(NA+2) = (  2*A(K) -24*A(K+1) -35*A(K+2) +80*A(K+3)-30*A(K+4) +
     *            8*A(K+5) - A(K+6))*F
       N = NH(J)+N
       NB = N-6
       DO 7 K=NA,NB
   7    B(K+3) = (((A(K+4)-A(K+2))*5+A(K+1)-A(K+5))*9+A(K+6)-A(K))*F       78FEB
       K = NB
       NB = N
       B(NB-2) = (  A(K) -8*A(K+1)+30*A(K+2) -80*A(K+3) +35*A(K+4) +24*
     *            A(K+5) -2*A(K+6))*F
       B(NB-1) = ( -2*A(K)+15*A(K+1) -50*A(K+2)+100*A(K+3)-150*A(K+4)
     *            +77*A(K+5) +10*A(K+6))*F
   8   B(NB) = ( 10*A(K) -72*A(K+1) +225*A(K+2) -400*A(K+3) +450*A(K+4)
     *         -360*A(K+5)+147*A(K+6))*F
      RETURN
      END
      SUBROUTINE YLAMK(L,M, A,B, NH,HN,JH, MODE)
C     -- EVALUATES RADIAL MULTIPOLE FUNCTIONS (OUTPUT ARRAY B) --
C     IT USES THE MODIFIED BODY OF J. A. BELLING'S SR.YLAM.  UCL76JAN/WE
C     MODE.EQ.0: YLAMK COMPUTES  COULOMB INTEGRALS YLAMBDA (REL.TO RLAM)
C     MODE.LT.0:                MAGNETIC INTEGRALS RELATED TO VLAM
C     MODE.GT.0:                                              NLAM
      DOUBLE PRECISION  H,H1,X,Z, A,B,HN, C,E,F
      DIMENSION A(0:*),B(0:*),NH(JH),HN(JH),C(5),E(5),F(5)
      K = 1                                                             UCL76FEB
      IF (MODE.NE.0)  K = 3                                              NEWCO
      J = L+K
      N = J
      IF (MODE.NE.0)  N = 2                                             (NEWCO)
      IF (J.LE.0 .OR. M.LT.N .OR. JH.LE.0)  GO TO 50
      N = 8                                                             UCL78JUN
      DO 51 I=1,JH
       IF (HN(I).LT.0.0)  GO TO 50
       IF (NH(I).LT.N)  GO TO 50
   51  N = 5
      H=HN(1)
      J1 = M-1
      X=0.
      DO 1 I=1,4
      X=X+H
    1 C(I) = A(I)/X**J1                                                 (NEWCO)
cP    Z = H*24.                                                         UCL78JUN
      Z=H*24.D0
cP    E(1) = (96.  *C(1)-72.  *C(2)+32.  *C(3)-6.  *C(4))/Z             UCL78JUN
      E(1) = (96.D0*C(1)-72.D0*C(2)+32.D0*C(3)-6.D0*C(4))/Z
      Z=H*Z
cP    E(2) = (-104.  *C(1)+114.  *C(2)-56.  *C(3)+11.  *C(4))/Z
      E(2) = (-104.D0*C(1)+114.D0*C(2)-56.D0*C(3)+11.D0*C(4))/Z
      Z=H*Z
cP    E(3) = (36.  *C(1)-48.  *C(2)+28.  *C(3)-6.  *C(4))/Z
      E(3) = (36.D0*C(1)-48.D0*C(2)+28.D0*C(3)-6.D0*C(4))/Z
      Z=H*Z
cP    E(4) = (-4.  *(C(1)+C(3))+6.  *C(2)+C(4))/Z
      E(4) = (-4.D0*(C(1)+C(3))+6.D0*C(2)+C(4))/Z
      X=0.
      DO 3 N=1,4
      X=X+H
      C(N)=0.
      DO 2 I1=1,4
      I2=5-I1
      Z=L+M+I2
    2 C(N)=E(I2)/Z+C(N)*X                                               UCL78JUN
      B(N)=C(N)*X**(M-K+1)
    3 C(N)=B(N)*X**J
      E(4)=A(4)*X**L
      N=4
      I1 = 8
      DO 10 J1=1,JH
      H=HN(J1)
cP    H1=H/22.5
      H1=H/22.5D0
      E(1)=E(4)
      C(1)=C(4)
      DO 4 I=2,5
      N=N+1
      X=X+H
      Z=X**L
      E(I) = Z*A(N)
    4 F(I) = Z*X**K
      C(2) = C(1) + H*(                                                 UCL75NOV
cP   C251.  *E(1)+646.  *E(2)-264.  *E(3)+106.  *E(4)-19.  *E(5))/720.
     C251.D0*E(1)+646.D0*E(2)-264.D0*E(3)+106.D0*E(4)-19.D0*E(5))/720.D0
      B(N-3)=C(2)/F(2)
cP    C(3)=C(1)+H*(29.  *E(1)+124.  *E(2)+24.  *E(3)+4.  *E(4)-E(5))/90.
      C(3)=C(1)+H*(29.D0*E(1)+124.D0*E(2)+24.D0*E(3)+4.D0*E(4)-E(5))/
     190.D0
      B(N-2)=C(3)/F(3)
cP    C(4)=C(1)+H*(9.  *E(1)+34.  *E(2)+24.  *E(3)+14.*E(4)-E(5))*3./80.
      C(4)=C(1)+H*(9.D0*E(1)+34.D0*E(2)+24.D0*E(3)+14.D0*E(4)-E(5))*3.D0
     1/80.D0
      B(N-1)=C(4)/F(4)
      I2=NH(J1)
      DO 9 I=I1,I2
      IF (I.EQ.I1)  GO TO 8                                             UCL78JUN
      N=N+1
      X=X+H
      Z=X**L
      F(5)=Z*X**K
      E(5)=Z*A(N)
cP  8 C(5)=C(1)+H1*(7.  *(E(1)+E(5))+32.  *(E(2)+E(4))+12.  *E(3))
    8 C(5)=C(1)+H1*(7.D0*(E(1)+E(5))+32.D0*(E(2)+E(4))+12.D0*E(3))
      B(N)=C(5)/F(5)
      DO 9  I3=1,4
      C(I3)=C(I3+1)
    9 E(I3)=E(I3+1)
   10 I1 = 4
      A(0) = C(5)
      IF (MODE.GT.0)  GO TO 90                                          UCL76FEB
      C(5) = 0.0
C NEW C(5) = B(0)
      I1 = 1
      X=X+H
      DO 19 J1=1,JH
      I3=JH-J1+1
      H=HN(I3)
cP    H1=H/22.5
      H1=H/22.5D0
      E(1)=E(5)
      C(1)=C(5)
      I2=NH(I3)
      I3 = N
      DO 11 I=I1,5
      X=X-H
      F(I)=X**L
      E(I)=A(N)/(F(I)*X**K)
   11 N=N-1
      C(2) = C(1) + H*(                                                 UCL75NOV
cP   C251.  *E(1)+646.  *E(2)-264.  *E(3)+106.  *E(4)-19.  *E(5))/720.
     C251.D0*E(1)+646.D0*E(2)-264.D0*E(3)+106.D0*E(4)-19.D0*E(5))/720.D0
cP    C(3)=C(1)+H*(29.  *E(1)+124.  *E(2)+24.  *E(3)+4.  *E(4)-E(5))/90.
      C(3)=C(1)+H*(29.D0*E(1)+124.D0*E(2)+24.D0*E(3)+4.D0*E(4)-E(5))/
     190.D0
cP    C(4)=C(1)+H*(9.  *E(1)+34.  *E(2)+24.  *E(3)+14.*E(4)-E(5))*3./80.
      C(4)=C(1)+H*(9.D0*E(1)+34.D0*E(2)+24.D0*E(3)+14.D0*E(4)-E(5))*3.D0
     1/80.D0
cP    C(5)=C(1)+H1*(7.  *(E(1)+E(5))+32.  *(E(2)+E(4))+12.  *E(3))
      C(5)=C(1)+H1*(7.D0*(E(1)+E(5))+32.D0*(E(2)+E(4))+12.D0*E(3))
      DO 12 I=I1,5
      IF(MODE.LE.-999) B(I3)=0.0                                        MOD80FEB
      B(I3) = C(I)*F(I) + B(I3)                                         UCL78JUN
   12 I3 = I3-1
      DO 18 I=5,I2
      DO 14 I3=1,4
      E(I3)=E(I3+1)
   14 C(I3)=C(I3+1)
      E(5) = 0.0
      IF (N.EQ.0)  GO TO 16                                             UCL78JUN
      X=X-H
      Z=X**L
      E(5)=A(N)/(Z*X**K)
cP 16 C(5)=C(1)+H1*(7.  *(E(1)+E(5))+32.  *(E(2)+E(4))+12.  *E(3))
   16 C(5)=C(1)+H1*(7.D0*(E(1)+E(5))+32.D0*(E(2)+E(4))+12.D0*E(3))
      IF (N.EQ.0)  GO TO 20                                             UCL78JUN
      IF(MODE.LE.-999) B(N)=0.0                                         MOD80FEB
      B(N) = C(5)*Z+B(N)
   18 N=N-1
   19 I1 = 2
   20 B(0) = C(5)
   90 RETURN
   50 PRINT 99, L,MODE, M, JH,(NH(I),HN(I),I=1,JH)                      (NEWCO)
      GO TO 90
   99 FORMAT(/20X,20HINPUT ERROR IN YLAMK,20X,7HL,MODE=,2I5,5X,2HM=,I3, (NEWCO)
     C 5X,3HJH=,I3,5X,6HNH,HN=/(10X,5(I5,E16.8)))
      END
      SUBROUTINE RADIAL(ADJUST,KPRINT)
C
C   CALCULATES THOSE RADIAL FUNCTIONS <NL|X> FOR WHICH THE S.M.POTENTIAL RADIAL
C     V(L) IS TO BE CHANGED SINCE PREVIOUS CALLS, ADJUST(J).NE.ADJOLD(J) RADIAL
C     J=L+1; FOR FUNCTIONS NOT NEEDED DEY(K) HAS BEEN INITIALIZED AS 0.; RADIAL
C     NK,LK=QN(K),QL(K)/2, NORMALLY (ALGEB1) K=1,2,3.. FOR NL=1S,2S,2P.. RADIAL
C
cM    IMPLICIT INTEGER*2(Q)
cS   C        ,INTEGER*2(I-L,N)
      INTEGER QCG,QL,QN
      LOGICAL HFF,OLD(15)
      DOUBLE PRECISION DD1,DD2,DD3,E,HNS,DJ,S,Z, DEY,POT,DPNL,DQNL,DUY,
     C   X,ADJUST,ADJOLD,DP, DA, DM,ZEF, F100
      DIMENSION ADJUST(15),LORTH(15),DA(0: 999),ZEF(0: 999)
     C  ,DQNL(0: 999,15),POT(0: 999),DP(0: 999),LSH(15)
     C  ,MNH(10),MORT(5)
      COMMON MAXGR,NF,KV,HFF,MQ
     C /GENINF/ADJOLD(15),SCREEN(15),MION,NZION,NPARAM,ITOL
     C             , INCL,JPRT,NGROUP,IZDW
     C /DBD2/ DEY(15),QCG(54, 60),QL(15),QN(15)
     C /CRAD/ HNS(10),MNE(10),MJH,MAXQS,JEND(15)
     C /RADF/ X(0: 999),DPNL(0: 999,15),DUY(15,15)
     C /REL/ DMASS(15,15),DCD(15,15),D2LL(15,15)
cD    COMMON /CADJ/ ADJUST  /DQNL/ DQNL -- '93fevr27:                   85AP86JL
      COMMON /DQNL/ DQNL
C
  975 FORMAT(///47H RADIAL FUNCTIONS:   PRECISION OF EIGENVALUE IS,E9.2,
     * I9,25H POINTS;    ATOMIC NUMBER,I3,23H,   NUMBER OF ELECTRONS,I3)
  776 FORMAT(3X,7HORBITAL,I3,3X,5HN L =,2I2,4X,
     C 38HS.M.-POTENTIAL V(NL) WITH SCALE FACTOR,F12.6,
     C 27H:  COULOMBIC BEYOND R(IEND=,I3,3H) =,F9.5)
  777 FORMAT(52X,16HFOR PETE ORBITAL,I3,5H, N =,I3,11H CHANGED TO,I3)    85APJL
  778 FORMAT(/' ABORT IN RADIAL: SET MAXB2 GT IEND =',I5,'  OR = MAXB1')89AVR18
  779 FORMAT(/1X,76('*')/' *** ERRORS -- RESULTS UNRELIABLE; INCREMENT M
     *AXB2 =',I4,' TO AT LEAST',I5,' ***'/1X,76(1H*)/)
  630 FORMAT(2I5,1X,F5.4,F7.2,2X,I3,2I4,36X,4HZSTR)
  631 FORMAT(5H   -7,2I5,I3,F4.0,I3,F12.6,I6,F12.6,2X,A4,F10.5,5H ZSTR)
  632 FORMAT((5H   -8,2(I4,1P,2E14.7),3X,4HZSTR))
  633 FORMAT((5H   -6,2(I4,1P,2E14.7)))
C
C   SET UP THE INTERVALS FOR THE RADIAL FUNCTIONS
      DATA MAXA/ 999/, MXQIN/ 999/, DEL/1.E-6/, DKEY/999./,
     C     MNH /16,32,32,32,32,64,48,32,32,32/, MJH0/10/,F100/100./,
     C     MORT/4HS.M.,4HNOOR,4HORTH,4HO.K.,4HPJS>/, EY0,KYM9/0.,-9/
C   NOTE: ANY VALUE MNH(J).LT.9 STEPS PER INTERVAL J WILL CAUSE TROUBLE;
C     SO WILL A NUMBER MJH0.LT.2 OF INTERVALS; MJH0.LE.DIM(MNH,MNE,HNS)
C
C   THE RADIAL FUNCTIONS WILL BE CALCULATED UNTIL THE RELATIVE CHANGE IN
C          THE EIGENVALUE IS SMALLER THAN TOL
C
      TOL = 1./10**ITOL
      X(0) = TOL
      Z = NZION
      POT(0) = Z
C
C   EXPERIENCE HAS SHOWN THAT THIS LENGTH FOR THE SMALLEST INTERVAL
C          GIVES IN MOST CASES A REASONABLE INTERVAL SET-UP
C
C     HNS(1) = ( 26.0/Z )**(1./3.) / (2**11)  ---  IN SR.MINIM
      MRAD = MJH0
      IF(MJH.NE.0) MRAD=MIN(MJH,10)
C
      MAXPS = MAXQS
  616 E = HNS(1)
      S = 0.
      MAXRS = 0
      DO 619 J=1,MRAD
       L = MAXRS
       M = MAXRS+MNH(J)
C      IF(M+9.GT.MAXA) M=MAXA
C      THE PRECEEDING STATEMENT REPLACES WERNERS STATEMENT
       IF (J.EQ.MRAD .OR. M+9.GT.MAXA)  M = MAXA
C      WHICH CAN CAUSE PROBLEMS BECAUSE MAXB1 MAY BE AUTOMAT. REDEFINED?
       MAXRS = MIN(M,MAXA)
       MNE(J) = M-L
       IF (MNE(J).LE.0) GO TO 619
       HNS(J) = E
       DO 618 I=L+1,MAXRS
        S = E+S
  618   X(I) = S
       MJH = J
  619  E = E*2
C   MAXRS = NUMBER OF POINTS FOR WHICH THE RADIAL FUNCTIONS WILL BE
C          CALCULATED; MJH INTERVALS WITH MNE(I),I=1,MJH STEPS
C
C
C   CALCULATE DPNL(I,K) = <NL(K)|X(I)> FOR NK,LK=QN(K),QL(K)/2 AT X(I);
C     EVALUATE DUY(J,K) = <NL(J)| V(L)-Z/X |NL(K)> FOR LJ=LK=L, E&N 2.8,
C     AND FOR N'=N DEY(K) = DUY(K,K) + EIGENENERGY/2RY(=2EPSILON,E+N2.1)
C   SR. TFDAPO CALCULATES STATISTICAL MODEL POTENTIAL FOR MION ELECTRONS
C     AND ELECTRIC NUCLEAR CHARGE Z;
C     OUTPUT: POTENTIAL IN POT(I); X(I)=X(I) FROM INTERVAL SET-UP MJH...
C     HNS(M)=HNS(1)*2**(M-1); X(MEND)= RANGE OF NON-COULOMB POTENTIAL
C   SR. RADWAV CALCULATES RADIAL FUNCTIONS RHO IN POTENTIAL FROM TFDAPO.
C   SR. RADWIN READS USER-SUPPLIED RADIAL FUNCTION INPUT.
C
      IF (NF.LE.0)  GO TO 620
      IF(KPRINT.GE.0) PRINT 975, TOL,MAXRS, NZION,MION
      MRAD = 0
      DJ = 0.0
      MP = -ABS(MQ)
C     RUN THROUGH L=J-1 UP TO LARGEST IN USE:
      DO 603 J=1,NPARAM
       N = 0
       NEW = 0
C       " SECURES UPWARD ORTHOGONALIZATION -- QUB'91JUN05!
       MYL = J-1
       DO 602 K=1,MAXGR
        IF (QL(K).NE.MYL*2) GO TO 602
        IF (DEY(K).EQ.0.)  GO TO 602
        OLD(K)=.TRUE.
        IF (ADJUST(K).EQ.ADJOLD(K) .AND. ABS(MP)+KV+NEW.EQ.0) GO TO 602 85NV89MY
        SC = SCREEN(K)
        IF (SC.GT.DKEY .AND. DJ.NE.0.) GO TO 602                        DL85AP6&
C                      'AND...' REQUIRED TO SET UP RADIAL MESH.         86JLY07
        MYN = QN(K)
        DM = ADJUST(K)
        IF (DM.LT.0.0) GO TO 611
C       BYPASS TFDAPO IN HYDROGENLIKE CASE.
        IF (DM.EQ.DJ) GO TO 601
        CALL TFDAPO(POT,MION,DM,MEND, MAXRS,MJH,MNE,HNS,X)
        IF (HNS(1).EQ.X(1))  GO TO 635
C       STEP LENGTH DOUBLES IF RANGE APPEARS TO BE TOO SMALL:
        GO TO 636
  611   M = -DM/100.
        IF (M.EQ.0) GO TO 626
        IF(KPRINT.GE.0)  PRINT 777, K, MYN,M
        DM = (DM+100*M)
        MYN = M
  626   IF (DM.EQ.DJ) GO TO 601
C       NOW PETE-POTENTIAL WHENEVER M SPECIFIED IN SCALED COULOMB CASE: 86JLY27
        IF(N.EQ.0) N=5
        E = -Z*DM
C ?|?   E = -DM -- SO ERRONEOUSLY IN BESSS EQ.(3.4).
        MEND=0
        DO 634 I=1,MAXRS
         S = 0.
         IF(M.EQ.0) GO TO 634
         IF(Z*X(I).GT.64.47) GO TO 634
         S = EXP(-Z*X(I)/2.)
         IF(ABS(E-Z)*Z*S.GT.E*10.*TOL) MEND=I
  634    POT(I) = ((1.-S)*E+S*Z)/X(I)
        IF(S.LT.1.E-4) GO TO 635
  636   HNS(1) = HNS(2)
        DO 617  I=1,MAXGR
  617    ADJOLD(I) = 0.0
        MAXPS = 0
        GO TO 616
  635   IF(KPRINT.GE.0)  PRINT 776, K, MYN,MYL, DM,MEND,X(MEND)
        IF(N.EQ.1) N=2
        IF(MRAD.EQ.0) MRAD=MEND-MOD(MEND,2)+1
        DJ = DM
        IF(MXQIN.GE.MEND) GO TO 601
        PRINT 778, MEND
        GO TO 621
  601   IF (SCREEN(K).GT.DKEY)  GO TO 602                               -&85JL14
        NEW = 1
        CALL RADWAV(MYN,MYL,POT,MEND,MAXRS,MJH,MNE,HNS,X,SC,DP,DA,E)
        IF (MYN.LE.0)  GO TO 621
        OLD(K)=.FALSE.
        S = 0.
        DD2 = 0.0
        DO 606 M=0,MAXRS
         DD3 = DP(M)
         IF (M.EQ.0) GO TO 690
         DD1 = ABS(DD3)
         IF (DD1.GT.S) S = DD1
         IF (DD1.GT.DEL)  MAXPS = MAX(M,MAXPS)
         IF(MQ) 657,655,654
  654    IF(M.LE.MEND+2) GO TO 655
C        CHANGED AFTER CLAUDIO'S TROUBLE WITH A VII UCL/QUB'90JUL16-7:
C TMP    IF(M.LE.MEND+6) GO TO 655 -- NOT NECESSARY.
         IF(MYN.EQ.0) GO TO 658
         IF(-E*X(M)*X(M).LT.1.) GO TO 655
C TMP    IF(-E*X(M)*X(M).LT.4.) GO TO 655
         IF((DP(M-2)-DP(M-1))*(DP(M-1)-DD3).LE.0.) MYN=0
         IF(DD2.GT.DD1) GO TO 658
  655    IF(DD1+DD2.LE.0.) GO TO 658
         LSH(K)=M
  656    MRAD=MAX(M,MRAD)
         GO TO 658
  657    IF(M.GE.MXQIN) GO TO 658
         IF(DD1.GT.S*1.E-6) GO TO 655
  658    IF(MP.GE.0) GO TO 659
         ZEF(M)=POT(M)*X(M)
  659    DD2=DD1
         IF (M.GT.MXQIN)  GO TO 606
  690    DQNL(M,K) = DA(M)
  606    DPNL(M,K) = DD3
        MP = ABS(MP)
        IF(N.EQ.0) N=1
        LORTH(K)=N
        DEY(K) = E
        JEND(K) = MEND
C       SIGN AS A MARKER WHICH SLATER INTEGRALS TO RECALCULATE IN DIAGONTE85AP5
        IF(SCREEN(K).LT.DKEY) SCREEN(K) = SC
  602   CONTINUE
  603  CONTINUE
C
C     PUNCH RADIAL GRID
      MRAD=MIN(MRAD+1,MAXRS)+1
C LTR IF(HFF) MRAD=MAXRS+1
      X(0) = 0.
      IF(MQ) 643,640,644
  643 MRAD=MRAD-MOD(MRAD,2)
  644 WRITE(MP,630)  KYM9, NGROUP, X(1),X(MRAD-1), MRAD, MION, NZION
      ZEF(0) = Z
      WRITE(MP,632)  (I,X(I-1),ZEF(I-1),I=1,MRAD)
  640 J=0
      M = MIN(MXQIN,MAXRS)
      DO 642 K=1,MAXGR
       E = DEY(K)
       IF(E.EQ.0.) GO TO 642
       IF(SCREEN(K).GE.DKEY) GO TO 642
       DJ=ADJUST(K)
C      IF(ADJOLD(K).EQ.DJ .AND. KV+MP.EQ.0) GO TO 642 -- RUB'95SEP07:
       IF(ADJOLD(K).EQ.DJ .AND. KV+MP.EQ.0 .AND. OLD(K)) GO TO 642
       N = MIN(LSH(K)+2,MRAD)
       IF(DPNL(N,K).EQ.0.) N=N-1
       IF(DPNL(N,K).EQ.0.) N=N-1
       IF(MP.EQ.0) GO TO 622
       MYL=QL(K)/2
       MYN=QN(K)
       IF(MQ.LE.0) GO TO 622
       I=LORTH(K)
       L=(N+1)/2
       WRITE(MP,631)  K,MYN,MYL,   Z,MION, E, L, EY0,MORT(I), DJ
       DO 651 I=0,M
  651   ZEF(I) = DQNL(I,K)
       IF(M.GE.N) GO TO 623
       DM=(ZEF(M)/DPNL(M,K)-E)*X(M)
       DO 652 I=M,MAXRS
  652   ZEF(I) = (DM/X(I)+E)*DPNL(I,K)
  623  WRITE(MP,633) (I,DPNL(I-1,K),ZEF(I-1),I=1,N)
  622  DP(0) = 0.0
       DO 604  L=1,K
        IF (QL(K).NE.QL(L))  GO TO 604
        IF (DEY(L).EQ.0.0) GO TO 604
        IF (ADJUST(L).EQ.DJ)  GO TO 604
        IF (DJ.GT.0.)  GO TO 505
        IF (ADJUST(L).GT.0.0)  GO TO 505
        IF (MOD(ADJUST(L)-DJ,F100).EQ.0.)  GO TO 604
C       ORTHOGONALIZE IF DIFFERENT SCALING FACTORS FOR SAME LL USED
C       (BUT NO ATTEMPT TO ORTHOG. L.GT.K WHILE VARIATIONALLY ITERATING)
  505   DO 510 I=1,MAXRS
  510    DP(I)=DPNL(I,K)*DPNL(I,L)
        CALL WEDDLE(DP,S,MNE,HNS,MJH,MAXRS)
        DO 515 I=0,MAXRS
  515    DPNL(I,K)=DPNL(I,K)-S*DPNL(I,L)
        DO 520 I=0,M
  520    DQNL(I,K)=DQNL(I,K)-S*DQNL(I,L)
C LTR   DUY(L,K)=S
        IF (KPRINT.GT.0)  PRINT 2000, K,L,S
 2000   FORMAT(34X,7HORBITAL,I5,3X,25HORTHOGONALISED TO ORBITAL,I5,4X,
     C  10HOVERLAP IS,F10.5)
        N = 0
  604   CONTINUE
       L = 4
       DM = E
       IF (N.NE.0) GO TO 605
       DP(0) = 0.
       DO 525 I=1,MAXRS
  525   DP(I)=DPNL(I,K)*DPNL(I,K)
       CALL WEDDLE(DP,S,MNE,HNS,MJH,MAXRS)
       DM = 1./SQRT(S)
       S = 0.
       DO 528 I=0,MAXRS
        DD3 = DPNL(I,K)*DM
        IF (I.EQ.0) GO TO 689
        DD2 = ABS(DD3)
        IF (DD2.GT.S) S = DD2
        IF (DD2.GT.S*1.E-5 .AND. J.LT.I) J=I
        IF (I.GT.MXQIN)  GO TO 528
        IF (DD2.GT.S*1.E-6)  N = I
  689   DQNL(I,K)=DM*DQNL(I,K)
  528   DPNL(I,K) = DD3
       IF(KPRINT.GT.0)  PRINT 2001, K,DM
 2001  FORMAT(34X,7HORBITAL,I5,3X,12HRENORMALISED,F10.5)
       L = 3
       DM=0.0
  605  IF(MQ.GE.0) GO TO 627
C TST  IF(MQ.EQ.-7) N=MRAD
       I = MIN(MRAD,N+1)/2
       N = 2*I
       IF(N.LE.JEND(K)+2) DM=0.
       WRITE(MP,631) K,MYN,MYL,   Z,MION,DM, I, E, MORT(L), DJ
       WRITE(MP,633) (I,DPNL(I-1,K),DQNL(I-1,K),I=1,N)
C
C      COMPUTE ONE-BODY INTEGRALS
  627  DA(0) = 0.
       DO 624 I=M,MAXRS
        DP(I) = 0.0
  624   DA(I) = 0.0
       DO 613  L=1,K
        IF (QL(K).NE.QL(L))  GO TO 613
        IF (SCREEN(L).GT.DKEY)  GO TO 613
        DD3 = 0.0
        DD2 = 0.0
        DD1 = 0.0
        S = 0.0
        IF (DEY(L).EQ.0.0)  GO TO 614
        IF (KV.EQ.0)  GO TO 625
C       SKIP RELATIVISTIC CODE UNLESS AND UNTIL REQUIRED.
        DO 615  I=1,M
         DD1 = DPNL(I,K)
         DD3 = DPNL(I,L)
         DM = 2*Z/X(I)
         S = DM*DD3+DQNL(I,L)
         DA(I) = DD1*S
  615    DP(I) = (DQNL(I,K)+DM*DD1)*S
        CALL WEDDLE(DA,DD3,MNE,HNS,MJH,MAXRS)
C       CALCULATE VALUE OF THE INTEGRAND AT THE ORIGIN:
        IF (QL(K).EQ.0) DD2 = DPNL(0,K)*DPNL(0,L)*Z
        DP(0) = 4*Z*DD2
        CALL WEDDLE(DP,DD1,MNE,HNS,MJH,MAXRS)
        DD2 = DD2 * 0.66561925E-5
        DD1 = -DD1 * 0.66561925E-5
  625   DO 607 I=1,M
  607    DA(I) = DQNL(I,K)*DPNL(I,L)
        CALL WEDDLE(DA,S,MNE,HNS,MJH,MAXRS)
  614   DMASS(K,L) = DD1
        DCD(K,L) = DD2
        D2LL(K,L) = DD3
        DUY(K,L) = S/2
  613   CONTINUE
       DEY(K) = DUY(K,K)
       DUY(K,K) = (S-E)/2
       ADJOLD(K) = ADJUST(K)
  642  CONTINUE
      IF(J.GT.M) PRINT 779, M,J
      GO TO 620
C
  621 NF = 0
  620 IF (.NOT.HFF)  GO TO 612
      MAXQS = MAXRS
      CALL RADWIN(DQNL,MXQIN,MAXGR,MAXPS)
C     TO READ RADIAL BOUND FUNCTIONS AS INPUT AND PROCESS THEM.
C
C
C     DROP POINTS I BEYOND WHICH ALL /<NL|X>/.LT.DEL
C
  612 MAXQS = 0
      IF (MP.GT.0)  WRITE(MP,630) MAXQS
      DO 610  I=1,MJH0
       MAXQS = MNE(I) + MAXQS
       MJH = I
       IF (MAXQS-MAXPS)  610,609,608
  608  MAXQS = MAXQS - MNE(I)
       MNE(I) = MAX(MAXPS-MAXQS,9)
       MAXQS = MAXQS + MNE(I)
       GO TO 609
  610  CONTINUE
  609 RETURN
      END
      SUBROUTINE TFDAPO(POT,NION,ADJUST,IEND, NPTS,NI,NTI,DXI,X)
C
C     -- CALCULATES A THOMAS-FERMI-DIRAC-AMALDI POTENTIAL (EN PART 2.2).
C     QUANTITIES REQUIRED: TOL=X(0), ALL ARGUMENTS EXCEPT DXI AND IEND;
C     Z=POT(0) = NUCLEAR CHARGE, NION = NUMBER OF ELECTRONS IN THE ION
C     ADJUST = SCALING PARAMETER (A VALUE GT 1.0 CONTRACTS THE EFFECTIVE
C       RADIAL SCALE, I.E. Z FALLS OFF MORE SLOWLY TOWARDS RESIDUAL ZN.
C     DXI(J),J=1,NI = STEP LENGTH IN THE J'TH INTERVAL -- STEP LENGTH IS
C     DOUBLED IN SUCCESSIVE INTERVALS, X(1)=DXI(1) IS INPUT - SO ARE THE
C     NUMBERS NTI(J) OF STEPS IN THE NI INTERVALS J;  ANOTHER RESULT IS
C     X(I),I=1,NPTS = RADIAL DISTANCE AT THE NPTS RADIAL POINTS I;
C     NPTS MUST BE EITHER EXACT OR LE 0 AND WILL BE EXACT ON RETURN.
C     IEND = INDEX OF THE LAST POINT FOR WHICH THE EFFECTIVE CHARGE HAS
C     NOT NECESSARILIY THE RESIDUAL VALUE ZN; FOR X.GT.X(IEND) THE
C     POTENTIAL IS ZN/X=(Z-NION+1)/X. IF THE RANGE X(NPTS) IS TOO
C     SMALL FOR THE EFFECTIVE CHARGE TO DROP TO ZN CONTROL IS RETURNED
C     WITH X(1)=2*X(1) -- WHILE DXI(1) CONTAINS ITS ORIGINAL VALUE.
C     POT(I),I=1,NPTS = VALUE OF THE POTENTIAL AT THE POINTS X(I).
C     TOL, TYPICALLY 1.E-6, =ACCURACY: MAY NOT MATCH MACHINE PRECISION
C     - ABOUT 1.E-5 WOULD MATCH A 24-BIT MANTISSA.
C
      DOUBLE PRECISION  POT, F,FE,H, ZN,Z,DXI,X,XB,V0,TOL1, ADJUST,
     C  BB,DMU0,DMUE,Y0,YY0,Y1,YY1,DLOW,HIGH, YLOW,YHIGH
      DIMENSION X(0:NPTS),DXI( 1),NTI( 1), POT(0:NPTS), F(2),FE(2)
C     DATA CHIA,CHIK,PI/.73855876638,2.8712340002,3.1415926536/         *87FE14
C     CHIA=0.75*(3.0/PI)**(1.0/3.0);   CHIK=0.3*(3.0*PI*PI)**(2.0/3.0)
C     BB=5*CHIA*CHIA/(12*CHIK);   DMU0=0.25*(9.0*PI*PI/2.0)**(1.0/3.0)
      DATA  DMU0/.88534131027D0/, BB/.79157174720D-1/
cP    DATA  DMU0/.88534131027/, BB/.079157174720/
  996 FORMAT(/' SR TFDAPO  (ADJUST,X(IEND),FE(1)) =',3F10.5/ 41H  RETURN
     * WITH INITIAL STEP LENGTH DOUBLED)
  995 FORMAT(3I5)
  993 FORMAT(/25H TFDAPO  IEND.GT.NPTS, AT,F9.4,3H*A0)
  992 FORMAT(/38H TFDAPO: NPTS INCOMPATIBLE WITH NTI,NI)
C
C     DETERMINE ASYMPTOTIC CHARGE
      Z = POT(0)
      ZN = Z-NION+1
      TOL = X(0)
C
C     SET UP THE X ARRAY
C
CNEW  IF (NPTS.GT.0)  GO TO 3
      ISTEP = 0
C     X(1) = STEP LENGTH IN THE FIRST INTERVAL (I=1)
C     THE STEP LENGTH DOUBLES FROM ONE INTERVAL TO THE NEXT
      H = X(1)
      XB = 0.0
      DO 2  J=1,NI
      DXI(J) = H
      II = NTI(J)
      DO 1  I=1,II
      XB = XB+H
    1 X(I+ISTEP) = XB
      ISTEP = II+ISTEP
    2 H = 2*H
      IF (NPTS.LE.0)  NPTS = ISTEP
CNEW  NPTS = ISTEP
      IF(ISTEP.EQ.NPTS) GO TO 3
      PRINT 992
      STOP
C
C     IF ONLY ONE ELECTRON IS PRESENT THE POTENTIAL IS PURELY COULOMBIC
    3 IEND = 0
      IF (NION.EQ.1)  GO TO 192
C
      DMUE = ((NION/(NION-1.0))**2/Z)**(1./3.) * DMU0  *  ADJUST
C     EN 2.14 AND 2.20,  *ADJUST
C
C     WE SHALL TRANSFORM X OF EN 2.20 TO Y WITH Y*Y=X
      YY1 = SQRT(X(1)/DMUE)/2
      IF(YY1.GT.0.01) YY1=.01
      Y1=YY1*YY1*DMUE
      DLOW=0.
      YLOW=0.
      ILOW = 1
      ISTEP = 1
C
C     TRY THE INTEGRATION FROM THE END OF EACH INTERVAL UNTIL THE
C     FUNCTION REACHES A VALUE GT 1 AT Y.EQ.0.
C
      DO 21 I=1,NI
      II=IEND+1
      IEND=IEND+NTI(I)
C     FILL POT(I) TEMPORARILY WITH Y(I) CORRESPONDING TO X(I)
      DO 10 J=II,IEND
   10  POT(J) = SQRT(X(J)/DMUE)
      J = 8
C     IN THE FIRST INTERVAL THE INTEGRATION IS DONE FROM A SMALL
C     DISTANCE TO ASSURE THAT THE FIRST FUNCTION VALUE AT Y.EQ.0 IS LT.1
      IF (I.EQ.1) GO TO 13                                              83APR03
   33 ISTEP = 7
      IF (I.EQ.NI) GO TO 11
      IF(I.LE.3) GO TO 21
      IF(ZN.LT.2.1) GO TO 11
      IF (MOD(I,2).NE.0) GO TO 21                                       78JN83AP
   11 J=IEND
C     IF THE INTEGRATION INTERVAL BECOMES GT 0.5 REDUCE IT
   12 ISTEP=ISTEP-1
      IF(ISTEP.EQ.1) GO TO 13                                           UCL78JUN
      IF (POT(J)-POT(J-ISTEP).GT..5) GO TO 12                           83APR04
   13 IHIGH=J
      YHIGH=POT(J)
      Y0=YHIGH
C     CALCULATE THE FUNCTION AT X0 (EN 2.17)
      F(1)=BB*Y0*Y0*DMUE/Z
C     CALCULATE THE FIRST DERIVATIVE AT X0
      F(2)=2*(F(1)-ZN/Z)/Y0
   20 Y0=POT(J)
      J=J-ISTEP
      H=YY1-Y0
      IF (J.GT.0)  H=POT(J)-Y0
C     INTEGRATE 1 STEP
      CALL RK1ST(Y0,F,H,2,YY0,FE)
      F(1)=FE(1)
      IF(FE(1).LT.1.E10) GO TO 201                                      UCL78JUN
      J=IHIGH-NTI(I)/10-1
      GO TO 13
  201 F(2)=FE(2)
      IF (J.GT.0)  GO TO 20                                             78JN87MR
      HIGH = FE(1) + (SQRT(FE(1))*YY1)**3*2./3. - FE(2)*(YY1/2.+YY1**4)
      IF(HIGH.GT.1.) GO TO 22                                           UCL78JUN
      IF (I.NE.NI) GO TO 32
C     CUT TROUBLESOME FINAL INTERVAL IF TOO LONG - INSERTED 1983 EASTER 83APR04
      IF (IEND.LT.II+17) GO TO 32
      IEND = (II-1+IEND)/2
      PRINT 995, I, II,IEND
      GO TO 33
   32 YLOW=YHIGH
      ILOW=IHIGH
      DLOW=HIGH
   21 CONTINUE
      X(1) = X(1)+X(1)
      PRINT 996,  ADJUST,X(IEND),FE(1)
      GO TO 199
C
C     FIND AN IMPROVED APPROXIMATION TO Y0
   22 Y0 = ((1.-DLOW)*(YHIGH-YLOW)/(HIGH-DLOW)+(YHIGH+YLOW)/2.+YLOW)/2. -87FE14
      YHIGH=YHIGH+3*TOL
      YLOW=YLOW-3*TOL
   23 DO 24 J=ILOW,IHIGH
      IF(POT(J).LT.Y0) GO TO 24                                         UCL78JUN
      IEND=J-1
      GO TO 25
   24 CONTINUE
   25 J=IEND
C     BOUNDARY CONDITION, EN 2.17 AND EN 2.18
      F(1)=BB*Y0*Y0*DMUE/Z
      F(2)=2*(F(1)-ZN/Z)/Y0
      YY0=Y0
   26 J=J-ISTEP
      H=YY1-YY0
      IF (J.GT.0)  H=POT(J)-YY0
      CALL RK1ST(YY0,F,H,2,XB,FE)
      F(1)=FE(1)
      F(2)=FE(2)
      IF (J.LE.0)  GO TO 27
      YY0=POT(J)
      GO TO 26
C
C     EXPAND AT YY1 IN A TAYLOR SERIES TO CALCULATE FE AT Y.EQ.0.
   27 FE(1)= FE(1) + (SQRT(FE(1))*YY1)**3*2./3. - FE(2)*(YY1/2.+YY1**4)
      IF (DLOW.EQ.FE(1) .OR. HIGH.EQ.FE(1))  GO TO 70                   *87FE14
      TOL1=FE(1)-1.
      IF ((YHIGH-YLOW)*2.GT.Y0*TOL)  GO TO 271                          78JN87MR
      IF(TOL1.LT.0.) YHIGH=YHIGH-TOL1
      IF(TOL1.GT.0.) YLOW=YLOW-TOL1
  271 H = (((DLOW-1.)*Y0-YLOW*TOL1)/(DLOW-FE(1)) +
     C     ((HIGH-1.)*Y0-YHIGH*TOL1)/(HIGH-FE(1)))/2
      IF (TOL1.GT.0.)  GO TO 28
      YLOW=Y0
      DLOW=FE(1)
      ILOW=IEND
      GO TO 29
   28 YHIGH=Y0
      HIGH=FE(1)
      IHIGH=IEND+1
   29 Y0 = H
      IF(Y0.LT.YLOW.OR.Y0.GE.YHIGH) Y0=(YLOW+YHIGH)/2.
      ISTEP = 1
      H = ABS(TOL1)
      IF (H.GT.0.1)  ISTEP = 2
      IF(H.GT.2*TOL) GO TO 23                                           78JN87FE
C
C     FIND THE FINAL VALUE FOR Y0
   70 H = Y0*Y0*DMUE
      DO 80 I=1,NPTS
      IF (X(I).LT.H)  GO TO 80                                          78JN87FE
      IEND=I-1
      GO TO 90
   80 CONTINUE
      PRINT 993, H
      STOP
   90 FE(1) = BB*H/Z                                                    +87FE14
      FE(2) = (FE(1)-ZN/Z)*2/Y0
      V0 = ZN/H - BB
      YY1=Y0
      I=IEND
  100 XB = Y1
      IF (I.NE.0)  XB = X(I)                                            -87FE14
      YY0=YY1
      YY1 = SQRT(XB/DMUE)
      F(1)=FE(1)
      F(2)=FE(2)
      H=YY1-YY0
C     INTEGRATE FROM YY0 TO YY0+H
      CALL RK1ST(YY0,F,H,2,YY1,FE)
      IF(I.EQ.0) GO TO 170
      POT(I)=FE(1)*Z/XB + V0
      I=I-1
      GO TO 100
C     EXTRAPOLATE TO X=0 -- BEWARE OF OSCILLATING ITERATIONS (GO TO 191)*87FE14
  170 FE(1)= FE(1) + (SQRT(FE(1))*YY1)**3*2./3. - FE(2)*(YY1/2.+YY1**4)
      TOL1 = FE(1)-1
      IF (ABS(TOL1).LE.TOL)  GO TO 192
      V0 = (YHIGH-YLOW)*5-TOL                                           '87MR16
      IF (TOL1)  172,171,173
  173 IF (HIGH.EQ.FE(1))  GO TO 191
      IF(V0.LT.0.0) YLOW=YLOW-TOL1
      GO TO 171
  172 IF (DLOW.EQ.FE(1))  GO TO 191
      IF(V0.LT.0.0) YHIGH=YHIGH-TOL1
  171 H = (((DLOW-1)*Y0-YLOW*TOL1)/(DLOW-FE(1)) +
     C     ((HIGH-1)*Y0-YHIGH*TOL1)/(HIGH-FE(1)))/2                     -TFDAPO
      IF (TOL1.LT.0.)  GO TO 180                                        78JN87FE
      YHIGH=Y0
      HIGH=FE(1)
      GO TO 190
  180 YLOW=Y0
      DLOW=FE(1)
  190 Y0 = H
      IF(Y0.LE.YLOW.OR.Y0.GE.YHIGH) Y0=(YLOW+YHIGH)/2.
C     IF THE APPROXIMATION IS NOT GOOD ENOUGH REPEAT THE PROCESS
      GO TO 70
C
  991 FORMAT(/46H TFDAPO FINDS TOL TOO SMALL; (DLOW,HIGH,TOL1)=,3F12.8/)*87FE14
  191 PRINT 991, DLOW,HIGH,TOL1
C     FILL THE REMAINING POTENTIAL AS A COULOMB POTENTIAL
  192 I = IEND+1
      DO 195 J=I,NPTS
  195  POT(J)=ZN/X(J)
  199 RETURN
      END
      SUBROUTINE RK1ST(X0,Y0,H,N,X1,Y1)                                  RK1ST
C
C     -- INTEGRATES 1 RUNGE-KUTTA STEP WITH INITIAL VALUES X0,Y0(N).    RADW0790
C     RESULT X1=X+H (H= LENGTH OF STEP), Y1(N) = SOLUTION AT X1.
C     FKT(X,Y,N,Z) REPRESENTS THE SYSTEM TO BE INTEGRATED, Z(N)=
C     DERIVATIVES.
C
      DOUBLE PRECISION X0,Y0,H,X1,Y1, A,Z,HH,Y
      DIMENSION Y0(1),Y1(1),Y(2),A(5),Z(2)
      X1=X0
      HH=H/2
      A(1)=HH
      A(2)=HH
      A(5)=HH
      A(4)=H
      A(3)=H
      DO 1 K=1,N
      Y(K)=Y0(K)
    1 Y1(K)=Y0(K)
      DO 2 I=1,4
      Z(1) = Y(2)
      Z(2) = 4.*X1*SQRT(Y(1))*Y(1)+Y(2)/X1
      X1=X0+A(I)
      DO 2 K=1,N
      Y(K)=Y0(K)+A(I)*Z(K)
    2 Y1(K)=Y1(K)+A(I+1)*Z(K)/3
      RETURN
      END
      SUBROUTINE RADWAV(N,L,POT,IEND,NPTS,NI,NTI,DXI,X,SCREEN,P,Q,E)
C
C     -- CALCULATES ELECTRON BOUND WAVE FUNCTIONS IN A POTENTIAL POT
C     (E.G. FROM RUNNING TFDAPO) AT NPTS RADIAL MESH POINTS X(I).
C     SUBROUTINES REQUIRED: NUMERO, WHITEX, WEDDLE.
C     QUANTITIES REQUIRED      - APART FROM POT(I) AND GRID X(I) -
C     N = PRINCIPAL QUANTUM NUMBER, L = ANGULAR MOMENTUM, Z=POT(0):
C     Z= NUCLEAR CHARGE, RESIDUAL CHARGE =POT(NPTS)*X(NPTS) ASSUMED.
C     NI = NUMBER OF INTERVALS INTO WHICH THE WHOLE RANGE IS DIVIDED,
C     NTI(J) =  NUMBER OF STEPS (.GE.8) IN EACH OF THE INTERVALS
C     DXI(J) = STEP LENGTH IN INTERVAL J, NPTS = TOTAL NUMBER OF STEPS.
C     SCREEN IS AN ESTIMATE OF THE SCREENING VALUE IN A RYDBERG FORMULA;
C     AFTER EXCECUTING RADWAV THE INITIAL VALUE OF SCREEN IS REPLACED BY
C     THE CALCULATED SIGMA. OTHER INPUT IS IEND, TOL(=10**(-ITOL) IN SS)
C     RESULTS:
C     NPTS VALUES OF THE NORMALIZED WAVE FUNCTIONS P(I) AND Q(I),
C     E = ENERGY EIGENVALUE IN RYDBERGS (INACCURACY ABS(DE/E).LT.TOL),
C     SCREEN = SCREENING PARAMETER IN A RYDBERG FORMULA FOR  E
C
      DOUBLE PRECISION Z,XA,XB,E,RJ,SQRE,PC,PNORM,PO,PP,DE, ONE,
     C         POT,EE,ZN,LLL,Q, WHITEX,A,Y,PKOEF,P,X,DXI,U, DIFF, DE0
cP    REAL LLL
      LOGICAL BSHORT,BNORM
      PARAMETER (MAXIT=16,NK=5,ONE=1.0)
      DIMENSION X(0:NPTS),P(0:NPTS),DXI(NI),Y(6),A(12),U(3),
     *        POT(0:NPTS),Q(0:NPTS),NTI(NI),PKOEF(4),IND(3)
      EQUIVALENCE (Y(1),A(7))
  997 FORMAT(' RADWAV: RANGE TOO SHORT FOR  N-L =',I2,' -',I2,'  NODES')
  996 FORMAT(' RADWAV: JOINING POINT LIES IN FIRST INTERVAL FOR (N,L) ='
     *,2I3,', PERHAPS Z POOR'/' -- (E,RJ) = ',2F12.4,'; POINT SHIFTED.')
C                    (Z WRONG, OR SIGMA0 POORLY SPECIFIED)
  994 FORMAT(' RADWAV FATAL MIXUP IN JOINING AREA (CHECK NTI(I) FIRST)')
  993 FORMAT(' RADWAV WARNING FOR NL=',2I2,': XOUTW=',F9.4,' LT RJ=',F9.
     *4/' -- TRY BIGGER TABULATION RANGE (MORE POINTS OR LONGER STEPS)')
  992 FORMAT(52H RADWAV - WARNING:  INWARD-INTEGRATION STARTED AT R(,I3,
     *3H) =,F7.3,11H: Z(R)-ZN =,F10.6,3H  -,F3.0,5X,12HFOR  (N L) =,2I3)
  991 FORMAT(' RADWAV STOPS: CHANGE OF SIGN AT BEGINNING FOR (NL)=',2I2)
  990 FORMAT(' SR.RADWAV GIVES UP WITH (E,DE,RJ)=',3F14.7/I7,' ITERATION
     *S TRIED FOR (N,L)=',2I2,'. CHECK WHETHER PRECISION GOOD ENOUGH!'/)
      BSHORT=.TRUE.
      ITERA = MAXIT
      NPRES = NPTS
      PNORM = 1.0
CN    NOUTW = 0
      NCORR = 0
      Q(0) = 0.
      DE0 = 1.E10
      LLL = L*(L+1)
      NODES = N-L
C
C     ZN = ASYMPTOTIC SCREENING CHARGE = POT(.GT.IEND)*X(.GT.IEND)
      ZN = POT(NPTS)*X(NPTS)
      TOL = X(0)
C
C     CORRECT THE SCREENING CHARGE IF TOO LARGE
      Z = POT(0)
      IF (Z-ZN.LT.SCREEN)  SCREEN = (Z-ZN)/(N*N)
      S = POT(0)
      IF (ABS(POT(2)*X(2)-POT(1)*X(1)).LT.1.E-5)  S = POT(1)*X(1)
C     FOR THE CASE OF A SCALED COULOMB POTENTIAL.
C
C     NK= NUMBER OF TERMS IN THE WAVE EXPANSION AT THE ORIGIN (SEE DATA)
      NC = NK - 2
C
C     EXPAND POT(X) = PKOEF(1)/X + PKOEF(2) +.. + PKOEF(NC+1)*X**(NC-1)
      PKOEF(1) = 1/REAL(6)
      DO 21 I=1,NC
       A(I) = POT(I)*X(I)-S
  21   PKOEF(I+1) = PKOEF(I)/X(1)
      PKOEF(1) = S
      PKOEF(2) = ((A(1)*2-A(2))*9+A(3)*2)*PKOEF(2)
      PKOEF(3) = (-A(1)*5+A(2)*4-A(3))*3*PKOEF(3)
      PKOEF(4) = ((A(1)-A(2))*3+A(3))*PKOEF(4)
C
C     CALCULATE A FIRST APPROXIMATION TO THE EIGENVALUE
      E = -((Z-SCREEN)/N)**2
      IF (-E*X(NPTS-5).LT.ZN)  E = -ZN/X(NPTS-5)
      EE = E
      EH = -(Z/N)**2
      EL = -(ZN/N)**2
C
C     CALCULATE JOINING DISTANCE FOR INWARD AND OUTWARD INTEGRATION. WE
C     CHOOSE FOR IT THE LAST POINT OF INFLECTION:
C
   30 IF(E.LT.EL) GO TO 22
      E = (E+EE)/2.
      EL=EL/1.05
      IF (E.GT.EL) E=EL
   22 IF(E.GT.EH) GO TO 23
      E = (E+EE)/2.
      EH=EH*1.05 ! RESTORED '02MAY19
      IF (E.LT.EH) E=EH
   23 EE=E
C     print "(30x,' out: EL,EH,E=',1p,3e11.4e1)", EL,EH,E
C     THE SEARCH FOR RJ IS DONE STEP BY STEP FROM X(NPTS) INWARDS
      JJ = NPTS
CL    IF(ZN.ZN.GT.-E*LLL) PP = DSQRT(E*LLL/(ZN*ZN)+1.)
      RJ = -2.*ZN/E
CN    IF(NOUTW.NE.0) GO TO 31 !- DEL '02MAY19
CN    IF(RJ.LT.X(IEND)) RJ = X(IEND) !- ''
   31 IF (X(JJ).LE.RJ)  GO TO 41
      IF ((2.0*POT(JJ)+E)*X(JJ)*X(JJ).GE.LLL)  GO TO 32
      JJ = JJ-1
      IF (JJ-NTI(1)-4) 156,33,31
   33 PRINT 996, N,L, E,RJ
C TRY GO TO 41
   32 RJ = X(JJ)
C
C     FIND  THE JOINING POINT.  WE TAKE AS JOINING POINT THE FIRST X
C     THAT IS LARGER THAN THE JOINING DISTANCE.
C
   41 NOUTW=NTI(1)
C     RUN THROUGH THE STEPS J OF THE INTERVALS I
      DO 60 I=2,NI
       NHI=I
       NC=NTI(I)
       DO 50 J=1,NC
        NOUTW=NOUTW+1
        IF(NOUTW.GE.NPTS-4) GO TO 40
        IF(RJ.GT.X(NOUTW)) GO TO 50
        IF(J.LT.4) GO TO 50
   40   NTINHI = J
        II = NTI(I)-NTINHI
        GO TO 80
   50   CONTINUE
   60  CONTINUE
C
C     SHIFT JOINING POINT IF TOO NEAR TO END OF INTERVAL
C     AS WE CALCULATE THE DERIVATIVE WITH 7 POINTS.
   80 IF(II.GE.4) GO TO 90
      NOUTW=NOUTW-(4-II)
      NTINHI = NTINHI+II-4
C
C     CALCULATE FIRST TWO POINTS FOR NUMEROV INTEGRATION WITH A SERIES
C     EXPANSION OF THE WAVE FUNCTION AT THE ORIGIN
C
   90 A(1) = REAL(1)
      A(2)=-A(1)*PKOEF(1)/(L+1)
      DO 96 I=3,NK
      II=I-1
      A(I)=0.
      DO 95 J=1,II
   95 A(I) = A(I)+A(J)*PKOEF(I-J)
   96 A(I) = -(2.0*A(I) + A(I-2)*E)/(II*(2*L+I))
      DO 101 I=1,2
      II=I+1
C     U SHALL CONTAIN THE VALUE OF THE FUNCTION
      U(II)=0.
      DO 100 J=1,NK
  100 U(II)=U(II) + A(J)*X(I)**(L+J)
      Q(I)=U(II)
C 101 F(II) = LLL/(X(I)*X(I)) -2.0*POT(I) - E
C     F SHALL CONTAIN THE SECOND DERIVATIVE - DONE IN NUMERO THROUGH
  101 IND(II) = I
C
C     CHECK THAT THE FUNCTION DOES NOT CHANGE SIGN BETWEEN THE FIRST
C     POINTS.  IF IT DOES, THEN PRINT ERROR MESSAGE AND STOP
      IF(Q(1)*Q(2).GT.0.) GO TO 102
      PRINT 991, N,L
   45 N = 0
      GO TO 250
C
C
C     OUTWARD INTEGRATION
C     NC=NUMBER OF POINTS EXCLUDING THE ORIGIN FOR INTEGRATION.
C     XA=ORIGIN, XB=END OF INTEGRATION
C
  102 NC = NTI(1)-1
      XA=X(1)
      XB=X(NC+1)
C
C     NODE AT THE ORIGIN DOES NOT COUNT
      NODS = 1
C     FIRST 2 POINTS
      J=2
C
C     ARRAY INDEX IN NUMEROV MUST INCREASE   (STEPS +1 OF INDEX TO X0)
      IND(1) = 1
      DO 120 I=1,NHI
      CALL NUMERO(XA,XB,U,IND,NC,EE,POT,ZN,LLL,P(1))
      DO 110 II=2,NC
      J=J+1
      Q(J)=P(II)
C
      if (Q(J).eq.0.) Q(J)=1.e-30
C     A NODE IMPLIES A CHANGE OF SIGN IN Q
      IF (SIGN(ONE,Q(J)).NE.SIGN(ONE,Q(J-1))) NODS = NODS+1
C
C     NOT YET TOO MANY NODES, OUTWARD INTEGRATION MAY GO ON
      IF(NODS.LE.NODES) GO TO 110
C
C     TOO MANY NODES.  THE PRESENT ABSOLUTE OF E THEREFORE REPRESENTS
C     A LOWER LIMIT EL
      EL=E
C     INCREASE THE ABSOLUTE OF E
C     E=E*1.5 -- XX= A LA ZSS '02MAY19(WHITSUN)-28:
      E= MIN(REAL(NODS+L)/N,1.5)*E
C
      GO TO 22
C
  110 CONTINUE
C
C     IF THE JOINING POINT HAS BEEN REACHED GO FOR A CHECK
      IF(I.EQ.NHI) GO TO 130
C
C     CALCULATE THE STARTING VALUES FOR NUMEROV FOR THE NEXT INTERVAL
      U(2)=P(NC-2)
      U(3)=P(NC)
      XA=X(J-2)
      IND(2) = J-2
      IND(3) = J
C     IND(3) GIVES THROUGH X(IND(3)) THE INITIAL POINT OF THE PARTICULAR
C     NUMEROV INTEGRATION
C
      NC = NTI(I+1)+1
      IF (I.EQ.NHI-1)  NC = NTINHI+5
  120 XB=X(J+NC-1)
  130 IF(NODS.EQ.NODES) GO TO 150
C
C     CHECK WHETHER NUMBER OF NODES IS CORRECT
C     IF NOT ENOUGH NODES IN THE WAVE FUNCTION REDUCE THE ENERGY AND
C     START THE PROCESS AGAIN
C     THE PRESENT ABSOLUTE OF E THEN REPRESENTS AN UPPER LIMIT EH
      EH=E
C     E=E/1.3 -- XX:
      E= MAX(REAL(NODS+L)/N,0.8)*E
C     print "(' n,NODS NODES,E=',3i3,1pe12.4e1)", n,nods,nodes, E
C
C     START INTEGRATION AGAIN WITH NEW E
      GO TO 30
C
C
C
C     FIND STARTING POINT X(NP) FOR INWARD INTEGRATION
C
C     IF STARTING VALUE.LT.1.(-30) MOVE INWARDS
  150 DIFF = 0.
      SQRE = SQRT(-E)
      I = NPTS
      IF(BSHORT) I = MIN(MAX(NPRES+5,NOUTW+4),NPTS)
C     print "(' inw: I,E=',i4,1pe11.4e1)", I,E
  151 NC = I
  157 NP = I
      XA = X(NP)
      I = I-4
C
C     THE STARTING VALUES WILL BE CALCULATED WITH A WHITTAKER FUNCTION
  158 PP = SQRE*XA
      PO = LOG(PP+PP)*ZN/SQRE-PP
C     EXP(-SQRT(-E)*XA) MUST NOT BECOME 0.0 - REDUCE IF MACHINE ALLOWS
      IF (PO.GE.-69.) GO TO 152
      IF (I.GT.IEND+1)  GO TO 157
      DIFF=PO+69.
  152 PO = WHITEX(XA,L,SQRE,ZN,BNORM,DIFF)
      IF (PO.EQ.0.0) GO TO 151
C     IN (VAX) CASES OF RESTRICTED EXPONENTIAL RANGE, PROMPTING PRINT992
      IF (.NOT.BNORM)  PNORM = 1.0
C
C     THE FUNCTION WILL BE CALCULATED FOR ALL X.LE.X(NP)
C
      NPRES=NP
      IF(BSHORT) NP=MIN(MAX(IEND,NOUTW)+NCORR+5,NPRES)
C
C     CHECK WHETHER NEW STARTING POINT FALLS NOT TOO CLOSE TO END OF
C     INTERVAL;  PP WILL BE USED FOR DERIVATIVES, NTI(NHI) FOR WEDDLE
C
      II = 0
      PP=DXI(NHI)*840
      DO 155  J=1,NI
       IF (NTI(J).LT.8)  GO TO 156
       NHI = J
       JJ = II+NTI(J)
       IF (JJ-NP) 155,140,154
  154  IF (NP-II.GE.8)  GO TO 140
       NP = II+8
       IF (NP.LE.NC)  GO TO 140
       NHI = J-1
       NP = II
       II = II-NTI(J-1)
       IF (NOUTW+4-NP) 140,140,156
  155  II = JJ
  156 PRINT 994
      GO TO 45
  140 NTINHI = NTI(NHI)
      NTI(NHI) = NP-II
C
C
C     INWARD INTEGRATION
C     ARRAY INDEX IN NUMEROV MUST DECREASE   (IND(1) NEGATIVE)
C
C   GIVE THE STARTING VALUES FOR THE NUMEROV INTEGRATION
C   CALCULATE THE TWO OUTERMOST POINTS WITH THE WHITTAKER FUNCTION
      XA = X(NP)
      P(NP) = WHITEX(XA,L,SQRE,ZN,BNORM,DIFF)*PNORM
      I=NP-1
      XB=X(I)
      U(3) = WHITEX(XB,L,SQRE,ZN,BNORM,DIFF)*PNORM
      IF (BNORM)  GO TO 159
      U(3) = (U(3)/P(NP))*1.E-30
      P(NP) = 1.E-30
      GO TO 159
C
C
C   A NEW INTERVAL WITH A SMALLER STEP LENGTH UP HAS BEEN ENTERED.
C   THE SECOND STARTING POINT HAS TO BE CALCULATED BY AN INTERPOLATION,
C   AT 6 EQUIDISTANT POINTS X(J): J=I+3,I+2,I+1,I-1,I-3,I-5.
C   INTEGRATE OVER ANOTHER 3 INTERVALS OF THE OLD LENGTH
C
  170 IND(1) = -2
      I=I-1
      DO 182  J=1,4
  182  Y(J) = X(I+3-2*J)
      XB = Y(4)
      CALL NUMERO(XA,XB,U,IND,4,EE,POT,ZN,LLL,A)
      Y(5) = X(I+3)
      Y(6) = X(I+2)
      A(5) = P(I+3)
      A(6) = P(I+2)
C
C   INTERPOLATE TO GET A FUNCTION VALUE P(I) AT X(I), THEN PROCEED
C   TO USE NUMERO
      U(3) = 0.0
      DO 616 II=1,6
       XA = 1.0
       XB = 1.0
       DO 617 JJ=1,6
        IF (JJ.EQ.II)  GO TO 617
        XA = XA*(X(I)-Y(JJ))
        XB = XB*(Y(II)-Y(JJ))
  617   CONTINUE
  616  U(3) = A(II)*XA/XB + U(3)
C
  159 P(I) = U(3)
C   ASSIGN STARTING VALUES FOR THE CONTINUATION OF THE NUMEROV
C   INTEGRATION
      U(2)=P(I+1)
C
C
C   INTEGRATE INWARDS TO THE MATCHING POINT
C
  160 IND(2) = I+1
      IND(3) = I
C     THE  U(2),U(3)  ALREADY CONTAIN THEIR PROPER VALUES.
      XA=X(I+1)
C
C   DETERMINE NEW I AND INTERVAL
C   I SHALL GIVE THE ARRAY INDEX OF XB
      DO 183  J=2,12
C     IF THE END HAS NOT BEEN REACHED YET, CONTINUE WITH THE INTEGRATION
      IF (I.GT.NOUTW-4) GO TO 185
      IF (J.EQ.2)  GO TO 190
      GO TO 180
C     CHECK WHETHER THE NEW STEP HAS THE SAME LENGTH AS THE PREVIOUS ONE
  185 IF (X(I+1)-X(I).LE.(X(I)-X(I-1))*1.05)  GO TO 184
      IF (J.EQ.2)  GO TO 170
      GO TO 180
  184 I=I-1
  183 NC = J
C
  180 IND(1) = -1
      XB=X(I)
      CALL NUMERO(XA,XB,U,IND,NC,EE,POT,ZN,LLL,A)
C
C   STORE RESULT IN P
      DO 181  J=2,NC
       II = I+NC-J
  181  P(II) = A(J)
      GO TO 160
C
C
C
C     IF INWARD AND OUTWARD FUNCTIONS HAVE DIFFERENT SIGNS, CHANGE
C     THE SIGN OF THE INWARD FUNCTION.
C     SCALE OUTWARD AND INWARD FUNCTION TO Q(NOUTW)=P(NOUTW)=1.*SIGN(P)
C
  190 PC = 1.0/P(NOUTW)
      IF (SIGN(ONE,Q(NOUTW)).NE.SIGN(ONE,PC))  PC = -PC
      II = NOUTW-4
      DO 195 I=II,NP
  195  P(I) = P(I)*PC
      P(0) = ABS(1.0/Q(NOUTW))
      JJ = NOUTW+4
      DO 200 I=1,JJ
  200  Q(I)=Q(I)*P(0)
C
C     CALCULATE DERIVATIVES XB AND XA OF INWARD AND OUTWARD FUNCTIONS
C
      I=NOUTW
      XB = ( 672*(P(I+1)-P(I-1)) - 168*(P(I+2)-P(I-2))
     *      + 32*(P(I+3)-P(I-3)) - 3*(P(I+4)-P(I-4)) )/PP
      XA = ( 672*(Q(I+1)-Q(I-1)) - 168*(Q(I+2)-Q(I-2))
     *      + 32*(Q(I+3)-Q(I-3)) - 3*(Q(I+4)-Q(I-4)) )/PP
C
C     CALCULATE P(X)*P(X), INTEGRATE THAT FUNCTION AND CALCULATE
C                          THE ENERGY CORRECTION ACCORDING TO HARTREE
      PO = 0.0
      DO 210 I=1,NOUTW
       P(I)=Q(I)
       IF (ABS(P(I)).GT.PO) PO= ABS(P(I))
  210  Q(I)=Q(I)*Q(I)
      DO 215 I=NOUTW,NP
       IF (ABS(P(I)).LT.PO*1.E-30) P(I)=0.0
  215  Q(I)=P(I)*P(I)
C
C     INTEGRATE P(X)*P(X) AND CORRECT ASYMPTOTICALLY; RESTORE NTI(NHI)
      CALL WEDDLE(Q,PP,NTI,DXI,NHI,NP)
      NTI(NHI) = NTINHI
      PO = Q(NP)/(2.0*SQRE)
      PP = PP + PO
C
C     ENERGY CORRECTION;  E MUST NOT BECOME POSITIVE
      ITERA = ITERA-1
      DE = P(NOUTW)*(XB-XA)/PP
      IF (ITERA*2.GT.MAXIT.AND.ABS(DE).GT.ABS(DE0)) DE=SIGN(DE0,DE)
      DE0 = DE
      IF (E.LT.DE) GO TO 75
C OLD DE = E/1.5 -- RUB'93NOV24:
      DE = E/4.
      IF (ITERA.GT.0) GO TO 75
      PRINT 997, N,L
      N = -N
      GO TO 250
   75 XB = ABS(DE/E)
      if (E-DE.lt.EH) DE=E-EH
      IF(BSHORT) GO TO 220
C
C     THE APPROXIMATION IS TERMINATED WHEN THE RELATIVE CORRECTION TO
C     THE EIGENVALUE IS SMALLER THAN TOL
      IF (XB.LT.TOL)  GO TO 225
  220 E=E-DE
      IF (XB.LT.99.0*TOL .OR. ITERA*2.LT.MAXIT)  BSHORT=.FALSE.
      IF (PO.GT.0.001*PP)  NCORR = NCORR+10
      PNORM = ABS(PC)*PNORM
      IF (ITERA.GE.0)  GO TO 30
      PRINT 990,  E,DE,RJ, MAXIT, N,L
C
C     NORMALIZE THE FUNCTION
C     SET ALL FUNCTION VALUES FOR X.GE.X(NP) TO ZERO
  225 PNORM = ONE/SQRT(PP)
      DO 230 I=NP+1,NPTS
       Q(I) = 0.
  230  P(I) = 0.
      DO 240 I=0,NP
  240  P(I) = P(I)*PNORM
      DO 245 I=1,NP
  245  Q(I) = ((POT(I)-Z/X(I))*2+E)*P(I)
      IF (NP.LE.IEND)  PRINT 992, NP,X(NP), POT(NP)*X(NP),ZN, N,L
C
C     P(0) CONTAINS THE CORRECT ANORM FOR THE STARTING EXPANSION
      Q(0) = (PKOEF(2)*2+E)*P(0)
C
C     CALCULATE THE CORRECT SCREENING VALUE
      SCREEN = Z - N*SQRE
      IF(NOUTW.LT.NPTS-4) GO TO 250
      IF(RJ.GT.X(NOUTW))  PRINT 993, N,L, X(NOUTW),RJ
  250 RETURN
      END
      SUBROUTINE NUMERO(XA,XB,Y,IND,N,E,POT,ZN,LL,XY)
C
C     INTEGRATES COULOMB EQUATION (CHARGE ZN, EVENTUALLY MODIFIED: POT)
C     WITH REDUCED NUMEROV (G=0, D.R. HARTREE: NUMERICAL ANALYSIS P.142)
C     A SECOND ORDER DIFFERENTIAL EQUATION Y''= F(X)*Y + G(X) FROM
C     XA TO XB IN N STEPS. THE VALUES F,Y,G FOR THE FIRST 2 POINTS
C     ARE TO BE GIVEN IN F(2),F(3),Y(2),Y(3),G(2),G(3). THE VALUES
C     AT THE N POINTS XA + I*DX I=1,N ARE WRITTEN INTO XY(I),I=1,N.
C     E =EBOUND/RY FOR BOUND, =(K*A0)**2 FOR FREE WAVES; LL=L*(L+1)
C
      DOUBLE PRECISION A,B,C,D12,D56,DX,X,XA,XB, POT, E,ZN,LL, Y,F,XY
cP    REAL LL
      DIMENSION Y(3),F(3),IND(3), XY(N), POT(0:*)
C
      DX=(XB-XA)/N
      X = XA
      DO 5 I=2,3
       IF (IND(1)) 7,8,7
    8  A = ZN/X
       GO TO 6
    7  INDEX2 = IND(I)
       A = POT(INDEX2)
    6  F(I) = LL/X**2 - A - A - E
    5  X = X + DX
C
      D12 = DX*DX/12
      D56 = 10*D12
      XY(1)=Y(3)
      DO 1 I=2,N
      F(1)=F(2)
      F(2)=F(3)
      Y(1)=Y(2)
      Y(2)=Y(3)
      IF (IND(1)) 3,4,3
    4 A = ZN/X
      GO TO 2
    3 INDEX2 = IND(1) + INDEX2
      A = POT(INDEX2)
C     IND(2) = IND(3)
C     IND(3) = INDEX2
    2 F(3) = LL/X**2 - A - A - E
      A=1. - D12*F(3)
      B=(2. + D56*F(2))*Y(2)
      C=(1. - D12*F(1))*Y(1)
      Y(3)=(B-C)/A
      XY(I)=Y(3)
    1 X = X + DX
C
      RETURN
      END
cP    REAL FUNCTION WHITEX(R,L,E,ZN,BNORM,DIFF)
      DOUBLE PRECISION FUNCTION WHITEX(R,L,E,ZN,BNORM,DIFF)
C
C     CALCULATES THE VALUE OF THE WHITTAKER FUNCTION AT POINT R
C     L= ANGULAR MOMENTUM, E=SQRT(-ENERGY/RY), ZN= RESIDUAL CHARGE
C     IF WHITEX CANNOT BE NORMALIZED THEN BNORM=.FALSE. ELSE .TRUE.
C
      DOUBLE PRECISION  A,DL,E,FN, PS1,PS2,P,R,SUM,ZN, DIFF
      LOGICAL BNORM
  999 FORMAT(/33H WHITEX: EXPANSION TOO RESTRICTED)
      DATA SUPFCT,ENFFCT/55.,1.E-37/
cR    SUPFCT=43. -- TEMPORARILY 
cQ    SUPFCT=43.
      ENFFCT=1.E-6                                                      COLG86JL
      BNORM=.FALSE.
      P = ZN/E
C
      A = E*R
      FN = EXP(LOG(A+A)*P-A-DIFF)
C
      A = 1./(A+A)
      DL = (L+1)*L
      PS2 = ((1-P)*P+DL)*A
      PS1 = PS2
      SUM = 1.
C
C     EXPAND TO A MAXIMUM OF 30 TERMS
C     CONTINUE THE EXPANSION AS LONG AS ADDITIONAL TERMS BECOME SMALLER
C     STOP THE EXPANSION WHEN ADDITIONAL TERMS BECOME VANISHINGLY SMALL
      DO 1 I=1,30
       IF (ABS(PS2).GT.ABS(PS1)) GO TO 2
       SUM=SUM+PS2
       IF(ABS(PS2).LT.ABS(SUM)*1.E-10) GO TO 2
       PS1=PS2
    1  PS2 = PS2 * (DL-(P-I)*(P-I+1)) * A/I
C     PRINT A WARNING IF EXPANSION EXHAUSTED
      PRINT 999
C
C     DO NOT NORMALIZE WHITTAKER FUNCTION
C     IF FOR ARGUMENTS H1 OR H2  GAMMA(H) IS OUTSIDE MACHINE RANGE
    2 IF(DIFF.LT.0.) GO TO 3
      H2=P-L
      IF (H2.LE.ENFFCT)  GO TO 3                                        LT<86JLY
      H1=P+L+1
      IF (H1.GT.SUPFCT)  GO TO 3
C
C     NORMALIZATION CAN BE CALCULATED
      BNORM=.TRUE.
      DL =  GAMMA(H1) * GAMMA(H2) * ZN
      FN = FN*E/SQRT(DL)
    3 WHITEX = FN*SUM
      RETURN
      END
      REAL FUNCTION GAMMA(XX)                                            DWN01
      DATA ERR/1.E-6/, ARGFCT/57./
      IER = 2
      X = XX
      IF (X.GT.ARGFCT)  GO TO 9
      GX=1.0
    2 IF (X.LT.2)  GO TO 3
      X=X-1.0
      GX=GX*X
      GO TO 2
    3 IF(X-1.0) 4,8,7
    4 IF(X.GT.ERR) GO TO 6
      IER=1
      Y = REAL(INT(X))-X
      IF(ABS(Y).LT.ERR) GO TO 9
      IF(1.0-Y-ERR) 9,9,5
    5 IF(X-1.0) 6,8,7
    6 GX=GX/X
      X=X+1.0
      GO TO 5
    7 Y=X-1.0
      GX = (((((((-.05149930*Y+.2548205)*Y-.5684729)*Y+.8328212)*Y
     C           -.8764218)*Y+.9858540)*Y-.5771017)*Y + 1.0) * GX        DWN01
    8 GAMMA = GX
      RETURN
    9 PRINT 1, IER, XX
      STOP
    1 FORMAT(/7H  ERROR,I3,19H IN FUNCTION GAMMA(,E12.5,1H))
      END
      SUBROUTINE RADWIN(DQNL,MXQIN,MXG,MAXPS)                           UCL78JAN
C     FOR CALL FROM SR.RADIAL OF PROGRAM  S U P E R S T R U C T U R E
C     FEB12TH1975, STO-'84FEB             ***************************
C     (REPLACE BY DUMMY ROUTINE IF NOT REQUIRED AND IF *MAXGR IN DQNL
C      MAKES IT TOO BIG  --  AND SET  *MAXB2(=MXQIN OF SR.RADIAL) = 1).
C     THIS SUBROUTINE READS RADIAL FUNCTION INPUT AND PROCESSES IT FOR
C     ORBITALS K MARKED BY SIGMA(K).EQ.999. INPUT TYPE DEPENDS UPON THE
C     VALUE OF KEY READ IN POSITION (T1,I5) OF THE HEADER RECORD:
C     KEY= -10  FOR STO INPUT IN R-MATRIX FORMAT, ALSO IN CLEMENTI FORM;
C     KEY=  -9  FOR S.M. ORBITALS IN SUPERSTRUCTURE/COLALG/IMPACT FORMAT
C              --> WARNING: N O WHITTAKER SERIES EXTENSION IN THIS CODE!
C     KEY.GE.0  FOR HARTREE-FOCK-FROESE FUNCTIONS P(N,L) AND Q(N,L) AS
C               FROM H.E.SARAPH-SR OUTPUT AT THE USUAL CH.FROESE RADII.
C
cM    IMPLICIT INTEGER*2 (Q)
cS   C        ,INTEGER*2 (I-L,N)
      INTEGER QCG,QL,QN
      CHARACTER HEAD*8
      DOUBLE PRECISION X,ADJOLD,HP,ORIG, HPP
     C , DD,DK,DM,Z, DNS,DEY,DPNL,DUY, DA, DD1,DD2,  DQNL,HQ
cP    PARAMETER (MXD27= 999)
      PARAMETER (MXD27=2* 999)
      PARAMETER (MXD04=3100*3+  38+1)
      DIMENSION HP(0: 999),DA(0: 999),HQ(0: 999), ORIG(15),
     C  Y(MXD27),BP(MXD27),BQ(MXD27),KHLP(MXD27),
     *  IRAD(0:22),ZE(0:22),CJ(0:22),  DQNL(0:MXQIN,MXG)
      COMMON MAXGR,NF  /OUTP/ MPRINT,MDUM(2),KDUM(3)
     * /GENINF/ ADJOLD(15),SIGMA(15),MION,NZION,IDUM(6)
     C /DBD2/ DEY(15),QCG(54, 60),QL(15),QN(15)
     C /CRAD/ DNS(10),MNE(10),MJH,MXR,JEND(15)  /JSPOR/ NJO(MXD04)
     C /RADF/ X(0: 999),DPNL(0: 999,15),DUY(15,15)
     C /REL/ DMASS(15,15),DCD(15,15),D2LL(15,15)
      EQUIVALENCE (BP(1),HP(1)), (BQ(1),HQ(1)), (MXPIN,MAXE)
      DATA IREAD/5/,OVRLP/2.E-6/,ALPH2/.665619E-5/, ID/4/,
     * HP(0),HQ(0),DA(0)/3*0./, MSTO,MCLE,MENT/4HSTO ,4HCLEM,4HENTI/
C
      MAXE=MXD27
      MR = IREAD
      Z = NZION
      IF (NF.LE.0)  GO TO 70
      DO 66  K=1,MAXGR
       ORIG(K) = 0.0
       IF (DEY(K).EQ.0.0)  GO TO 66
       IF (SIGMA(K).GE.999.)  GO TO 66
       ORIG(K) = DPNL(0,K)*Z
  66   CONTINUE
      KMAX = 0
  70  MXE = MXPIN
      II = 1
      PRINT 250
      READ(MR,590)  KEY, MPMX, MC,ZC
      IF (MPMX.LT.0)  MR = -MPMX
      J = KEY
C +++ IF (KEY.EQ.-9)  GO TO 43 -- TEMP.FIX:
      IF(J+9) 72,43,39
C      ASSUME MXE.LE.MAXE POINTS Y FOR (HARTREE-FOCK-FROESE) CARD INPUT
C      (ADDITIONAL RECORDS WILL BE SKIPPED - DO49; 2 POINTS PER CARD)
  39   DM = 1./16.
       DD = -4.0
       DO 71  I=1,MXE
        Y(I) = EXP(DD)/Z
  71    DD = DD+DM
      GO TO 40
C
  41  MXE = IPMX
  40  II = 1
      DO 85  K=1,MXR
       KHLP(K) = 0
       GO TO 82
  81   II = II+1
  82   IF (II-MXE)  83,84,85
  83   IF (Y(II+1)+Y(II).LT.X(K)*2.)  GO TO 81
  84   IF (X(K).GT.Y(MXE))  GO TO 81
       KMAX = K
       KHLP(K) = II
C      ADDRESS ARRAY KHLP WILL HELP TO INTERPOLATE Y ONTO X             UCL74NOV
  85   CONTINUE
C
  72   MYN = 0
       NSTO = 0
       IF (KEY.GE.0)  GO TO 42
       READ(MR,570,END=79)  J,N, MYN,MYL, ZE(0), MPMX, M1,M2            *IMPACT*
       IF (J.EQ.-5)  GO TO 79                                           78JN80MY
       CJ(0) = 0.0
       MPMX = MPMX*2
C +++  STO CODE COPIED FROM COLALG VERSION - QUB'90MAY23
       IF (KEY.GE.-9)  GO TO 43
       IF (J.LE.0)  GO TO 43
C
C      COMPUTE SLATER TYPE ORBITALS FROM INPUT IN RMATRX/STG1 FORMAT,   84FEB15
C              I.E. READ  ISTO(K),ZESTO(K),CSTO(K),
C              WRAPPED IN CARD IMAGE RECORDS MARKED KEY=-10 AND KEY=-5  86JLY16
       READ(MR,*) (IRAD(K),K=1,J)
       READ(MR,*) (ZE(K),K=1,J)
       READ(MR,*) (CJ(K),K=1,J)
       IF(NF.LE.0) GO TO 72
       NSTO=J
C ---  COMPUTE P AND Q BAR0, AND SATISFY CUSP CONDITION IF NYN.NE.-1    86JLY16
  88   K = 1
  32   L = IRAD(K)
       DM = 0.0
       DD1 = 0.0
       HP(0) = 0.0
       DD2 = 0.0
       HQ(0) = 0.0
       RPEND = 0.0
       DO 31 K=1,NSTO
        IF (IRAD(K)-L)  32,36,38
  36    IF (ZE(K).GT.DM)  DM = ZE(K)
        HP(0) = CJ(K) + HP(0)
        DD = ZE(K)*CJ(K)
        DD1 = DD + DD1
        HQ(0) = (Z*2-(2*L+1)*ZE(K))*DD + HQ(0)
        GO TO 31
  38    IF (IRAD(K).NE.L+1)  GO TO 31
        DD2 = CJ(K)+DD2
        HQ(0) = ((L*2+1)*ZE(K)-Z)*2*CJ(K) + HQ(0)
  31    CONTINUE
       IRAD(0) = L
       MYL = L-1
       CJ(0) = 0.0
       ZE(0) = Z
C TRY  IF (ZE(0).LE.DM*1.1)  MYN = -2
C      MODIFY  Z(0) FOR CUSP CORRECTION IF REQUIRED.
       DK = 0.0
       IF (MYN+1)  28,27,29
  28   ZE(0) = -MYN*DM
  29   DD = (DD2-DD1)*L + Z*HP(0)
       IF (ABS(DD).LT.1.E-5)  GO TO 35
       IF (L*ZE(0).LE.Z)  ZE(0) = (Z+1.)/L
       CJ(0) = DD/(L*ZE(0)-Z)
       HP(0) = CJ(0) + HP(0)
       DK = (Z*2-(2*L+1)*ZE(0))*ZE(0)*CJ(0) + HQ(0)
  27   HQ(0) = DK
  35   KMAX = MXR
       J = KEY
       IF (II-1) 30,37,30
C +++  GO TO 43 - END OF STO EXTENSION; PLUS LABELS 37,30; DQNL FOR HQ
C
  42   READ(MR,600,END=79) MYN,MYL, J, N, ZE(0),CJ(0),MPMX, DK,DM, M1,M2UCL78FEB
  43   IF (MPMX)  70,79,75
C      A BLANK (P/Q) HEADING CARD SERVES AS A DATA INPUT TERMINATOR.
  75   DO 49  I=1,MPMX,2
        READ(MR,600)  L,L,L,  I1,DD1,DD, L,DD2,DM
        I2 = I1+1
        IF (J.NE.-9)  GO TO 46
        IF (I1-MXE)  44,45,49
  44    Y(I2) = DD2
  45    Y(I1) = DD1
        GO TO 49
  46    IF (I1-MXE)  47,48,49
  47    BP(I2) = DD2
        BQ(I2) = DM
  48    BP(I1) = DD1
        BQ(I1) = DD
  49    CONTINUE
C      DO49 PROCESSES A RANDOM ORDERED SET THAT MAY EXCEED BUFFER SIZES.
       IF (NF.LE.0)  GO TO 72
       IF (MXQIN.LE.9)  GO TO 72
       IF(L.EQ.0) MPMX=I1
       IPMX = MIN(MPMX,MXE)
       IF (J.EQ.-9)  GO TO 41
C TMP  PLAST = ABS(BP(IPMX))
       RPEND = Y(IPMX)
       L = MPMX-IPMX
       IF (MPMX.GT.MXE)  PRINT 580, L,MPMX,MXPIN,MXE, RPEND,BP(IPMX)    UCL78OCT
       IF (Y(1).GT.0.) GO TO 37
C !!!  NO ASSIGNMENT YET FOR 'HARTREE'-HX(0)!
       HP(0) = BP(1)
       HQ(0) = BQ(1)
       BP(1) = 0.0
       BQ(1) = 0.0
  37   II = KMAX-2
       IF(MPRINT.LT.0) II=KMAX-1
C
  30   DO 68  K=1,MAXGR
        IF (2*MYL.NE.QL(K))  GO TO 68
        IF (ORIG(K).NE.0.0)  GO TO 68
        IF (DEY(K).EQ.0.0)  GO TO 68
        N = K
        GO TO 69
  68    CONTINUE
       PRINT 800, M1,M2, MYL,MYN
       GO TO 72
C
  69   DD1 = HP(0)
       DD2 = HQ(0)
C      COMPUTE ORBITAL AT THE INTERNAL GRID POINTS (I=1,MXR)
       DO 73  L=0,MXR
        IF(L.EQ.0) GO TO 74
        DD2 = 0.0
        DD1 = 0.0
        IF(NSTO.EQ.0) GO TO 33
C ---   COMPUTE SLATER TYPE ORBITAL
        DD = LOG(X(L))
        DM = (MYL*IRAD(0)/X(L)-2*Z)/X(L)
        DO 34 K=0,NSTO
         IF(CJ(K).EQ.0.) GO TO 34
         J = IRAD(K)
         DK = J*DD-ZE(K)*X(L)
         IF (DK.LT.-85.196) GO TO 34
         DK = CJ(K)*EXP(DK)
         DD1 = DK + DD1
         DD2 = (((1-J)/X(L)+ZE(K)*2)*J/X(L)-ZE(K)*ZE(K)+DM)*DK + DD2
  34     CONTINUE
        GO TO 74
C       LAGRANGE INTERPOLATION (ID+1 POINTS) FROM ARGUMENTS Y TO X(L)
  33    IF(X(L).GT.Y(IPMX)) GO TO 74
C       FUNCTION VALUES BEYOND THE SUPPLIED AND HELD RANGE ARE SET =0.
        I1 = MAX(KHLP(L)-ID/2,1)
        I2 = I1 + ID
        IF (I2.LE.IPMX)  GO TO 78
        I2 = IPMX
  78    DO 76  I=I1,I2
         DD = 1.0
         DM = 1.0
         DO 77  J=I1,I2
          IF (J.EQ.I)  GO TO 77
          DM = (X(L)-Y(J)) * DM
          DD = (Y(I)-Y(J)) * DD
  77      CONTINUE
         DD2 = BQ(I) * DM/DD + DD2
  76     DD1 = BP(I) * DM/DD + DD1
CTEST   J = KHLP(L)
CTEST   WRITE(6,'(5X,I4,E14.7,14X,3I4,2E14.7)') L,X(L), J,I1,I2,Y(J),DD1**TEST**
  74    IF (L.GT.MXQIN)  GO TO 73
        DQNL(L,N) = DD2
  73    DPNL(L,N) = DD1
C      ORTHONORMALIZE (SCHMIDT PROCEDURE DO63, NORMALIZATION DO64-65)
       DO 63  K=1,MAXGR
        IF (2*MYL.NE.QL(K))  GO TO 63
        IF (ORIG(K).EQ.0.0)  GO TO 63
        DO 61  I=1,MXR
  61     DA(I) = DPNL(I,K)*DPNL(I,N)
        CALL WEDDLE(DA,DD, MNE,DNS,MJH,MXR)
        IF(ABS(DD).GT.1.E-2 .AND. MPRINT.GE.-1)  PRINT 960,  K, DD
        DO 62  I=0,MXR
         IF (I.GT.MXQIN)  GO TO 62
         DQNL(I,N) = DQNL(I,N) - DD*DQNL(I,K)
  62     DPNL(I,N) = DPNL(I,N) - DD*DPNL(I,K)
  63    CONTINUE
       DO 64  I=1,MXR
  64    DA(I) = DPNL(I,N)**2
       CALL WEDDLE(DA,DD, MNE,DNS,MJH,MXR)
       IF (DD.GT.OVRLP)  GO TO 67
C      IGNORE NEAR-IDENTICAL FUNCTION:
       PRINT 700, MYN,MYL, OVRLP
       GO TO 72
  67   DM = 1.0/SQRT(DD)
CEVTL  EVENTUALLY POSITIVE SLOPE AT ORIGIN R=0:
CEVTL  DM = SIGN(1./SQRT(DD),DPNL(0,N))
       DO 65  M=0,MXR
        DD1 = DM*DPNL(M,N)
        IF (ABS(DD1).GT.1.E-6)  MAXPS = MAX(M,MAXPS)
C                        =DEL
        HP(M) = DD1
        IF (M.GT.MXQIN)  GO TO 65
        DQNL(M,N) = DM*DQNL(M,N)
  65    DPNL(M,N) = DD1
       ORIG(N) = DPNL(0,N)*Z
       DO 94  K=1,N
        IF (QL(K).NE.QL(N))  GO TO 94
        DD2 = 0.0
        IF (ORIG(K).EQ.0.0)  GO TO 93
        DO 92  I=1,MXR
         DA(I) = 0.0
         IF (I.GT.MXQIN)  GO TO 92
         DA(I) = DQNL(I,K)*HP(I)
  92     CONTINUE
        CALL WEDDLE(DA,DD, MNE,DNS,MJH,MXR)
        DD2 = DD/2.
  93    DUY(N,K) = DD2
        DUY(K,N) = DD2
  94    CONTINUE
       DEY(N) = DD2
       PRINT 300,  QN(N),MYL, MC,ZC, CJ(0),ZE(0), MR,DPNL(0,N), RPEND,
     *             M1,M2,MYN,MYL, N,DM,DD, (HP(I),I=II,KMAX)
       IF (NSTO.EQ.0) ZE(0)=MIN(ZE(0),-1.E-10)
       DUY(N,N) = (DD-ZE(0))/2.
       SIGMA(N) = CJ(0)
       JEND(N) = 0
       IF (M1.EQ.MCLE .AND. M2.NE.MENT) GO TO 80
       IF(ABS(DM-1.).LT.0.1) GO TO 72
       IF(M1.EQ.MSTO) GO TO 72
       IF(NSTO.EQ.0) GO TO 89
       IF(M2.EQ.MENT) GO TO 89
       M1=MCLE
  80   M2=MENT
       DO 87 J=1,NSTO
        DD=ZE(J)*2.
        DO 86 K=1,2*IRAD(J)
  86     DD=ZE(J)*DD*2./K
  87    CJ(J)=SQRT(DD)*CJ(J)
       ORIG(N)=0.0
       GO TO 88
  89   PRINT 950
C      N.B.  ALL ACCEPTABLE INPUT CAN BE MARKED .STO . ON HEADER RECORD.
       STOP
C
  79  IF (NF.LE.0)  GO TO 90
C     CHECK COMPLETENESS OF RADIAL FUNCTION SET
C     COMPUTE RELATIVISTIC INTEGRALS (MASS AND DARWIN TERM, EJN-EQ.60)
      MP = 0
      DO 52  K=1,MAXGR
       IF (DEY(K).EQ.0.0)  GO TO 52
       MP = K
       IF (SIGMA(K)-999.)  96,97,98
  98   PRINT 980, K
       DEY(K) = 0.0
       NF = -1
       GO TO 52
  97   PRINT 970, K
  96   IF (NJO(1).LE.0)  GO TO 52
       DO 53  L=1,K
       DD = 0.0
       DM = 0.0
       HP(0) = 0.
       IF (DEY(L).EQ.0.0)  GO TO 54
       IF (QL(K).NE.QL(L))  GO TO 54
       DO 55  I=1,MXR
       DA(I) = 0.0
       HP(I) = 0.0
       IF (I.GT.MXQIN)  GO TO 55
       DK = 2*Z/X(I)
       DD2 = DPNL(I,L)*DK + DQNL(I,L)
       DD1 = DPNL(I,K)
       DA(I) = (DD1*DK+DQNL(I,K))*DD2
       HP(I) = DD1*DD2
  55   CONTINUE
       CALL WEDDLE(HP,DD,MNE,DNS,MJH,MXR)
       IF (QL(K).EQ.0)  HP(0) = ORIG(K)*ORIG(L)
       DA(0) = HP(0)*4.
       CALL WEDDLE(DA, DM,MNE,DNS,MJH,MXR)
       DM = -DM * ALPH2
       HP(0) = HP(0)*ALPH2/Z
  54   DMASS(K,L) = DM
       DCD(K,L) = HP(0)
  53   D2LL(K,L) = DD
  52   CONTINUE
C
      IF (KMAX.GT.0)  PRINT 400,  MXR,(X(I),I=II,KMAX)
      IF (MAXPS.GT.MXQIN)  PRINT 500, MXQIN, MAXPS, X(MXQIN)             *MXQIN*
      N = MIN(MYN,MP)
      IF (N.LE.0)  GO TO 90
C     TERMINATOR CARD (READ AT 72READ570/600) ALLOWS TO SPECIFY PRINTOUT
      PRINT 990
      M = MIN(MAXPS,MXQIN)
      DO 95  L=1,M
  95   PRINT 900,  L,X(L), (DPNL(L,I),DQNL(L,I),I=1,N)
  90  RETURN
C
C 100 FORMAT(26X,F13.6,31X,2A4,I3,I2)
  250 FORMAT (/65H  N, L,NION, Z, SIG OR C0   EPS OR ZE0  OF NUMERICAL O
     *R STO INPUT, 3X,53H( ORIGIN  N L) GAM  FNORM, <NL|H1|NL>, LAST 2-3
     * P(R):)
  300 FORMAT(1X,I2,I3,A4,1X,A4,F10.5, F13.6,1X, I4,1X,F11.5,F10.3,
     * 3X,2A4,I3,I2, 1X,I3,F8.3, F9.4,1X,1P,3E9.2)
  400 FORMAT(36X,29HREAD('')     PBAR0      RPEND,8X,I4,6H STEPS,
     * 9X,11HLAST 2-3 R:,3F9.4/)
  500 FORMAT(/' SR.RADWIN: P/Q DATA READ WHILE *MAXB2=',I3,24H -- SHOULD
     * BE .GE.MAXPS=,I3/12X,52HRESULTS INVOLVING Q(N,L) MAY BE POOR - R(80/05/14
     *MAXB2)/A0 =,F9.3)
  570 FORMAT(3I5,I3,7X,F12.6,2X,I4,29X,2A4)
  580 FORMAT(64X,42H**WARNING**   FOR THE FOLLOWING FUNCTION P/66X,
     1 I3,13H OF THE IPMX=,I3,36H INPUT VALUES P/Q HAVE BEEN IGNORED,/
     2 66X,28HEITHER BECAUSE BUFFER(MXPIN=,I3,18H) CANNOT HOLD THEM/
     3 66X,51HOR BECAUSE ARGUMENTS R HAVE BEEN READ FOR ONLY MXE=,I3/
     4 66X,24HPOINTS -- CUT-OFF RADIUS ,F7.2,15H*A0,  P(RCUT) =,E9.2)
  590 FORMAT(I5,20X,I3,2A4)
  600 FORMAT(I2,I1,I2,2(I4,2E14.7),3X,A8)
  700 FORMAT(78X,2I2,32H WILL BE SKIPPED, OVERLAP.GT.1.-,1PE7.1)
  800 FORMAT(T69,2A4,I3,I2,'  WILL BE SKIPPED, BECAUSE NO MORE FUNC-'/
     * 70X,51HTIONS ARE SPECIFIED BY SIGMA=999 FOR THIS ORBITAL L)
  900 FORMAT(I5,(7F18.6))
  950 FORMAT(/' STOPPING - FNORM FAILURE: IS RADIAL RANGE TOO SHORT?'/
     * 12X,54HENFORCE PROCESSING ON MARKING HEADER-C(T73,A4)='STO '!/)
  960 FORMAT(31H ***** OVERLAP INTEGRAL WITH K=,I2,4H IS ,E12.5)
  970 FORMAT(60X,24HP/Q-INPUT FOR ORBITAL K=,I2,34H MISSING, S.M. USED -
     * ORBITALS MAY/76X,44HNOT BE ORTHOGONAL TO INPUT-PNL'S WITH SAME L)
  980 FORMAT(60X,24HP/Q-INPUT FOR ORBITAL K=,I2,41H MISSING (OR MAXB2 TO80/05/14
     CO SMALL), CASE FAILS)
  990 FORMAT(//50H OPTIONAL PRINTOUT OF  I, R(I), N P(I) AND Q(I)'S:/)
      END
      SUBROUTINE DIAGON(ECORE,DF,IDOWN)
C
C     -- CALCULATES THE NENERG TERM ENERGIES ENERG (HARTREE UNITS)       85AP6
C     AND DATA FOR ELECTRIC RADIATION TRANSITIONS.
C     BPRINT=TRUE  DETAILED WRITING;
C NEW TRANSITIONS INVOLVING CORRELATION TERMS SUPPRESSED IF JPRINT.LT.0  85AP10
C
cM    IMPLICIT INTEGER*2(Q)
cS   C        ,INTEGER*2(I-L,N)
      INTEGER  QCG,QL,QN, QPI,QSI,QLI, QRL, QDUM
cS    INTEGER LIMR,LAM, LX,LY,LZ,LP
      LOGICAL BPRINT, BINT, BAUX, BRADAT
      DOUBLE PRECISION DD,DD1,DD2,ECORE,DMIN,DRY,DF,DS,ENERG,DE,DU,DV,X,
     * DC,DP,DPA,DRK,DRL,DEY,DUY,HNS,DPNL,OSC,ADJUST,STRNG,DB,OBO,SBO
      PARAMETER (MXD13=78*3, MXA2=130, MXB2=((MXA2+1)*MXA2)/2,
     *  NXDIP = ( ((1225-1)*1225)/2 + 1225/2 )/2)
      DIMENSION STRNG(6), IHARRY( 60),TFU( 97000),   DE(290)
     C , DU(290,290),NADRU(1225),DTM(1225),DPA(0: 999)
     C , DV(290,290),IORIG(1225),ENR(1225), DP(0: 999)
     * ,OSC(15,15),ENERG(1225),NAI(1225)
     * ,ACC(15,15), LIMR(0:15), SBO(MXA2,0:3)
     * ,OCT(15,15),    MLL(15), MIT(14),MF0(10)
      COMMON  MAXGR,NF /CCLSH/ NW,NNL(MXD13) /GENINF/ADJUST(15)
     C , SCREEN(15),MION,NZION,NPARAM,ITOL,INCLUD,JPRINT,NGROUP,IZDW
     C /CRAD/ HNS(10),MNH(10),MJH,MAXRS,IEND(15)
     C /DBD2/ DEY(15),QCG(54, 60),QL(15),QN(15)
     * /DXRL/ DRK( 513000), IRL,NRK( 513000), QRL(5, 11000)
     * /MQVC/ MDUM,MODE,KCUT,QDUM(2),NDUM(15, 60)
     C /OUTP/ MPRINT,BPRINT,MDUMM,LDUM(3)  /CUTOUT/ LSLIM1,LSLIM2
     C /RADF/ X(0: 999),DPNL(0: 999,15),DUY(15,15)
     C /REL/ DMASS(15,15),DCD(15,15),D2LL(15,15)
     C /TRANS/ DRL( 11000),OSC,OCT,TFU,ENR,NADRU,NAI,NC0,JORIG(0:1225)
     * /OMEGA/ DELEN(1225,2),B2(MXB2,0:3),M3(0:MXA2),M4(0:MXA2)
     C /TERMS/ NCONFI,NSL0, NSL( 60),NFI(1225),NFK(1225),
     *   NFQ(1225),NAD(0: 61500),QPI( 60),QSI( 60),QLI( 60)
     C /WEIGHT/ ECO(-1225:1225),WGHT(1225),MECO,INDEXW(1225)
     * /COMSD/ ASD(NXDIP),MTEC,NSD,KSD(NXDIP,2)
      EQUIVALENCE (IHARRY(1),MLL(1)), (STRNG(1),DE(1))
CW'  * ,(DU(1,1),DP(1),DTM(1)), (DV(1,1),DPA(1),IORIG(1))
      DATA DKCM/109737.31/, MXDI/290/, MAXU/ 97000/,
     C  MBLK/4H    /,MCOR/4H COR/,MOUT/4H  X /,
     *  MIT/4H    ,4H    ,4H    ,4H    ,4H    ,4H    ,4H    ,
     *      4H10**,4H5 * ,4H  * ,4H  * ,4H    ,4H    ,4H    /,
     *  MF0/4H (4I, 4H4,F1, 4H1.5,, 4HF12., 4H6,I5, 4H,I3,, 4HI4,(,
     *      4HT53,, 4H10F8, 4H.4))/, MF1,MF2/4H10F8,4H 8F8/
      DATA NSQ1,NSQ2,NBO1,NBO2/4HSQRT,4H(L*V,4HOMEG,4HA(BO/
C 180 FORMAT(4I4,F11.5,F12.6,I5,I3,I4,(T53,10F8.4))
C
  100 FORMAT(T70,I5,7H STEPS,,5X,9HR OF LAST,I2,6H P(R):,3F9.4)
  200 FORMAT (//  108H GAM (N,  L,NION, Z,  SIGMA)  EPSILON/RY     <1/R>
     *  <Z/R-V>      <R>   <R**2>   <R**3>   (ADJUST, REND, LAST,I2,
     * 6H P(R)))
  250 FORMAT(I3,4I4,F9.5,F12.5,1X,3F9.5,F9.4,1P,E9.2E1,0P, 1X,F9.4,F6.2,
     * 1X,1P,3E9.2)
  300 FORMAT(//131H I(R)   R(  A,  B,   C,  D, 2LBD ) = SLATER-INTEGRALS
     *    (2LAMBDA=-1 DENOTES ONE-BODY INTEGRALS <A|-D**2/DR**2+L(L+1)/R
     ***2-2Z/R|C>))
  400 FORMAT  (//109H   T, 2S  2L  (P) H(ZZ)/2RY EIGEN-H/2RY   CF NI  NO
     C  MATRIX <GSL|CASL>  AND  H(Z)/2RY-TRIANGLE. E(CORE)/2RY =,F12.5,
     C F11.4)
  500 FORMAT(1X,I4,A4,2I4,1P,E13.3,0P,F14.7,2PF6.1,1H%,0P,F14.6,2X,
     * 2F10.5,F12.2, F11.4,F11.5,F11.4)
  600 FORMAT(//4H   E,I1,12H-DATA  I  IP, 4X,30HA(EK)*SEC   <I||PK||IP>
     * BSSUM,2X,2A4,3HG*F,3X,A4,28HF(ABS)   -F(EMI)    WAVEL/AE,
     * A4, 9HGF(VEL)  ,2A4, 1H),A4,7HGF(ACC))
  700 FORMAT(I5,3X,2(I5,I4),I6, F14.7, 2X,A4)
  900 FORMAT(14H CORE CONTRIB.,F13.5,F12.5)
  980 FORMAT(/22H SR.DIAGON: IF MAXDI =,I4,4H.LT.,I3,20H   INCREASE  * M
     *AXDI /21H *********  IF MAXUC=,I5,4H.LT.,I5,18H INCREASE  * MAXUC)79/11/03
  981 FORMAT(31X,4I4,2X,8F9.4)
  982 FORMAT(I4,I2,(T9,15F8.4))
  983 FORMAT(/ 95H DIPOLE LENGTH INTEGRALS (K=1, FOR /L-L'/=1)  AND QUAD
     *RUPOLE (K=2) INTEGRALS  <NL| R**K |N'L'>;,8X,17H('N**' STANDS FOR/
     *8X,86HABOVE THE DIAGONAL ARE VELOCITY INTEGRALS <NL| 2*D/DR+(L'(L'
     *+1)-L(L+1))/R |N'L'> (K=1),11X,16HNL NOT COMPUTED)/3X,3HN L,
     * (T9,15(I3,I2,3X)))
  984 FORMAT(/20H SR.DIAGON  * MAXUC=,I6,24H  REQUIRED FOR ARRAY TFU/20X
     1,I6,51H  INSUFFICIENT TO COMPUTE RADIATIVE TRANSITION DATA)
  985 FORMAT(/9X,39(1H*)/9X,39H* WARNING: CORRELATION TERMS EMBEDDED */
     * 9X,39(1H*))
  995 FORMAT(I10,I8,F13.0,I5,I2,I5,F12.3,F17.6,A1,21X,'<---',F9.5)
 1996 FORMAT(78X,43HNOW MASS-VELOCITY AND DARWIN TERMS INCLUDED)
  996 FORMAT(9X,1HI,6X,2H T,8X,4HK*CM,5X,8HS L   CF,5X,7HWEIGHTS,7X,
     * 22H(EI-E1)/RY     E1/RY =,F13.6,'    TEC/RY',3X,7H(KCUT =,I3,1H))
 1997 FORMAT(//I6,74H (IF .GT. 0: LOWEST EQUALLY WEIGHTED) TERMS ARE MIN
     *IMIZED;   SCALE FACTORS,(T82,4F10.5))
  997 FORMAT(//I6,75H (IF .GT. 0: LOWEST EQUALLY WEIGHTED) TERMS ARE MIN
     *IMIZED;    SCALE FACTORS,(T83,5F10.5))
  998 FORMAT(68X,44H*WARNING*  G WILL BE MINIMIZED, AS JPRINT=-2)
 1999 FORMAT(/7X,8HINCLUD =,I4,6X,14HFUNCTIONAL F =,1PE14.7,6X,14HFUNCTI
     *ONAL G =,E10.3,2H (,I4,13H TRANSITIONS),5X,10HCOUNTDOWN:,I4)
  999 FORMAT(//7X,8HINCLUD =,I5,6X,15HFUNCTIONAL FF =,1PE14.7,6X,14HFUNC
     *TIONAL G =,E10.3,2H (,I4,13H TRANSITIONS),5X,10HLS.JPRINT=,I2)
C
      TIF(LZ)= SQRT(REAL((LZ-1)*(LZ+2)*(LZ+3)*LZ*4)) / ((LZ+2)*LZ)
C     TIF(2) = SQRT(10.)/2 ETC FOR LAM=2-->0  '00Dec19, & '01Feb10-3:
      T2UP(LX,LY,LZ) = SQRT( REAL( (LX-LY+LZ+2)*(LX-LY+LZ+4)
     *                           * (LY-LX+LZ+2)*(LY-LX+LZ+4)
C    X                    ) /REAL( (LX+LY-LZ-2)*(LX+LY-LZ  ) !'02Mar-17
C    X                           * (LX+LY+LZ+4)*(LX+LY+LZ+6) ) ) *
C    X REAL((LX+LY+LZ+4)*(LX+LY-LZ  ))/((LY-LX+LZ+4) * (LX-LY+LZ+4))
     *         *(LX+LY-LZ) )/((LX+LY-LZ-2)*(LX+LY+LZ+4)*(LX+LY+LZ+6)) )
     *  *REAL((LX+LY+LZ+4))/((LY-LX+LZ+4) * (LX-LY+LZ+4))
C      = (LX,LZ+4,LY,0.0.0) / (LX,LZ,LY,0,0,0) ALL 'TWICE' NO (2*LAM+1) 
C     AND ALTERNATING SIGN FOR LZ= 4-8-12..., IRRELEVANT: '01FEB14.
C
C
C   PRINT CHARACTERISTICS OF ONE ELECTRON RADIAL FUNCTIONS CALCULATED IN
C     SR RADIAL (SEE NOTES THERE): (NL(K)|X(I)) = DPNL(I,K), K=1,2,3..
C     FOR 1S,2S,2P..  AT POINTS X(I),I=1,MAXRS
C
      DPA(0) = 0.
      IF (.NOT.BPRINT)  GO TO 820
      NC=2
      IF(MPRINT.GE.0) NC=3
      PRINT 200, NC
      L=MAXRS-NC+1 
      DO 816 K=1,MAXGR
C     DEY(K) = TOTAL ENERGY OF A SINGLE K(=1S,2S,2P..)-ELECTRON IN Z,
C     DUY(J,K)=(NL(J)|V-Z/X|NL(K)), DD = EIGENV/2RY; NL(K)=QN(K),QL(K)/2
C      SKIP K'TH SUBSHELL IF RADIAL FUNCTION HAS NOT BEEN CALCULATED
       IF (DEY(K).EQ.0.)  GO TO 816
       N1 = QL(K)/2
       STRNG(3) = -DUY(K,K)
       STRNG(1) = (DEY(K)+STRNG(3))*2.0
       DO 818 J=2,6
        M = J-3
        IF (M.EQ.0)  GO TO 818
        DO 807 I=1,MAXRS
         DD = DPNL(I,K)
  807    DPA(I) = DD*DD * X(I)**M
        CALL WEDDLE(DPA,DC,MNH,HNS,MJH,MAXRS)
        STRNG(J) = DC
  818   CONTINUE
       M = IEND(K)
       N2 = ABS(M)
C      MM = STRNG(6)
C      IF (MM.GT.999) THEN // ELSE
       PRINT 250,  K, QN(K),N1,MION,NZION,SCREEN(K),STRNG,
     *               ADJUST(K), X(N2),(DPNL(I,K),I=L,MAXRS)
  816  CONTINUE
      PRINT 100, MAXRS,NC,(X(I),I=L,MAXRS)
C
C
C   CALCULATE SLATER INTEGRALS  DRL(L)  IF DIFFERENT SINCE PREVIOUS CALL  85APR
C
      IF(MPRINT.GE.0) PRINT 300
  820 IF (IRL.EQ.0)  GO TO 805
      DO 824  L=1,IRL
       DO 831 K=1,4
        JJ = QRL(K,L)
        IF (JJ.EQ.0)  GO TO 831
        IF (IEND(JJ).GE.0)  GO TO 832
  831   CONTINUE
       GO TO 824
  832  DRL(L) = 0.0
  824  CONTINUE
C     THE FOUR ELECTRON-ARGUMENTS (1,2,3.. FOR 1S,2S,2P..) ARE HELD
C     IN QRL(I,L),I=1,4, AND 2*LAMBDA IN QRL(5,L)
      DO 810  J=1,IRL
       IF (DRL(J).NE.0.0)  GO TO 814
       N1 = QRL(1,J)
       N2 = QRL(3,J)
       IF (QRL(5,J).GE.0)  GO TO 823
        DRL(J) = DUY(N1,N2)
        IF(IZDW.LT.0) DRL(J) = DMASS(N1,N2)+DCD(N1,N2) + DRL(J)
        GO TO 814
  823  DO 821  I=1,MAXRS
  821   DPA(I) = DPNL(I,N1) * DPNL(I,N2)
       M2 = (QL(N1) + QL(N2))/2 + 2
       JJ = QRL(5,J)
       M1 = JJ/2
       CALL YLAMK(M1,M2, DPA,DP, MNH,HNS,MJH, 0)
       DO 815 L=J,IRL
        IF (QRL(1,L).NE.N1)  GO TO 815
        IF (QRL(3,L).NE.N2)  GO TO 815
        IF (QRL(5,L).NE.JJ)  GO TO 815
        M1 = QRL(2,L)
        M2 = QRL(4,L)
        DO 822  I=1,MAXRS
  822    DPA(I) = DPNL(I,M1)*DPNL(I,M2) * DP(I)
        DPA(0) = 0.
        CALL WEDDLE(DPA,DD, MNH,HNS,MJH,MAXRS)
        DRL(L) = DD
  815   CONTINUE
  814  IF (BPRINT.AND.MPRINT.GE.0)  PRINT 700, J,(QRL(I,J),I=1,5),DRL(J)
  810  CONTINUE
      DO 833 K=1,NGROUP
cM     IF (IEND(K).GT.0)  IEND(K) = -IEND(K)
       IEND(K) = -ABS(IEND(K))
  833  CONTINUE
C
C
C   CALCULATE DIPOLE (FOR |L'-L|=1) AND SOME QUADRUPOLE MOMENTS
C     INTO UPPER TRIANGLE OF ARRAY OSC PACK DIPOLE VELOCITY INTEGRALS
C
  805 BRADAT = BPRINT .OR. JPRINT.LT.0
      IF (.NOT.BRADAT)  GO TO 830
      BINT = MPRINT.GE.-1 .AND. BPRINT
      N = 0
      NC = 0
      LP = 0
      M3(0)=0
      M4(0)=0
C     LIMR(0) = MAXRS
      DO 828 K=1,MAXGR
       MLL(K) = 10000
       IF (DEY(K).EQ.0.0)  GO TO 825
       DO 811  I=1,MAXRS
        DD = DPNL(I,K)
        IF(ABS(DD).GT.1.E-6) LIMR(K)=I
  811   DPA(I) = DD
       CALL DIFF(DPA(1),DP(1), MNH,HNS,MJH)
       MLL(K) = QL(K)/2
C OLD  NGROUP = K
       M1 = K
  825  DO 828 J=1,K
        DB = 0.0
        DC = 0.0
        DD = 0.0
        IF (DEY(J)*DEY(K).EQ.0.) GO TO 827
        IF(J.LE.NNL(NW)) GO TO 828 
         LL = ABS(MLL(K)-MLL(J))
         NC = NC+1
         IF(BINT) write(*,"(/' CALLing BORN at K1,K2= ',2I3)") m1,j
         IF(NC.GT.MXA2) GO TO 839
         M2=J
         M4(NC)=M2
         M3(NC)=M1
         IF(.NOT.BPRINT) GO TO 839
         DO 888 I=1,NC
          N = N+1
          B2(N,0) = 0. ! CASE OPTICAL E1!
          L = MLL(M3(I))+MLL(M4(I))
          IF (MOD(L,2).NE.MOD(LL,2)) GO TO 888
          LAM = MIN(L,MLL(K)+MLL(J))
          IF (LAM.EQ.1) GO TO 888
          L = ABS(MLL(M3(I))-MLL(M4(I)))
          IF (MAX(L,LL).GT.LAM) GO TO 888
          IF(BINT) write(*,"(13X,'and K3,K4= ',6X,3I3)") M3(I),M4(I),LAM
          IF(LAM/2.LE.3) GO TO 808
           IF (BINT .OR. LP.LT.LAM) print *,
     *  ' >>> DIAGON dropping Born multipoles above LAM = ',LAM-2,' <<<'
           LP = MAX(LAM,LP)
           LAM = 3*2 + MOD(LAM,2)
           GO TO 809
  808      CALL BORN(LAM, M1,M2,M3(I),M4(I), MLL, LIMR,BINT, DD1)
           IF(N.GT.MXB2) THEN
c !!!       print * "(/' STOPPING: AUGMENT MAXBO FOR BORN INTEGRALS!')"
            STOP "DIAGON-BORN: MAXBO too small!"
           ENDIF
           M4(0) = MAX(LAM/2,M4(0))
           B2(N,LAM/2) = DD1
           LAM = LAM-2
  809      IF (LAM.EQ.1) GO TO 888
           IF (MAX(L,LL).GT.LAM) GO TO 888
            IF(BINT) write(*,"('  same with LAM=',I1,':')") LAM
            GO TO 808
  888     CONTINUE
  839   IF (LL.GT.3)  GO TO 827
        IF (QL(K)+QL(J).EQ.0)  GO TO 827
        NN = LL
        IF (LL.LE.1) NN = LL+2
  841   DO 826 I=1,MAXRS
  826    DPA(I) = DPNL(I,J)*DPNL(I,K)*X(I)**NN
        CALL WEDDLE(DPA,DB,MNH,HNS,MJH,MAXRS)
        IF (NN.LT.0) GO TO 641
         IF(NN.EQ.3) THEN
          OCT(J,K) = DB
          OCT(K,J) = DB
          NN = NN-2
          GO TO 841
         ENDIF
         DD = DB
         NN = -2
         IF(LL.LT.3) GO TO 841
         GO TO 827
C
  641   IF (J.EQ.K)  GO TO 741
        IF (LL.EQ.0)  LL = 2
        DD2 = (MLL(K)+1)*MLL(K) - (MLL(J)+1)*MLL(J) + (LL-1)*LL
        DD1 = 1
        DO 812 I=1,MAXRS
         IF (LL.EQ.2)  DD1 = X(I)
  812    DPA(I) = (DPNL(I,K)*DD2/X(I) + DP(I)*LL*2) * DPNL(I,J)*DD1
        CALL WEDDLE(DPA,DC,MNH,HNS,MJH,MAXRS)
  827   OSC(J,K) = DC
  741   ACC(K,J) = DB ! acceleration integrals
  828   OSC(K,J) = DD
      if(nc.GT.MXA2) then
       print *,' MAXBO arrays too short to hold BORN B2 data'
      else
       M3(0) = NC
      endif
      IF (.NOT.BPRINT)  GO TO 830
      IF (MPRINT.LT.-1) GO TO 830
      PRINT 983,  (QN(I),MLL(I),I=1,NGROUP)
      DO 829 I=1,NGROUP
  829 PRINT 982,  QN(I),MLL(I),(OSC(I,J),J=1,NGROUP)
C
C
C   CONSTRUCT AND DIAGONALIZE ENERGY (SUB-)MATRICES (UNITS  2*RYDBERGS).
C     FIND THE TERM WITH THE LOWEST ENERGY
C
  830 DO 850 I=1,NCONFI
  850  IHARRY(I) = 0
C     CALCULATE ENERGY CONTRIBUTION ECORE OF THE NW CORE ELECTRONS
      DD1 = 0.0
      DD2 = 0.0
      IF (NW.EQ.0)  GO TO 726
      DO 727  L=1,NW
       J = NNL(L)
       IF(IZDW.LT.0) DD1 = DMASS(J,J)+DCD(J,J) + DD1
  727  DD1 = DEY(J) + DD1
      IF (NAD(0).EQ.0)  GO TO 726
      DO 723  I=1,NAD(0)
       J = NRK(I)
  723  DD2 = DRL(J) * DRK(I)  + DD2
  726 ECORE = DD1 + DD2
      IF (BPRINT) THEN
       MF0(9) = MF2
       IF(MPRINT.GE.0) THEN
        MF0(9) = MF1
        PRINT 400,  DD2,DD1
       ELSE IF(MPRINT.GE.-2) THEN
        PRINT 400,  ECORE
       ENDIF
      ENDIF
C
      MTEC = MECO
      ITECO = 0
  701 ITECO=ITECO-1
      DMIN = DKCM
      N = 0
      M = 0
      NENERG = 0
      JORIG(0) = 0
C     SUBMATRICES 2S,2L=QSI,QLI(K) (NF = NUMBER OF VALENCE ELECTRONS)
C     LOOP 728 (WITH 723) CORRESPONDS TO LOOP 61 (WITH N=0) IN SR ALGEB2
      DO 728 K=1,NSL0
      NC = NSL(K)
      MM = NC*NC
      IF (MM.GT.MAXU)  GO TO 990
      IF (NC.GT.MXDI)  GO TO 990
      BINT = MM+M.LE.MAXU
      DO 722  I=1,NC
       DELEN(I+NENERG,1) = ECO(I+NENERG)
      DELEN(I+NENERG,2) = ECO(-I-NENERG)
      NN = M
      IF (.NOT.BINT)  NN = (I-1)*NC
      DO 724  J=1,I
      N = N + 1
      N1 = NAD(N-1) + 1
      N2 = NAD(N)
      DU(I,J) = 0.0
CADD  DU(I,I) = DD2 !'02Jun20/24: TEC
      DU(I,I) = DELEN(I+NENERG,1)/2.
      IF(N1.GT.N2) GO TO 720                                            79/10/31
      DO 721  L=N1,N2
      M1 = NRK(L)
  721 DU(I,J) = DRL(M1)*DRK(L) + DU(I,J)
  720 TFU(J+NN) = DU(I,J)
  724 DU(J,I) = DU(I,J)
      J = I + NENERG
      M1 = NFK(J)
      NAI(J) = I
      NADRU(J) = NN
      M = M + NC
      DE(I) = 0.0
CADD  DE(I) = DD1
      DO 729  L=1,NF
      M2 = QCG(L,M1)
      IF(IZDW.LT.0) DE(I) = DMASS(M2,M2)+DCD(M2,M2) + DE(I)
  729 DE(I) = DEY(M2) + DE(I)
  722 DU(I,I) = DU(I,I) + DE(I)
C     DIAGONALIZATION: NO REORDERING ACCORDING TO FALLING EIGENVALUES BY
      NC=-NC
      CALL  JACORD( NC, BRADAT , DU , DV , MXDI )
C     IF TRUE THEN TRANSFORMATION MATRIX OTHERWISE ENERGY MATRIX IN DV.
      DO 725 I=1,NC
      J = I + NENERG
C     J'TH EIGENFUNCTION TO QSI,QLI,QPI(K)=2*S,2*L,PARITY(0,2=EVEN,ODD).
C     THE EIGENVALUE IN ATOMIC UNITS IS IN DU(I,I). THE EIGENVECTOR AS
C     LINEAR COMBINATION OF ONE-CONFIGURATION VECTORS IS IN DV(L,I),L=1,
C     NC; I=J-NENERG.  NFK(L),L=NENERG+1,NENERG+NC CONTAINS THE POSITION
C     CF OF THE CONFIGURATION, NFI(L),L=NENERG+1,NENERG+NC THE POSITION
C     OF THE TERM WHEN SCANNING THROUGH THE CONFIGURATION LISTS, AND
C     IHARRY(NFK(L)) THE TERM POSITION WITHIN THAT CONFIGURATION. E&N1.5 DIAGON
      DD = DU(I,I)
      JORIG(J) = 0
      IF (DD.LT.DMIN)  DMIN = DD
      IF (.NOT.BRADAT)  GO TO 725
      JJ = NFK(J)
      IHARRY(JJ) = IHARRY(JJ)+1
      II = NADRU(J)
      M1 = II+1
      M2 = II+I
      IF (BPRINT .AND.MPRINT.GE.-1)  PRINT MF0, J, QSI(K),QLI(K),QPI(K),
     *   DE(I),DD,JJ, IHARRY(JJ), I, (DV(L,I),L=1,NC), (TFU(L),L=M1,M2)
      DO 730  L=1,NC
  730  TFU(L+II) = DV(L,I)
  725 ENERG(J) = DD
  728 NENERG = J
      IF (BPRINT .AND. MPRINT.GE.-2)  PRINT 900, DD1,ECORE
C
C
C   CONSTRUCT FUNCTIONAL F (=DF+ECORE)
C     FORM (WEIGHTED) ENERGY SUM DF, AND PRINT TERM LIST IN ENERGY ORDER
C     NORMALIZE TO 0 FOR THE TERM WITH MINIMUM ENERGY
C     CONVERT ENERGY DIFFERENCES TO WAVE NUMBERS
C     NFQ(I) = INDEX TO QXI OF I'TH TERM IN /TERMS/-ORDER, (X FOR L,S,P)
C     NFK(I) = INDEX OF CONFIGURATION OF I'TH TERM
C
   50 BAUX = JPRINT.GE.4 .OR. BPRINT
      NTCC = 0
      IF (INCLUD.GT.NENERG)  INCLUD = NENERG
      NC0 = N
      IF (.NOT.BAUX)  GO TO 20
      IF(MPRINT.GE.0) THEN
      PRINT 997,  INCLUD, (ADJUST(I),I=1,NGROUP)
      ELSE
      PRINT 1997,  INCLUD, (ADJUST(I),I=1,NGROUP)                        DL85AP4
      ENDIF
      IF(IZDW.LT.0) PRINT 1996
      DRY = (ECORE+DMIN)*2.0
      PRINT 996,   DRY, KCUT
   20 DF = 0.0
      DS = 0.0
      LL = -INCLUD
      DO 80 J=1,NENERG
       DRY = DKCM
       DO 60 JJ=1,NENERG
        IF (JORIG(JJ).GT.0)  GO TO 60
        IF (ENERG(JJ).GE.DRY)  GO TO 60
        I = JJ
        DRY = ENERG(JJ)
   60   CONTINUE
       IORIG(J) = I
       JORIG(I) = J
       JJ = NFQ(I)
       II = QSI(JJ)+1
C OLD  IF (J.GT.INCLUD .AND. I.NE.-INCLUD)  GO TO 30
       DD = 0.0
       IF (LL)  55,30,35
   35  DO 45  K=1,LL
        IF (INDEXW(K).NE.I)  GO TO 45                                   D-NX+COR
        DD = WGHT(K)
        GO TO 65
   45   CONTINUE
       GO TO 30
   55  IF (J.GT.INCLUD)  GO TO 30
C OLD  DD = (QLI(JJ)+1)*II
       DD = 1.
   65  DF = DRY*DD + DF
       DS = DS + DD
   30  ENERG(I) = DRY-DMIN
       DRY = ENERG(I) * 2.0
       ENR(I) = DRY
       DTM(I) = DRY*DKCM
       II = (1-QPI(JJ))*II
       JJ = QLI(JJ)/2
       IF (KCUT.EQ.0 .OR. NFK(I).LE.KCUT) JORIG(0)=JORIG(0)+1
       IF (J.EQ.JORIG(0)) NTCC = J
C      SO AS TO STOP IN FRONT OF EMBEDDED TERMS;
       IF (.NOT.BAUX)  GO TO 80
       M=0
       IF(DELEN(I,1).NE.0.) M=1
       PRINT 995, J,I,DTM(I), II,JJ,NFK(I),DD,DRY,(' ',DELEN(I,1),K=1,M)
   80  CONTINUE
      IF(NTCC.NE.JORIG(0)) WRITE(6,985)
      IF (DS.NE.0.0)  GO TO 90
      DS = 1.0
      ECORE = 0.0
      IF (LL.LE.0)  GO TO 90
   70 FORMAT(I6,6H CALC ,F10.1,9H     OBS ,F10.1,13H   SQ-DIF.SUM,E16.5)UCL75NV:
         DO 40  I=1,LL
          II = -INDEXW(I)
          IF (II.EQ.0)  II = IORIG(I)
          DO 10 J=1,I
          JJ = -INDEXW(J)
          IF (JJ.EQ.0)  JJ = IORIG(J)
   10     DF = ( DTM(II)-DTM(JJ) - WGHT(I)+WGHT(J) )**2 + DF
          IF (BAUX)  PRINT 70, I, DTM(II), WGHT(I), DF
   40     CONTINUE
   90 DF = DF/DS
C
C
C   COMPUTE ELECTRIC MULTIPOLE DATA (A, G*F, F(ABS), F(EMI), WAVELENGTH)
C
      NGF = 0
      SGF = 0.0
      IF (.NOT.BRADAT)  GO TO 745
      if (LSLIM2.lt.0) go to 745
      IF (BINT)  GO TO 710
      PRINT 984,  M, MAXU
      GO TO 750
C     INSUFFICIENT TF COEFFICIENTS OR REDUCED MATRIX ELEMENTS
  710 IF (NAD(N+1).EQ.0)  GO TO 745                                     UCL77FEB
      NSD = 0
      BAUX = JPRINT.EQ.2 .OR. JPRINT.GT.4
      NMULTI = 1
      MIT(5) = NSQ1
      MIT(6) = NSQ2
  740 IOS = -1
      DO 732 II=1,NENERG
       I = IORIG(II)
       NC = NFQ(I)
       DMIN = QSI(NC) + 1
       K1 = I - NAI(I) + 1
       K2 = K1 + NSL(NC) - 1
       DO 733 JJ=II,NENERG
        J = IORIG(JJ)
        IF (J.EQ.I) GO TO 733
        ND = NFQ(J)
C       FOR SPEED PRE-SELECT ACCORDING TO MULTIPLICITY, PARITY, TOTAL L:
        IF (QSI(ND).NE.QSI(NC)) GO TO 733
        IF (QLI(ND)+QLI(NC).EQ.0) GO TO 733
        M = QPI(ND)-QPI(NC)
        IF (ABS(M).EQ.(NMULTI-1)*2)  GO TO 733
        ML = QLI(ND)-QLI(NC)
        IF (ABS(ML).GT.2*NMULTI)  GO TO 733
        L1 = J - NAI(J) + 1
        L2 = L1 + NSL(ND) - 1
        SU = 0.0
        AS = 0.0
        DC = 0.0
        DD = 0.0
        NSG = 1
        DO 796 L=0,M4(0)
         DO 796 K=1,M3(0)
  796     SBO(K,L) = 0.
        DO 734  K=K1,K2
         N1 = NADRU(I)+NAI(K)
         DD1 = TFU(N1)
         IF (ABS(DD1).LT.1.E-5)  GO TO 734
         DO 735  L=L1,L2
          N2 = NADRU(J)+NAI(L)
          DD2 = TFU(N2)
          IF (ABS(DD2).LT.1.E-5)  GO TO 735
          M = K + NC0
          DS = 1.0
          BINT = L.LE.K
          IF (BINT)  GO TO 731
          M = L + NC0
          DS = 1-MOD(ABS(ML),4)                                         UCL78AUG
  731     N1 = NAD(M-1) + 1
          N2 = NAD(M)
          IF (N2.LT.N1)  GO TO 735
          DO 736  M=N1,N2
           M1 = NRK(M)/MAXGR**2
           M2 = M1+1
           IF (BINT .AND. M2.NE.L)  GO TO 736
           IF (.NOT.BINT .AND. M2.NE.K)  GO TO 736
           M1 = (NRK(M)-M1*MAXGR*MAXGR)/MAXGR + 1
           MM = NRK(M) - ((M2-1)*MAXGR+M1-1)*MAXGR + 1                  VEL74JUL
           M2 = MIN(M1,MM)
           M1 = M1+MM - M2
           LP = QL(M1)
           MP = QL(M2)
           IF (MP+LP.EQ.0) GO TO 735
           DB = 0.0
           NN = 1
           IF (ABS(MP-LP).EQ.2)  NN = 2 ! UCL78AUG
           IF (NN-NMULTI)  743,736,739
  743      IF (M2.EQ.M1)  GO TO 738
  739      DB = OSC(M2,M1)
C          COMPENSATE FOR RELATIVE CHANGE OF ORBITAL TO TERM ORDER:
           IF (MM.NE.M1) DB=-DB
           IF(.NOT.BINT) DB=-DB
C          ADD CONTRIBUTIONS TO VELOCITY (DC) AND LENGTH (DD) AMPLITUDE VEL74JUL
  738      DRY = DD1*DD2*DRK(M)*DS
           DC = DB * DRY + DC
           DB = OSC(M1,M2)
           DD = DB * DRY + DD
           SU = ABS(DB*DRY) + SU
           AS = DRY*ACC(M1,M2)*(NN-1) + AS
           IF (.NOT.BPRINT)  GO TO 736
           IF (IOS.LT.0) THEN
            IOS = 7
            IF(MPRINT.LT.0 .OR. NMULTI.EQ.2) IOS = 6
            PRINT 600,  NMULTI, (MIT(KK+(NMULTI-1)*7),KK=1,IOS)
            IOS = 0
           ENDIF
           IF (BAUX) PRINT 981, K,L,M1,M2, DD1,DD2, DRY,DB,DD, DC,AS, SU
           IF (NMULTI.NE.2 .OR. M3(0).EQ.0) GO TO 736
            DO 757 N=1,M3(0)
             IF(M3(N).NE.M1) GO TO 757
             IF(M4(N).NE.M2) GO TO 757
             IF(QLI(ND).EQ.QLI(NC) .AND. LP.EQ.MP) ! nb LP+MP>0 since E2
     *        SBO(N,0) = DRY*TIF(MP) + SBO(N,0) ! monopole contribution
c            SBO(N,1) = DRY + SBO(N,1) !test '00Nov23: neg OBO as i**lam
C            write(6,"(17x,' test 757: K,L, M1,M2, N sbo =',2(i4,i3),i4,
C    *        1pe12.5e1)") k,l, m1,m2,ix, sbo(n,1)
             DB = 1.
             DO 777 LAM=1,M4(0)
              SBO(N,LAM) = DB*DRY + SBO(N,LAM)
              IF(LP+MP.LE.4*LAM) GO TO 736 ! e.g. abs(LP-MP).le.4 at E2!
  777         DB = T2UP(LP,4*LAM,MP)*DB ! hexadecupole contribution etc.
             IF (LP+MP.GT.3*4) NSG=-1 ! to mark for lack of storage
             GO TO 736
  757        CONTINUE
            STOP " DIAGON: no pair"
  736      CONTINUE
  735     CONTINUE
  734    CONTINUE
        IF (DD.EQ.0.0)  GO TO 733
        IOS = IOS + 1
        DRY = (ENERG(J)-ENERG(I)) * 2.0
        DP(4) = 4*NZION*AS/(DRY*DRY)
        WLG = 1.E-2
        MP = 0
        LP = 4
        IF(MPRINT.LT.0) LP = 3
        DB = DRY/3
        OBO = 0.
        IF (NMULTI.EQ.1)  GO TO 742
         M = 0
         DO 795 L=1,M3(0)
          DO 794 K=1,L
           M = M+1
           DS = 0.
           DO 793 N=0,M4(0)
  793       DS =  SBO(K,N)*SBO(L,N) * B2(M,N) * (4*N+1) + DS
  794      OBO = DS+DS + OBO
  795     OBO = OBO - DS
         OBO = REAL((QSI(ND)+1)*NSG) * OBO * 8.
         WLG = 1.E-7
         MP = 5
         DB = 2.21879E-7 * DRY*DRY*DRY
         LP = 3
  742   DS = DB * DD*DD
        AS = 8.0322E+9 * DS*DRY*DRY/(QLI(ND)+1)                         UCL78AUG
        IF (AS.LT.WLG)  GO TO 733
        MM=MBLK
C       FOR INCLUD.LT.0 EXCLUDE TRANSITIONS INVOLVING ZERO-WEIGHT TERMS UCL75NOV
C       FROM FUNCTIONAL G (WHICH NEVER INVOLVES CORRELATION TERMS)
        IF (LL.LE.0)  GO TO 746
        NN = -1
        DO 747  K=1,LL
         IF (INDEXW(K).NE.I .AND. INDEXW(K).NE.J)  GO TO 747
         NN = NN+1
         IF (NN.GT.0)  GO TO 746
  747    CONTINUE
        MM = MOUT
  746   IF (KCUT.LE.0)  GO TO 749
        IF (NFK(I).GT.KCUT.OR.NFK(J).GT.KCUT)  MM=MCOR
  749   IF ((JPRINT.LT.0 .OR. MPRINT.LE.0) .AND. MM.EQ.MCOR)  GO TO 733
        BINT = (JPRINT.NE.1 .OR. MM.NE.MCOR) .AND. BPRINT
        IF(.NOT.BINT) GO TO 709
        BINT = MPRINT.GE.0 .OR. MM.NE.MCOR
        IF(LSLIM1+LSLIM2.EQ.0) GO TO 709
        BINT = (II.GE.LSLIM1 .AND. JJ.LE.LSLIM2)
  709   DB = DB*DMIN*10**MP
        DC = DC/DRY
        DP(2) = DB * DC*DC
        DP(3) = DB * DC*DD
        DS = DS*10**MP
        DD1 = DS / (QLI(NC)+1)
        DD2 = DS / (QLI(ND)+1)
        DS = DS*DMIN
        IF (BINT) THEN
C        -- 00'JUN22 TRYING OM(BORN):
         IF(NMULTI.EQ.2)  DP(3) = OBO
         DP(1) = 1.E+8/(DRY*DKCM)
         DP(4) = DB * DP(4)*DP(4)
         SU = ABS(DD)/SU
         PRINT 500, IOS,MM,II,JJ, AS,DD,SU,DS, DD1,DD2, (DP(K),K=1,LP)
        ENDIF
C       IN ELECTRIC DIPOLE CASE ADD CONTRIBUTION TO FUNCTIONAL G
        IF (NMULTI.NE.1)  GO TO 733
        IF (MM.NE.MBLK)  GO TO 733
         NGF = NGF+1
         SGF = (DS+DP(2)-2*DP(3))/(DS+DP(2)+2*DP(3)) + SGF ! UCL78AUG
C        FOR TCC FILE IN DIAGFS:
         IF (II.GT.NTCC .OR. JJ.GT.NTCC) GO TO 733
         IF(ABS(DD).LE.1.E-9) GO TO 733
         NSD = NSD+1
         ASD(NSD) = DD
         KSD(NSD,1) = II
         KSD(NSD,2) = JJ
  733   CONTINUE
  732  CONTINUE
C     print *,' FERMI TEST: JPRINT,NMULTI =',JPRINT,NMULTI
C     IF (JPRINT.LT.0)  GO TO 744
      IF (MPRINT.LT.-2 .AND. MODE.NE.-2)  GO TO 744
      MIT(12) = NBO1
      MIT(13) = NBO2
      NMULTI = NMULTI + 1
      IF (NMULTI.LE.2)  GO TO 740
C
  744 IF (NGF.NE.0)  SGF = 2.*SGF/NGF
  745 IF (MPRINT+2) 773,772,771
  771  DRY = (DF+ECORE)*2.
       IF (IDOWN.NE.0) PRINT 999, INCLUD, DRY,SGF,NGF, JPRINT
       GO TO 773
  772  PRINT 1999, INCLUD, DF, SGF,NGF, IDOWN
  773 IF (JPRINT.NE.-2)  GO TO 750
      DF = SGF
      PRINT 998
      GO TO 748
C
  990 PRINT 980,  MXDI,NC, MAXU,MM
      NF = -2
      DF = 0.0
  748 ECORE = 0.0
  750 RETURN
      END
      SUBROUTINE BORN(LAM, K1,K2,K3,K4, LL, LIMR, PRT, BINT)
c
C     adapted BORN from Alan Burgess, DAMTP Cambridge:
c
Computes the Born integrals specified in the appendix to
c
      PARAMETER (ID=1024, M0=7)
      DOUBLE PRECISION  DPNL,DUY,X,
     *       X1,X2,X3,  V1,V0,VM1,VM2,VM,BINT,OINT,EB,EO,V,C,
     *       P1,P2,F1,F2,F12,F34,  R1,H1,B11,B22,B12,TM12,R2,H2
      INTEGER LAM,K1,K2,K3,K4,LL,LIMR, I,I1,I2,M
      LOGICAL CF,PRT
      DATA V0,V1/0.,9999./
C
      COMMON
     *  /RADF/ X(0: 999),DPNL(0: 999,15),DUY(15,15)
      DIMENSION X1(0:ID),X2(0:ID),X3(0:ID)
      DIMENSION F1(0:ID),F2(0:ID), F12(0:ID),F34(0:ID)
      DIMENSION P1(0:ID),P2(0:ID), LIMR(0:*),LL(*)

       CF = K3.NE.K1 .OR. K4.NE.K2
        I1 = ID
        M = MAX(LIMR(K1),LIMR(K2))
        IF (X(LIMR(K1)+LIMR(K2)-M)*1.5 .GT. X(M)) I1=I1/2
        R1 = X(M)
       H1=R1/I1
       CALL PNL(ID,I1,H1,LL(K1),X,DPNL(0,K1),LIMR(K1),F1)
       CALL PNL(ID,I1,H1,LL(K2),X,DPNL(0,K2),LIMR(K2),F2)
       CALL NORMS(ID,I1,H1,LAM,F1,F2,F12, B11,B22,B12,TM12, VM1)
       IF (CF) THEN
         I2 = ID
         M = MAX(LIMR(K3),LIMR(K4))
         IF (X(LIMR(K3)+LIMR(K4)-M)*1.5 .GT. X(M)) I2=I2/2
         R2 = X(M)
        H2=R2/I2
        CALL PNL(ID,I2,H2,LL(K3),X,DPNL(0,K3),LIMR(K3),F1)
        CALL PNL(ID,I2,H2,LL(K4),X,DPNL(0,K4),LIMR(K4),F2)
        CALL NORMS(ID,I2,H2,LAM,F1,F2,F34, B11,B22,B12,TM12, VM2)
       ELSE
        R2=R1
        I2=I1
        DO 10 I=1,I1
   10    F34(I)=F12(I)
        VM2=VM1
       ENDIF
       VM=(VM1+VM2)*.5
       CALL ROMB(ID,CF,LAM, R1,I1,F12, R2,I2,F34, VM,V0,V1, M0,X1,X2,X3,
     *   P1,P2,BINT,OINT,EB,EO)
       IF(PRT) WRITE(*,114) 2**M0,BINT,OINT,VM,EB,EO
      RETURN
C
  114  FORMAT( I4,' steps in K.   Integral(K0 to K1)dK = ',1P,E11.4,
     * E14.4/'  Km =',E8.2E1,5X,'Approx.relative error',E13.1,E14.1)
      END
      SUBROUTINE PNL(ID,IR,H,L, X,P,JMAX,F)
      INTEGER ID,IR,L,I,J, M,JMAX
      DOUBLE PRECISION  H,X,P,F,R,T, Y1,Y2,Y3, FLAGR,
     *       X1,X2,X3,X4,Z1,Z2,Z3,Z4,Z
      DIMENSION X(0:ID),P(0:ID),F(0:ID)
      FLAGR(X1,X2,X3,X4,Z1,Z2,Z3,Z4,Z) = 
     C   ((Z-X2)*(Z-X3)*(Z-X4)/((X1-X2)*(X1-X3)*(X1-X4))) * Z1
     C + ((Z-X1)*(Z-X3)*(Z-X4)/((X2-X1)*(X2-X3)*(X2-X4))) * Z2
     C + ((Z-X1)*(Z-X2)*(Z-X4)/((X3-X1)*(X3-X2)*(X3-X4))) * Z3
     C + ((Z-X1)*(Z-X2)*(Z-X3)/((X4-X1)*(X4-X2)*(X4-X3))) * Z4
      R=0.0
      F(0)=0.0
      M=L+1
      J=0
      DO 2 I=1,IR
       R=R+H
C      F(I)=FINTER(ID,R,L,X,P,NC,J):
    1  IF ( R.GT.X(J) .AND. J.LT.JMAX ) THEN
        J=J+1
        GO TO 1
       ENDIF
       IF (J .LT. 3) THEN
        Y1=P(1)/X(1)**M
        Y2=P(2)/X(2)**M
        Y3=P(3)/X(3)**M
        T=FLAGR(X(0),X(1),X(2),X(3),P(0),Y1,Y2,Y3, R)*R**M
       ELSE
        IF (J.LT.JMAX) THEN
         T=FLAGR(X(J-2),X(J-1),X(J),X(J+1),P(J-2),P(J-1),P(J),P(J+1),R)
        ELSE
         T=P(J)*EXP((X(J)-R)*LOG(P(J-1)/P(J))/(X(J)-X(J-1)))
        ENDIF
       ENDIF
    2  F(I)=T
      RETURN
      END
      SUBROUTINE NORMS(ID,IR,H,L,F1,F2,F12,B11,B22,B12,TM12, VMAX)
      INTEGER ID,IR,L,I
      DOUBLE PRECISION H,F1,F2,F12,B11,B22,B12,TM12,R,S1,S2,S,P1,P2,
     * F,T, RM,X,VMAX
      DIMENSION F1(0:ID),F2(0:ID),F12(0:ID)
       R=0.0
       X=0.0
       S1=0.0
       S2=0.0
       S=0.0
       TM12=0.0
       DO 1 I=1,IR
        R=R+H
        P1=F1(I)
        P2=F2(I)
        F=P1*P2
        T=ABS(F)*R
        IF (T .GT. X) THEN
         X=T
         RM=R
        ENDIF
        F12(I)=F
        T=MOD(I,2)+1
        S1=T*P1*P1+S1
        S2=T*P2*P2+S2
        T=T*F
        S=T+S
    1   TM12=TM12+T*R**L
       T=2.0*H/3.0
       B11=T*S1
       B22=T*S2
       B12=T*S
       TM12=T*TM12
        X=L+.5
        T=X**0.33333333
       VMAX=(1.85575*T+1.03315/T+X)*0.5/RM
       RETURN
      END
      SUBROUTINE ROMB(ID,CF,L,R1,I1,F1,R2,I2,F2,VM,V0,V1,M0,S1,S2,S3,
     & S4,S5,BINT,OINT,EB,EO)
      INTEGER ID,L,I1,I2,M,I,J,M0,N,K
      DOUBLE PRECISION R1,F1,R2,F2,VM,V0,V1,S1,S2,S3,S4,S5,BINT,OINT,
     *  EB,EO,H,R,S, T,TM1,X0,X1,X,V,FB1,FO1,FB2,FO2,T1,T2,
     *  B0,O0,SB,SO, BI,OI, T0,U0,T3,U1,U2,U3
      LOGICAL CF
      CHARACTER ANS*1
      DIMENSION BI(0:20),OI(0:20),F1(0:ID),F2(0:ID)
      DIMENSION S1(0:ID),S2(0:ID),S3(0:ID),S4(0:ID),S5(0:ID)
      X0=V0/(V0+VM)
      X1=V1/(V1+VM)
      X=X0
      V=V0
      K=0
    1  CALL FILON(L,V,R1,I1,F1,FB1,FO1)
       FB2=FB1
       FO2=FO1
       IF(CF) CALL FILON(L,V,R2,I2,F2,FB2,FO2)
       T=V+VM
       T=T*T/VM
       T2=FB1*FB2*V
       IF(L.EQ.0) THEN
        T1=T2
        T2=FO1*FO2*V
       ELSE
C N.B.  IF(L.EQ.1) STOP!
        T1=FB1*FB2*V**(L+L-3) 
        DO 2 J=1,L
    2    T2=T2*V*V
       ENDIF
       S1(K)=V
       S2(K)=FB1
       S3(K)=FB2
       S4(K)=T1
       S5(K)=T2
       IF(K.EQ.0) THEN
        B0=T*T1
        O0=T*T2
        X=X1
        V=V1
        K=ID
        GO TO 1
       ENDIF
       B0=(T*T1+B0)*.5
       O0=(T*T2+O0)*.5
      H=X1-X0
      BI(0)=B0*H
      OI(0)=O0*H
      SB=0
      SO=0
      M=0
    3  M=M+1
       H=H*.5
       X=X0-H
       N=2**(M-1)
       DO 5 I=1,N
        X=X+H+H
        V=VM*X/(1-X)
        T=V+VM
        T=T*T/VM
        CALL FILON(L,V,R1,I1,F1,FB1,FO1)
        FB2=FB1
        FO2=FO1
        IF(CF) CALL FILON(L,V,R2,I2,F2,FB2,FO2)
        T2=FB1*FB2*V
        IF(L.EQ.0) THEN
         T1=T2
         T2=FO1*FO2*V
        ELSE
C N.B.   IF(L.EQ.1) STOP!
         T1=FB1*FB2*V**(L+L-3)
         DO 4 J=1,L
    4     T2=T2*V*V
        ENDIF
        SB=T1*T+SB
        SO=T2*T+SO
        K=NINT(((X-X0)*ID)/(X1-X0))
        S1(K)=V
        S2(K)=FB1
        S3(K)=FB2
        S4(K)=T1
    5   S5(K)=T2
       T0=BI(0)
       BI(0)=(B0+SB)*H
       U0=OI(0)
       OI(0)=(O0+SO)*H
       DO 6 I=1,M
        T3=1./(2**(I+I)-1)
        T1=BI(I-1)
        U1=OI(I-1)
        T2=(T1-T0)*T3+T1
        U2=(U1-U0)*T3+U1
        T3=T0
        T0=BI(I)
        BI(I)=T2
        U3=U0
        U0=OI(I)
    6   OI(I)=U2
       EB=ABS((T2-T3)/T2)
       EO=ABS((U2-U3)/U2)
      IF (M.LT.M0 .AND. 2**M.LT.ID) GO TO 3
      BINT=T2
      OINT=U2
      RETURN
      END
      SUBROUTINE FILON(L,V,RMAX,IMAX,F,FB,FO)
      INTEGER L,IMAX,I,J,K
      DOUBLE PRECISION V,RMAX,F,FB,H,B0,B1,B2,R,S0,S1,V2,
     * T,T0,T1,T2,T3,S,C,U,B,FO,C0,S2,S3,TT
      DIMENSION F(0:*)
      H=RMAX/IMAX
      B0=1.0
      IF(L.GT.0) THEN
       DO 1 I=1,L
    1   B0=(I+I+1)*B0
       B0=1.0/B0
       B1=1.0/(L*4+6)
       B2=B1/(L*8+20)
       TT=L*.25
      ELSE
       S2=0.0
       S3=0.0
       T1=1./5040.
       TT=0.1
      ENDIF
      R=0.0
      S0=0.0
      S1=0.0
      V2=V*V
      DO 5 I=1,IMAX
       R=R+H
       T=V*R
       IF (T.LT.TT) THEN
        T2=T*T
        IF(L.GT.0) THEN
         T1=((B2*T2-B1)*T2+1.)*B0
         DO 2 K=1,L
    2     T1=R*T1
        ELSE
         T0=((42.-T2)*T2-840.)*T1*R*R
         T2=V2*T0+1.
        ENDIF
       ELSE
        IF (T .LT. 8.E+6) THEN
         S=SIN(T)
          C=COS(T)
        ELSE
         S=0.0
          C=0.0
        ENDIF
        IF(L.EQ.0) THEN
         T2=S/T
         T0=(T2-1.)/V2
        ELSE
         U=1.0/T
         T1=(S*U-C)*U
         IF (L .GT. 1) THEN
          T0=S*U
          DO 3 K=1,L-1
           T2=(2*K+1)*T1*U-T0
           T0=T1
    3      T1=T2
         ENDIF
         U=1.0/V
         DO 4 K=1,L
    4     T1=T1*U
        ENDIF
       ENDIF
       T=F(I)
       IF (MOD(I,2) .EQ. 0) THEN
        IF(L.EQ.0) THEN
         S0=T*T0+S0
         S2=T*T2+S2
        ELSE
         S0=T*T1+S0
        ENDIF
       ELSE
        IF(L.EQ.0) THEN
         S1=T*T0+S1
         S3=T*T2+S3
        ELSE
         S1=T*T1+S1
        ENDIF
       ENDIF
    5  CONTINUE
      T=V*H
      IF (T .LE. 0.3) THEN
       T2=T*T
       B0=(T2*10.-108.)*T2+378.
       C0=(54.-T2)*T2-1512.
       IF(L.GT.0) THEN
        B=(B0*T2+1890.)/2835.
        C=(C0*T2+15120.)/11340.
       ELSE
        B0=B0*H*H/2835.
        B=B0*V2+.6666666666667
        C0=C0*H*H/11340.
        C=C0*V2+1.333333333333
       ENDIF
      ELSE
       IF (T .LT. 8.E+6) THEN
        S=SIN(T)
        C=COS(T)
        T0=C*C
       ELSE
        S=0.0
        C=0.0
        T0=0.5
       ENDIF
       T1=1.0/T
       T2=T1*T1
       B=(1.0+T0-2.0*S*C*T1)*T2*2.
       C=(S*T1-C)*T2*4.
       IF(L.EQ.0) THEN
        C0=(C-1.333333333333)/V2
        B0=(B-.6666666666667)/V2
       ENDIF
      ENDIF
      IF(L.GT.0) THEN
       FB=(B*S0+C*S1)*H
       FO=0.
      ELSE
       FO=(B*S2+C*S3)*H
       FB=((S0*2.+S1*4.)/3.+B0*S2+C0*S3)*H
      ENDIF
      RETURN
      END
      SUBROUTINE SOCC
C     -- CALCULATES THE BLUME AND WATSON CONTRIBUTIONS TO THE
C      SPIN-ORBIT PARAMETERS.
cM    IMPLICIT INTEGER*2(J,Q)
cS   C        ,INTEGER*2(I,N)                                           UCL76NOV
      INTEGER QLA,QLB,QRLP,QL,QN,QX,QCG                                 UCL76NOV
cP    REAL NINT
      DOUBLE PRECISION RLP1,DI,V1,V2,V3,W1,DM,DK,DKU,DC1,DFS,NINT,VCC,P
     C  , DKCM,ADJUST, DEY
      PARAMETER (MXD13=78*3, DKCM=109737.31)
      DIMENSION NNL(MXD13), RLP1(5500), NINT(3,2)
      COMMON MAXGR /CCLSH/NW,NNL /EX/RLP1 /OUTP/ MPRINT,MDUM(2),NDUM(3)
     C /COEFF/ P( 550000),QRLP(2,5500),IRLP,NRX( 550000),NX(523000)
     C /DBD2/ DEY(15), QCG(54, 60),QL(15),QN(15)
     C /GENINF/ ADJUST(15),SCREEN(15),MION,NZION,IDUM(6)
      COMMON /COMFAC/ DFS( 64),MT
      DATA NINT(2,1)/999./
      IF (IRLP.LE.0)  GO TO 500                                         UCL75MAR
      IF (MPRINT.GE.-2)  PRINT 180
C     RUN THROUGH ALL PAIRS OF VALENCE ELECTRON QUANTUM NUMBERS
       K0 = 0
       DO 510 LP=1,IRLP
       K1=QRLP(1,LP)
       K3=QRLP(2,LP)
       K = (K3-1)/MAXGR
       DC1 = 0.
       IF (K.GT.8) GO TO 510 !-- CASE M2
       IF (K.NE.0)  GO TO 30                                            UCL77MAR
       MQLA = QL(K1)
       QLA = MQLA/2
       DI=0.0
       V1=0.0
       V2=0.0
       V3=0.0
       J2 = -1
       MQLB = 0
       GO TO 12
C  J2 NUMBERS THE ELECTRONS IN THE CORE C0,  J2=1,2,.....NW.
 11    K2=NNL(J2)
       K4=K2
       MQLB = QL(K2)
       QLB = MQLB/2
C      CALCULATE THE DIRECT INTEGRAL, N(ABAB,LBD = 0).
       M0 = 1
       CALL RAD(K1,K2,K3,K4,0,DM,M0)
       DI = DI - ((MQLB+1)*4)*DM
       IF(MPRINT.GT.0)  PRINT 182,  J2,      K1,K2,K3,K4,  DM
       QX=QLA+QLB
       L = ABS(MQLB-MQLA)/2
       K = L-3
       IF (L.GT.0)  GO TO 165
       DC1 = 1
       L = 1
       K = -1
 165   K = K+1
       NINT(1,1)=NINT(2,1)
       NINT(2,1)=NINT(3,1)
       NINT(1,2)=NINT(2,2)
       NINT(2,2)=NINT(3,2)
C      COMPUTE N-INTEGRALS (IF M0=+1)  AND V-INTEGRALS (M0=-1)          UCL76NOV
       CALL RAD(K1,K2,K4,K3,K,DK,M0)
       DM = DK
       IF (M0*K1.EQ.K3)  GO TO 45                                       UCL77FEB
C      USE THE RELATION N(AB,BA,K) = N(BA,AB,K) IN CASE A = C.          UCL76NOV
       CALL RAD(K2,K1,K3,K4,K,DM,M0)
  45   NINT(3,2) = DM
       NINT(3,1) = DK                                                   UCL77FEB
C      NINT(J1,1) CONTAINS INTEGRALS OF THE TYPE N(AB,BC) AND NINT(J1,2)
C      CONTAINS INTEGRALS N(BA,CB). THE INDEX J1 GIVES THE ORDER OF THE
C      INTEGRAL, THUS J1=I CORRESPONDS TO ORDER K+I-3.
       IF(MPRINT.GT.0)  PRINT 183,     K,M0,               DK, DM
       M0 = -M0
       IF (K.LT.L)  GO TO 165                                           UCL76NOV
       MK = 2*K
       DK = K
       DKU = K+1
       IF (M0.GT.0)  GO TO 40                                           UCL77FEB
C      IF QLA+QLB+K IS AN ODD INTEGER THEN THE CONTRIBUTIONS FROM V1
C      AND V3 ARE ZERO.
       DC1=VCC(MQLA,MK,MQLB,0,0,0,DFS,MT)
       DM = QLA*(QLA+1)+K*(K+1)-QLB*(QLB+1)                             UCL77JAN
       W1 = -DM/(MQLA*(QLA+1))
       V1 = V1 - 6*DC1*DC1*W1*(NINT(2,1)-NINT(2,2))                     UCL77FEB
C         = V1 - 6*DC1*DC1*W1*(V(K1,K2,K4,K3,K-1)-V(K2,K1,K3,K4,K-1))   UCL77MAR
       V3 = V3 - 3*DC1*DC1*W1*((DM-MK*DKU)*(DK*NINT(3,1)-DKU*NINT(1,2)) UCL77JAN
     C                     + DM*(DK*NINT(3,2)-DKU*NINT(1,1))) / (DK*DKU)
       GO TO 101
  40   MS = QX+K
       W1=6*(MS+1)*(MS-MQLB)*(MS-MQLA)*(MS-MK+1) /(MQLA*(MQLA+2)*DK*DKU)UCL77JAN
       DC1=VCC(MQLA,MK-2,MQLB,0,0,0,DFS,MT) ! re-activated '02Mar28
       V2=V2 + DC1*DC1*W1*(NINT(2,1)+NINT(2,2))
 101   IF(MPRINT.GT.0)  PRINT 184,   DC1,W1, V1,V2,V3
       IF (K.LT.QX)  GO TO 165                                          UCL76NOV
C      ONLY NEED TO CONSIDER EACH CLOSED SHELL ONCE. INCREASE J2 BY THE
C      NUMBER OF ELECTRONS IN THE CLOSED SHELL
 12    J2=J2+2*(MQLB + 1)
       IF(J2.LT.NW) GO TO 11
C      IF ALL THE CORE ELECTRONS HAVE BEEN CONSIDERED, THE NEXT SET OF
C      EQUIVALENT ELECTRONS IN THE VALENCE SHELLS MAY BE CONSIDERED
       W1 = V1 + V2 + V3
       CALL RAD(K1,K2,K3,K4,0,DK,0)
       DC1 = 2*NZION*DK + DI + W1
       DM = 2*DKCM*DC1
       DKU = DM/NZION**4
       IF (MPRINT.GE.-2)  PRINT 181,  LP, K1,K3,  DC1, DM,DKU,  DI,W1
       GO TO 510
C  THE FOLLOWING SECTION PROVIDES FOR RELATIVISTIC RADIATIVE INTEGRALS  UCL77MAR
  30   K2 = K1-K*MAXGR
       K4 = K3-K*MAXGR
       IF (K0.NE.0)  GO TO 31                                           79/03/16
       K0 = K
C TMP  K = -K0
       IF (MPRINT.GE.-2)  PRINT 185
  31   CALL RAD(K1,K2,K3,K4,K,DC1,0)
       IF (MPRINT.GE.-0)  PRINT 181,  LP,  K1,K3, DC1
  510  RLP1(LP) = DC1
  500  RETURN
  185 FORMAT(44X,'NOW FOLLOWING ARE RADIATIVE INTEGRALS IF MPRINT.GE.0')
  184 FORMAT (19X,14H...DC1,W1,V1-3,28X,2E17.5E1/71X,3E16.5E1)          **TEST**
  183 FORMAT(20X,'..N1- OR V1-2',4X,2I4,16X,2E17.5E1,3X,2F9.5)
  182 FORMAT(/21X,6H.   DM,6X,I4,8X,4I4,E17.5E1)
  181 FORMAT(I5,3X,2I5,7X,E14.7, 1P,2E17.6, 0P,6X,2(7X,E14.6))
  180 FORMAT(//4X,40HZETA(   A    B ) = SPIN-ORBIT PARAMETERS,27X,
     * 50HBLUME AND WATSON CLOSED SHELL CONTRIBUTION, IN 2RY/31X,4H2*RY,UCL77MAR
     * 15X,4H1/CM,10X,7HZ**4/CM,10X,19HDIRECT CONTRIBUTION,4X,
     * 17HEXCHANGE CONTRIB.)
      END
      SUBROUTINE RAD(K1,K2,K3,K4,K,DK,M0)                               UCL77FEB
C     - COMPUTES MAGNETIC INTEGRALS DK=N (IF M0.GT.0) OR =V(K1K2,K3K4,K)
cM    IMPLICIT INTEGER*2(Q)
cS    INTEGER*2 JX
      INTEGER QCG,QL,QN
      DOUBLE PRECISION DK,DD,HNS, DPNL,DUY,X, DPA,DP,DH, DKU, D00, DEY
      DIMENSION DPA(0: 999),DP(0: 999),CON(8), DH(0: 999)
      COMMON /CRAD/ HNS(10),MNH(10),MJH,MAXRS, JX(15)
     C /DBD2/ DEY(15),QCG(54, 60),QL(15),QN(15)
     * /RADF/ X(0: 999),DPNL(0: 999,15),DUY(15,15)
      DATA  CON /1.33123E-5, 1.33123E-5, 1.33123E-5,   1.33123E-5,
     C         2.66246E-5,.66562E-5,2.66246E-5, 1./
      N = 1
      DD = 0.0
      D00 = 0.0
      IF (M0)  20,28,25
 20    DO 22 I=1,MAXRS
 22    DPA(I)=DPNL(I,K3)/X(I)
       CALL DIFF(DPA(1),DP(1),MNH,HNS,MJH)
       DO 21 I=1,MAXRS
 21    DPA(I)=DPNL(I,K1)*DP(I)*X(I)
       I = (QL(K1)+QL(K3))/2 + 1                                        COR76FEB
       IF (QL(K3).EQ.0)  I = I+1                                        ADD76FEB
       CALL YLAMK(K,I,DPA,DP,MNH,HNS,MJH,M0)
       DO 24 I=1,MAXRS
 24    DP(I)=DPNL(I,K2)*DPNL(I,K4)*DP(I)*X(I)
      GO TO 49
 25    DO 26 I=1,MAXRS
 26    DPA(I)=DPNL(I,K2)*DPNL(I,K4)
       I = (QL(K2)+QL(K4))/2+2
       CALL YLAMK(K,I,DPA,DP,MNH,HNS,MJH,M0)
       DO 27 I=1,MAXRS
 27    DP(I)=DP(I)*DPNL(I,K1)*DPNL(I,K3)
      GO TO 49
  28  IF (K)  13,23,30
C     CALCULATE ORDINARY SPIN-ORBIT INTEGRAL
  23  DO 29 I=1,MAXRS
  29   DP(I) = DPNL(I,K1)*DPNL(I,K3)/(X(I)*X(I)*X(I))
      GO TO 49
  13  K = ABS(K)
C     COMPUTE RADIATIVE ONE-BODY INTEGRALS
  30  N = K
      DKU = 0.0
      GO TO (34,33,32,31,35,36,37,35),N                                 UCL78NOV
   34 DO 44 I=1,MAXRS
   44 DP(I) = DPNL(I,K2)*DPNL(I,K4)/(X(I)*X(I))
      GO TO 49
   33 DO 42 I=1,MAXRS
      DPA(I) = DPNL(I,K2)/X(I)
   42 DP(I)=DPNL(I,K4)
      GO TO 39
   32 DO 40 I=1,MAXRS
      DPA(I) = DPNL(I,K2)
   40 DP(I) = DPNL(I,K4)/X(I)
      GO TO 39
  31  DO 38 I=1,MAXRS
       DH(I) = DPNL(I,K2)
  38   DP(I) = DPNL(I,K4)
      IF (QL(K2)+QL(K4).EQ.0)  D00 = DPNL(0,K2)*DPNL(0,K4)
      CALL DIFF(DH(1),DPA(1),MNH,HNS,MJH)
  39  CALL DIFF(DP(1),DH(1), MNH,HNS,MJH)
      DO 48 I=1,MAXRS
  48   DP(I) = DPA(I)*DH(I)
      GO TO 49
   35 DO 45 I=1,MAXRS
   45 DP(I)=DPNL(I,K2)*DPNL(I,K4)*X(I)*X(I)
      GO TO 49
   36 DO 46 I=1,MAXRS
   46 DP(I)=DPNL(I,K2)*DPNL(I,K4)
      GO TO 49
   37 DO 47 I=1,MAXRS
   47 DP(I) = DPNL(I,K2)*DPNL(I,K4)/X(I)
  49  DP(0) = D00
      CALL WEDDLE(DP,DKU,MNH,HNS,MJH,MAXRS)
  50  DK = DKU*CON(N)
      RETURN
      END
      SUBROUTINE DIAGFS
C
C     DIAGFS  CALCULATES LEVEL ENERGIES INCLUDING RELATIVISTIC
C      CORRECTIONS, AND PERMITTED AND FORBIDDEN RADIATIVE DATA;
C      AS AN OPTION (PARAMETER MPNCH) TERM COUPLING COEFFICIENTS
C      FOR INPUT TO SARAPH'S PROGRAM JAJOM ARE PUNCHED.
C      PARAMETER MPNCH ALSO CONTROLS THE SUBSEQUENT CALL OF SR.CASC -
C      BPRINT WILL BE SET ACCORDINGLY, SUBJECT TO ADDITIONAL SIZE CHECKS
C
cM    IMPLICIT INTEGER*2(Q)
cS   C        ,INTEGER*2(I-L,N)
      INTEGER QL,QRL,QN,QCG,QLI,QSI,QPI,QRLP,QSS, QMCL,QCUT
cS    INTEGER LAM0, LZ1,LZ2,LZZ
      LOGICAL BPRINT,BAUX,BINT,LMOD,CPRINT
      CHARACTER*4 SAR(0:5),FM997(9),SMM,XE0, LTM(0:5)*1, OGT*1,
     * FMT*121,FBO*3,FLE*24,FRE*16, FWL*8
      DOUBLE PRECISION DRK,HNS,DPNL,DU,DT,DV,DUY,X,RLP1,DEY,DRKP,DRL,
     C OSC,SJS, DS,DD1,DD2,DD,DRY,DZ9,DZ8,DDM,RAC,DSC,DD8,ECORE,DMIN,
     C ENERG,DP,DPA,DE,DFS,DNL,ADJUST,ETM,WGT,DSJ,ARR,SBO,EEE,RAM,VCC
      PARAMETER(MXD13=78*3,
cW   *          MXD25=572*MAXDK+1,
     *   LEN3=( 999+1)*(15+1)+1, LEN2= 999+2,
     *   LEN0=( 999+1)*(15+1)+15*15, MXNOR=(LEN0-1)
cP   *    /2
     *        , NXDIP= (((1225-1)*1225)/2 + 1225/2)/2)
      PARAMETER (MXA2=130, MXB2=((MXA2+1)*MXA2)/2,
     *           NXOM=(3100*(3100-1))/2, DKCM=109737.31)
      DIMENSION ENERG(3100), NNL(MXD13), MF0(10), EJJ(3100),
     C DU(572,572), ETM(1225),WGT(1225), RAM(-2:3*4+4),
     C DV(572,572), DE(572), TFU(700000), ITCC(1225),
     C NADRU(3100), DPA(0: 999), DP(0: 999), JTCC(-2:9,1225),
     C DRKP( 550000), NRKP( 550000), QRLP(2,5500), SBO(MXA2,0:3),
     C MADD(MXNOR), JORIG(3100), DNL( 5000),DSS(500000),OMG0(NXOM),
     C MSS(500000), QSS(5, 5000),NADR(523000),NJD(523000),DT( 10633),
     * X(0: 999),DPNL(0: 999,15),DUY(15,15),AP(MXNOR),
     C NAJ(3100),KORIG(3100),MMIKE( 10633),NMIKE( 10633) !OMG2(NXOM)
      COMMON MAXGR,NF, KGAP(7),MGAP, DSS,MSS,QSS,NL000,NL,IRS,IRSM,NADR 80/02/04
     C /GENINF/ ADJUST(15),DSCREE(15),MION,NZION,NPARAM,ITOL,
     C   INCLUD,JPRINT,NGROUP,IZDW  /COEFF/ DRKP,QRLP,IRLP,NRKP,NJD
     * /CRAD/ HNS(10),MNH(10),MJH,MAXRS, JX(15)
C    C /RADF/ X(0: 999),DPNL(0: 999,15),DUY(15,15)
     C /RADF/ ARR(LEN0)  /EX/ RLP1(5500)  /COMFAC/DFS( 64),MT
     C /MQVC/ MAXDC,MODPH,KCUT,QMCL,QCUT,NEL(15, 60)
     C /TERMS/ NCONFI,NSL0, NSL( 60),NFI(1225),NFK(1225),
     *   NFQ(1225),NAD(0: 61500),QPI( 60),QSI( 60),QLI( 60)
     C /DBD2/ DEY(15), QCG(54, 60),QL(15),QN(15)
     C /JSPOR/ NJO,NRR(3100),NT(  38),JJ(3100),NGR(3100)
     C /REL/ DMASS(15,15),DCD(15,15),D2LL(15,15)
     C /TRANS/ DRL( 11000),OSC(15,15),OCT(15,15),
     *   TFWE( 97000),ENR(1225), NADWE(1225),NAI(1225),NCO,
     *   IORIG(0:1225)
     * /OMEGA/ DELEN(1225,2),B2(MXB2,0:3),ML(0:MXA2),MR(0:MXA2)
     * /DXRL/ DRK( 513000), IRX,NRK( 513000), QRL(5, 11000)
     C /OUTP/ MPRINT,BPRINT,MPNCH,KDUM,LCE1,LCE2
     * /COMSD/ ASD(NXDIP),MTEC,NSD,KSD(NXDIP,2)  /CCLSH/ NW,NNL
      EQUIVALENCE (DP(1),DT(1),ETM(1)),
     C  (ARR(LEN3),DUY(1,1)), (TFWE(1),MENERG), (TFWE(2),KORIG(1)),
     C  (ARR(LEN2),DPNL(0,1)), (DPA(1),WGT(1),NMIKE(1)),
cW   C  (ARR(1),DU(1,1)), (ARR(MXD25),DV(1,1)),
     C  (ARR(1),X(0),AP(1)), (ARR(LEN0),MADD(MXNOR))
      DATA MP/7/, MAXDK/572/, MAXTR/ 10633/,
     C   MAXJU/700000/,MAXTM/1225/, MXSOI,NSMAX/5500, 5000/,
     *   SAR/'0   ','    ',' SM0','+ BP',' SM ',' SM0'/,
     C   BIG/1.E20/, MF0,MF1,MF2,MF3,MF4
CH182 FORMAT(6I4,1X,F11.5,2X,F12.6,I4,I5, (T61, 8F9.5))
CG182 FORMAT(1X,I3,5I4,1X,F11.5,F14.6,I4,I5,1X, 8F9.5/(60X, 8F9.5))
     * /4H(6I4, 4H,F12, 4H.5,F, 4H14.6, 4H,I4,, 4H   I, 4H5,(T, 4H61,8,
     *  4HF9.5, 4H))  ,         4H5,(T, 4H3,(T,         4H61,8, 4H59,7/,
C 997 FORMAT(I11,I8,F13.0,I7,3I5,F18.6)
     * FM997/'(I11',',I8,','F13.','0,I7',',3I5',',F18','.6, ',' A2,',
     *    ' I4)'/,   LTM/'S','P','D','F','G','H'/,
     *  FLE/"(9X,'E3:',1P,2I4,E19.3,3"/, FRE/",E13.2,0P,F14.2)"/
  109  FORMAT(/118H SR.DIAGFS WILL NOT COMPUTE RADIATIVE TRANSITION PROB
     CABILITIES, SEE MESSAGE PRINTED OUT IN ALGEBRAIC SECTION BY ALGEB2)
  108 FORMAT(//' SR.DIAGFS WILL NOT COMPUTE RADIATIVE TRANSITION PROBABI
     *LITIES BECAUSE IT REQUIRES',I8,10H.GT.MAXJU=,I7,14H FOR ARRAY TFU)
  110  FORMAT(//103H *****WARNING*****--- IF SR. DIAGFS HAS PUNCHED TERM
     C COUPLING COEFFICIENTS, THE SET WILL BE INCOMPLETE /105H BECAUSE N
     COT ENOUGH STORAGE WAS ALLOWED FOR STORING TRANSFORMATION COEFFICIE
     CNTS IN DIAGON: INCREASE MAXUC)
 7393 FORMAT(//' *****WARNING*****  IF SR.DIAGFS HAS PUNCHED TERM COUPLI
     *NG COEFFICIENTS ON FORT.',I2.2/20X,'THE SET WILL BE INCOMPLETE, BE
     *CAUSE  * MAXTR.GE.',I7,12H IS REQUIRED)
 7395 FORMAT(/100H NO TERM-COUPLING COEFFICIENTS CALCULATED BECAUSE OF I
     *NCORRECT CHOICE OF MODE: CHOOSE MODE = 0 OR -1)
  900 FORMAT(//9X,73HONE-BODY RELATIVISTIC CORRECTIONS TO INDIVIDUAL ORB
     1ITALS IN UNITS OF 2*RY,24X,11HIC.JPRINT =,I4/9X,27HGAM    N    L     79MAY
     2  E(NON.REL),8X,7HE(MASS),6X,6HE(DAR),7X,6HE(TOT),23X,9H<P**2/RY>)
  899 FORMAT(7X,3I5,F14.6,3X,2F12.6,F13.7,20X,F12.6)
  709 FORMAT(I7,5X,2I4, 1X,1P,2E18.3, 3X,0P,2F10.5,F13.6,F14.2,1P,E14.2)
  710 FORMAT(//' WARNING: RECOMPILE WITH > LAMAX, SEE',I5,' CB VALUES!'/
     *10X,'NO OMEGA ON A TCC FILE!') 
  600 FORMAT(//40X, 46H**** INTERMEDIATE-COUPLING RADIATIVE DATA ****//
     *4X,67H1. DATA FOR ELECTRIC DIPOLE (AND OTHER PARITY CHANGING) TRAN
     *SITIONS,7X,'LCE1 =',I2/94H NOTATION: K,KP = INITIAL AND FINAL LEVE
     *LS; AE1 = ELECTRIC DIPOLE TRANSITION PROBABILITY * SEC/
     *35H SD = ELECTRIC DIPOLE LINE STRENGTH,9X,'AE3 IN OCTOPOLE CASE, T
     *HEN  OMEGA(B)'9X,'SO'/48X,32HHIGHER MULTIPOLES: JUST "(E8.3-)
     *//15X,5HK  KP,13X,3HAE1,15X,
     *3HG*F,10X,16HF(ABS)   -F(EMI),9X,2HSD,8X,8HWAVEL/AE,6X,8H'VEL.GF')
  650 FORMAT(//' 2. DATA FOR ELECTRIC QUADRUPOLE AND MAGNETIC DIPOLE TRA
     *NSITIONS   LCE2 =',I2/ 89H NOTATION: AQUAD, AMAG = ELECTRIC QUADRU
     *POLE AND MAGNETIC DIPOLE TRANSITION PROBABILITIES/
     *' SQ, SM = ELECTRIC QUADRUPOLE AND MAGNETIC DIPOLE LINE STRENGTHS'
     *,17X,6H(QCUT=,A1,1H)//15X,5HK  KP,11X,5HAQUAD,7X,5HAMAG ,A4,7X,
     * 21HWAVEL/AE    OMEGA(BO),10X,5HSQ   ,2(8X,A4))
  742 FORMAT(43X,3H...,9X,I3,I5,15X,43HHEADING CARD FOR TERM COUPLING CO
     *EFFICIENTS/(43X,3H...,5(2I3,F9.6)))
  743 FORMAT(5X,2I5,4X,28HTCC'S BASED ON JACORD; N Z =,2I4)
cY743 FORMAT(5X,2I5,4X,28HTCC'S BASED ON NAGLIB; N Z =,2I4)
cZ743 FORMAT(5X,2I5,4X,28HTCC'S BASED ON NAGMK4; N Z =,2I4)
  744 FORMAT(8X,'-1',I5,4X,'TRANSITION AMPLITUDES',1P/(4(2I4,E12.5E1)))
  753 FORMAT((5(I3,I2,F9.6)))
  754 FORMAT(1P,(4(2I4,E12.5E1)))
  982 FORMAT(A4,26X,4I4,2X,7F9.4)
 901  FORMAT(23H PLUS CORE CONTRIBUTION,F13.4,2X,F12.5,9X,36HRELATIVISTI
     *C CORE CONTRIBUTION ALONE ,F13.5)
 980  FORMAT(/22H SR.DIAGFS:  IF MAXDK=,I7,4H.LT.,I7,19H INCREASE   * MA
     CXDK/22H *********   IF MAXJU=,I7,4H.LT.,I7,19H INCREASE   * MAXJU)80/01/18
 400  FORMAT(//'  LV   T  2J  2S  2L   P   H(ZZ)/2RY EIGEN-HBP/2RY  CF',
     *6X,48HTF-MATRIX AND HZ/2RY-TRIANGLE      E(CORE)/2RY =,2F12.5)
  488 FORMAT(43X,'TABLE CONTENTS PRINTED IF MPRINT .GE. -1')
 610  FORMAT(//7X,48HN(   A   B    C   D  2LBD') = MAGNETIC INTEGRALS )
  991 FORMAT(/60H LIST OF TERMS WITH A WEIGHTED MEAN OVER THE FINE STRUC
     *TURE        /9X,1HI,6X,2H T,8X,4HK*CM,5X,8HS L   CF,19X,22H(EI-E1)
     */RY     E1/RY =,F12.5, 8X,'TEC/RY',4X,'ITEC=',I2)
  995 FORMAT(I10,I8,F13.0,I5,I2,I5,F29.6, A2,F20.5,3X,'<---',F9.5)
  996 FORMAT(//9X,2H K,6X,2HLV,8X,4HK*CM,5X,18H2*S+1  L   2J   CF,8X,
     *'(EK-E1)/RY     T[TEC]  MTEC=',I1,8X,'(KCUT,KUTSS =',I4,2X,I2,1H))
  140 FORMAT(I5,3X,2(I5,I4),I6,F15.8)
 3449 FORMAT(/4X,'--> IF YOU REQUIRE CASCADE COEFFICICIENTS AUGMENT MAXB
     *1 SLIGHTLY (OR MAXGR IF .LT.26) SO AS TO STORE',I6,'.GT.',I7)
C
      N = 0
      M = 0
      MM = 0
      DO 928 K=1,NJO
       MJ = NT(K)
       M = MAX(MJ,M)
       MLAM = MJ*MJ
       MM = MAX(MLAM,MM)
  928  N = MLAM+N
      IF (N.GT.MAXJU) PRINT 108, N, MAXJU
      IF (M.GT.MAXDK) GO TO 990
      IF (MM.GT.MAXJU) GO TO 990
      LMOD = MODPH.EQ.0 .OR. MODPH.EQ.-1
C
C   COMPUTE MAGNETIC INTEGRALS
C
      IF (MPRINT.GE.-1)  PRINT 900,  JPRINT
      DZ9 = 0.0
      DO 612 K=1,MAXGR
       IF(DEY(K).EQ.0.) GO TO 612
       DD1 = DMASS(K,K)
       DD2 = DCD(K,K)
       DD = DD1+DD2
       L = QL(K)/2
       IF(MPRINT.GE.-1) PRINT 899, K,QN(K),L,DEY(K),DD1,DD2,DD,D2LL(K,K)
       M = NEL(K,1)
       IF (M.LE.0)  GO TO 612
       DZ9 = (DEY(K)+DD)*M + DZ9
 612   CONTINUE
      IF (NL.EQ.0)  GO TO 500
      IF (MPRINT.GE.0)  PRINT 610
      DO 599 L=1,NL
 599   DNL(L)=0.0
      NN = NL000
      DO 609 J=1,NL
       IF(DNL(J).NE.0.) GO TO 699
       M = QSS(5,J)
       MM = (M+2)/100
       BAUX = MM.EQ.7
       BINT = MOD(MM,2).EQ.0 .OR. BAUX
       M1 = (M-100*MM)/2
       IF (J-NL000-1)  499,401,402                                      80/02/04
  401  IF (MPRINT.GE.0)  PRINT 982, SAR(1)
       NN = NL
       K = 0
  402  MJ = 0
       IF (MM.LE.4)  GO TO 408
       K = 1
       MJ = 1
       GO TO 408
  499  MJ = M-197
       K=0
       IF(BINT) K=1
  408  N1=QSS(K+1,J)
       N2=QSS(K+3,J)
       M2 = (QL(N1)+QL(N2))/2+2
       IF((MM+1)/2.EQ.2) M2 = M2+1                                      80/03/17
       DO 604  I=1,MAXRS
        DD = X(I)
        IF((MM+1)/2.EQ.2) GO TO 604
        DD = 1.
        IF (.NOT.BINT)  GO TO 601
        DD = DPNL(I,N1)
        IF (MM.NE.4)  GO TO 604
  601   DD = DD/X(I)
  604   DPA(I) = DPNL(I,N2)*DD
       IF (BINT)  GO TO 607
       IF (QL(N2).GT.0)  M2 = M2-1
       CALL DIFF(DPA(1),DP(1),MNH,HNS,MJH)
       DO 608 I =1,MAXRS
  608   DPA(I) = DPNL(I,N1)*DP(I)*X(I)
  607  CALL YLAMK(M1,M2, DPA,DP, MNH,HNS,MJH, MJ)
       KX = QSS(4-K,J)
       DO 407 I=1,MAXRS
        IF (MM-2)  403,407,405
  403   IF(MM.EQ.0) GO TO 407
  404   DD = X(I)
        IF((MM+1)/2.EQ.2) DD=1/DD
        GO TO 406
  405   IF(MM.LE.4) GO TO 404
        DD = X(I)*X(I)
        IF(MM.EQ.6) GO TO 406
        IF(BAUX) DPA(I) = -DPNL(I,KX)*DP(I)*DD*DD                       80LB*0-4
        DD = DD*X(I)
  406   DP(I) = DP(I)*DD
  407   CONTINUE
       IF (.NOT.BAUX)  GO TO 410
       CALL DIFF(DPA(1),DP(1),MNH,HNS,MJH)
  410  DO 602 L=J,NN
        IF (QSS(5,L).NE.M)  GO TO 602
        IF(QSS(K+1,L).NE.N1.OR.QSS(K+3,L).NE.N2) GO TO 602
        IF (BAUX .AND. QSS(4-K,L).NE.KX)  GO TO 602
        L1 = QSS(2-K,L)
        L2 = QSS(4-K,L)
        DO 603 I=1,MAXRS
         DD = 1./X(I)
         IF(BAUX) GO TO 603
         DD = DPNL(I,L2)
  603    DPA(I) = DPNL(I,L1)*DP(I)*DD
        DPA(0) = 0.
        CALL WEDDLE(DPA,DD,MNH,HNS,MJH,MAXRS)
        DNL(L) = DD*1.33123E-5
  602   CONTINUE
  699  IF (MPRINT.GE.0)  PRINT 140,J,(QSS(I,J),I=1,5) ,DNL(J)
  609  CONTINUE
C
C
C   CONSTRUCT AND DIAGONALIZE ENERGY (SUB-)MATRICES (UNITS: 2*RYDBERGS)
C
 500  BPRINT = .TRUE.
      DD1 = 0.0
      DD8 = 0.
      DD2 = 0.
      DDM = 0.
      IF(NW.EQ.0) GO TO 526
      DO 527 L=1,NW
       KX=NNL(L)
       DD8=DD8+DCD(KX,KX)+DMASS(KX,KX)
 527   DD1=DD1+DEY(KX)
      DD1 = DD1 + DD8
C     DD1 CONTAINS ALL ONE-BODY ENERGIES I(NL) OF THE NW CORE ELECTRONS.
      IF(NAD(0).EQ.0) GO TO 526
C     NAD0 IS THE ADDRESS OF THE LAST SLATER COEFFICIENT WHEN EXPANDING
C     THE TWO-BODY COULOMB TERMS OF THE CORE.
      DO 523 I=1,NAD(0)
       M = NRK(I)
 523   DD2 = DRL(M)*DRK(I) + DD2
 526  ECORE=DD1+DD2
C
      NTCC = 0
C     SUPPLY PROLOGUE TO TCC OUTPUT FILE:
      N = 0
      DO 510 I=1,NSL0
  510  N = NSL(I)+N
      DO 511 I=1,N
  511  ITCC(I)=N+1
      DO 513 J=1,IORIG(0)
       DO 512 I=1,N
        IF(IORIG(I).NE.J) GO TO 512
        IF (KCUT.NE.0 .AND. NFK(I).GT.KCUT) GO TO 514
C       SO AS TO STOP SHORT OF EMBEDDED TERMS!
        MTCC = J
        JTCC(0,J) = I
        GO TO 513
  512   CONTINUE
  513  CONTINUE
  514 IF (MPNCH.LT.0 .AND. LMOD) THEN
       NTCC = MTCC
       WRITE(MP,'(I4,12H TERMS AMONG,I4,7H (KCUT=,I2,1H))') NTCC, N,KCUT
       DO 515 J=1,NTCC
        I = JTCC(0,J)
        K = NFQ(I)
        WRITE(MP,'(I4,3I3,1P,E14.6)')J,QSI(K)+1,QLI(K)/2,QPI(K)/2,ENR(I)
C       AND PREPARE EPILOGUE:
        ITCC(I) = J
        JTCC(-2,J) = I
        L = ABS(QLI(K)-QSI(K))
        JTCC(-1,J) = L
  515   JTCC(0,J) = (QLI(K)+QSI(K)-L)/2+1
       IF (IZDW.LT.0 .AND.
     *    NSD.GT.0) WRITE(MP,744) NSD,(KSD(I,1),KSD(I,2),ASD(I),I=1,NSD)
      ENDIF
C
      IF(MPRINT.GE.0) THEN
       PRINT 400, DD2,DD1
       MF0(7) = MF1
       MF0(8) = MF3
      ELSE
       PRINT 400, ECORE
       MF0(7) = MF2
       MF0(8) = MF4
       IF(MPRINT.LT.-1) PRINT 488
      ENDIF
C
C
      ITECO = MTEC
  701 ITECO=ITECO-1
      CPRINT = ABS(MPNCH).EQ.1 .OR. ABS(MPNCH).GE.3
C     THE FOLLOWING DO LOOP RUNS THROUGH ALL THE NJO GROUPS, WHILST DO
C     522 RUNS THROUGH ALL THE NCJ LEVELS OF THE K'TH GROUP (J,P).
      DMIN=0.
      NEND=0
      NCI=0
      M=0
      NTRAN=0
      MJ = 0
      K2 = 0
      N2 = 0
      BAUX = .FALSE.
      DO 528 K=1,NJO
       NCJ = NT(K)
       MLAM = NCJ*NCJ
       BINT = MLAM+M.LE.MAXJU
C      IF (MLAM.GT.MAXJU)  GO TO 990
C      IF(NCJ.GT.MAXDK) GO TO 990
       MJ = MAX(MJ,MLAM+NTRAN)
       DO 522 I=1,NCJ
        J=I+NCI
        IT=NRR(J)
        NAJ(J)=I
        NN = M
        IF(.NOT.BINT) NN = (I-1)*NCJ
        NADRU(J)=NN
        M=M+NCJ
        IP=NFQ(IT)
        DO 524 J=1,I
         DD = 0.0
         L=J+NCI
         ITP=NRR(L)
         K1 = K2+1
         N1 = N2+1
         NEND = NEND+1
         K2 = NADR(NEND)
         N2 = NJD(NEND)
         IF(N1.GT.N2) GO TO 590
         DO 519 L=N1,N2
          KX=NRKP(L)
 519      DD = RLP1(KX)*DRKP(L) + DD
 590     IF(K1.GT.K2) GO TO 518
         DO 625 L=K1,K2
          KX = MSS(L)
 625      DD = DNL(KX)*DSS(L)+DD
 518     IF (NFQ(ITP).NE.IP)  GO TO 520
CP:      IA AND DO 593 CONTROL TERM ENERGY CORRECTION, reactivated'02Jun
         IA = 0
         IB = 0
         IAB = 0
         DO 592 L=1,NSL0
          II=NSL(L)
          IF(L.EQ.IP) GO TO 591
          IAB = IAB+II
          IA=II*II+IA
  592     IB=((II+1)*II)/2+IB
  591    L1 = IT-IAB
         L2 = ITP-IAB
         IB = (L1*(L1-1))/2+L2 + IB
         DO 593 L=1,II
          DD = DELEN(L+IAB,1)*TFWE(IA+L1)*TFWE(IA+L2)/2. + DD
CP             DELEN MAY BE ENERGY CORRECTION IN RYDBERGS TO TERMS
CP               WITH INDEX T FROM THE TERM TABLES (NOT ENERGY ORDER)
          L1 = II+L1
  593     L2 = II+L2
         M1=NAD(IB-1)+1
         M2=NAD(IB)
         IF(M1.GT.M2) GO TO 520
         DO 521 L=M1,M2
          KX=NRK(L)
          DRY=DRL(KX)
          IF(QRL(5,KX).GE.0) GO TO 521
          IF(IZDW.LT.0) GO TO 521
          L1=QRL(1,KX)
          L2=QRL(3,KX)
          DRY=DRY+DCD(L1,L2)+DMASS(L1,L2)
  521     DD = DRK(L)*DRY + DD
  520    TFU(J+NN) = DD
         DU(I,J) = DD
  524    DU(J,I) = DD
C       THE ABOVE TWO STATEMENTS EXPRESS THE SYMMETRY OF THE H-MATRIX
C       THE LOOP 'DO 519' IS SIMILAR TO THE LOOP 'DO 521', BUT IT ADDS
C       PRODUCTS GIVING RISE TO THE SPIN-ORBIT CONTRIBUTION TO THE M.E.
        DE(I)=0.
        J = NFK(IT)
        DO 529  L=1,MAXGR
         IP = NEL(L,J)-NEL(L,1)
         IF (IP.EQ.0)  GO TO 529
         DE(I) = (DMASS(L,L)+DCD(L,L)+DEY(L))*IP + DE(I)                UCL75FEB
  529    CONTINUE
  522   DU(I,I)=DU(I,I)+DE(I)
C      DIAGONALISE THE H-MATRIX USING JACORD. IF THE SECOND ARGUMENT
C      OF JACORD = .TRUE., THE TRANSFORMATION MATRIX IS OBTAINED AS
C      OUTPUT IN ARRAY DV.  ALSO IF NCJ IS REPLACED BY -NCJ, THE EIGEN-
C      VALUES ARE NOT RE-ORDERED IN DESCENDING ORDER.
       NCJ=-NCJ
       CALL JACORD( NCJ,.TRUE. ,DU,DV,MAXDK)
C           ====== DIAGONALIZES THE H-MATRIX
C
       DO 525 I=1,NCJ
        J=I+NCI
C       J IS THE ARRAY INDEX OF THE WHOLE H-MATRIX, WHEREAS
C       I IS THE POSITION IN THE APPROPRIATE SUBMATRIX
        ENERG(J)=DU(I,I)
        DDM = MAX(ENERG(J),DDM)
        JORIG(J) = J
        DO 60  L=1,J
         IF (L.EQ.J)  GO TO 60
         IA = J-L
         II = JORIG(IA)
         IF (ENERG(J).GT.ENERG(II))  GO TO 60
         JORIG(IA+1) = II
         JORIG(IA) = J
  60     CONTINUE
        II=NADRU(J)
        M1 = II+1
        M2 = II+I
        IT = NRR(J)
        IP = NFQ(IT)
C       PRINT ENERGY LEVELS, TRANSFORMATION MATRICES AND H-SUBMATRICES. UCL75FEB
        DD = DE(I)+DZ9
        DS = ENERG(J)+DZ9
        IF (JPRINT.NE.3 .AND. MPRINT.GE.-1)
     *      PRINT MF0, J, IT,JJ(J),QSI(IP),QLI(IP),QPI(IP),
     *             DD,DS, NFK(IT), I,(DV(L,I),L=1,NCJ), (TFU(L),L=M1,M2)UCL75FEB
C       STORE TRANSFORMATION MATRIX IN TFU:
        DO 730 L=1,NCJ
 730     TFU(L+II) = DV(L,I)
        IF (ITECO.GT.0) GO TO 525 ! while iterating TEC
C
C       CALCULATE 'TERM-COUPLING COEFFICIENTS' FOR TRANSFORMING LS-
C       COUPLING CONFIGURATION-MIXING R-MATRICES TO INTERMEDIATE
C       COUPLING R-MATRICES: IN THIS SECTION CARDS F1 AND F2, REQUIRED
C       AS INPUT TO SARAPH'S PROGRAM 'JAJOM', ARE PUNCHED -- SEE MPNCH
C       (REF. H.E.SARAPH, COMPUTER PHYS. COMMUN. 3(1972)256-68).
        IF (.NOT.LMOD)  GO TO 525
C       IF LMOD = .FALSE. PHASES OF TERM-COUPLING COEFFICIENTS MAY NOT BE
C       CONSISTENT WITH R-MATRIX DATA PRODUCED BY DISTORTED WAVE PROGRAM
C       OF W. EISSNER.
         DO 739 IB=1,NCJ
          IP = NRR(IB+NCI)
          IF (IP.NE.1 .AND. NADWE(IP).EQ.0)  BAUX = .TRUE.
          IF(BAUX) GO TO 739
          M1 = IORIG(IP)
          M2 = IORIG(IT)
         IF (M2.GT.MTCC .OR. M1.GT.MTCC) GO TO 739
         DS=0.
         DO 731 L=1,NCJ
          ITP=NRR(L+NCI)
          IF(NFQ(ITP).NE.NFQ(IP)) GO TO 731
           NN = NADWE(IP)+NAI(ITP)
           DS = DS+TFU(II+L)*TFWE(NN)
 731      CONTINUE
         IF(ABS(DS).LE.1.E-9) GO TO 739
         NTRAN=NTRAN+1
         IF (NTRAN.GT.MAXTR)  GO TO 739
         DT(NTRAN)=DS
         MMIKE(NTRAN) = M1
         NMIKE(NTRAN) = M2
 739     CONTINUE
 525    CONTINUE
       IF (ITECO.GT.0) GO TO 528 ! while iterating TEC
       IF (BAUX)  GO TO 528
       IF (K.EQ.NJO)  GO TO 670
       IF (JJ(J+1).EQ.JJ(J))  GO TO 528
 670   IF (.NOT.CPRINT .OR. .NOT.LMOD)  GO TO 111
       IF (NTRAN.GT.MAXTR)  GO TO 111
       PRINT 742, JJ(J),NTRAN, (MMIKE(L),NMIKE(L),DT(L),L=1,NTRAN)
       IF (MPNCH.GE.0)  GO TO 111
        WRITE(MP,743) JJ(J),NTRAN,MION,IZDW
        IF (NTCC.LE.99 .AND. MPNCH.GT.-4) THEN
         WRITE(MP,753) (MMIKE(L),NMIKE(L),DT(L),L=1,NTRAN)
        ELSE
C        SWITCH TO FORMAT 754 IF 753 CANNOT HOLD PLACES:
         WRITE(MP,754) (MMIKE(L),NMIKE(L),DT(L),L=1,NTRAN)
        ENDIF  
 111   NTRAN=0
 528   NCI = NCJ + NCI
      NENERG = NCI
      IF (ITECO.GT.0) GO TO 702 ! while iterating TEC
      PRINT 901,  DD1,ECORE, DD8
      IF (BAUX)  PRINT 110
      IF (MJ.GT.MAXTR)  PRINT 7393, MP, MJ
      IF (.NOT.LMOD .AND. CPRINT)  PRINT 7395
      PRINT 996, MTEC, KCUT,QMCL
  702 BAUX = JPRINT.EQ.1 .OR. JPRINT.GT.4
C      .FALSE.  THROWS OUT TRANSITIONS INVOLVING CORRELATION LEVELS
      DO 70 I=1,MAXTM
       WGT(I) = 0.0
   70  ETM(I) = 0.0
      M2 = 0
      II = JORIG(1)
      DSJ = ENERG(II)
      FM997(7) = '.6, '
      IF(DDM-DSJ.LT.50.) FM997(7) = '.7, '
      IF(DDM-DSJ.LT.5.) FM997(7) = '.8, '
      DO 80 J=1,NENERG
       I = JORIG(J)
       M1 = NRR(I)
       M2 = MAX(M1,M2)
       DS = JJ(I)+1
       WGT(M1) = WGT(M1) + DS
       ENERG(I) = ENERG(I)-DSJ
       DRY=ENERG(I)*2.
       IF(ITECO.GT.0) GO TO 80
        L = ITCC(M1)
        IF (L.LE.NTCC) THEN
         K = (JJ(I)-JTCC(-1,L))/2+1
         JTCC(K,L) = J
         EJJ(J) = DRY
        ENDIF
        L = 0
        IF(DELEN(M1,1).NE.0.) L = 1
        II = NFQ(M1)
        IF (NFK(M1)*KCUT.LE.KCUT*KCUT) GO TO 75
        IF (BAUX)  GO TO 75
        JORIG(J) = -I
   75   PRINT FM997,  J,I, DRY*DKCM,
     *    QSI(II)+1,QLI(II)/2,JJ(I), NFK(M1), DRY, (' <',M1,K=1,L)
   80  ETM(M1) = DRY*DS + ETM(M1)
C
C     FORM WEIGHTED MEAN OF FS-LEVELS TO YIELD TERM ENERGIES -- UCL75FEB
      DMIN = BIG
      DO 30  I=1,M2
       ETM(I) = ETM(I)/WGT(I)
       IF (DMIN.GT.ETM(I))  DMIN = ETM(I)
   30  CONTINUE
      IF (ITECO.LE.0) PRINT 991,  (ECORE+DSJ+DZ9)*2. + DMIN,  ITECO
      DO 50 I=1,M2
       DD = BIG
       DO 40 II=1,M2
        IF (ETM(II).GE.DD)  GO TO 40
        IT = II
        DD = ETM(II)
   40   CONTINUE
       DRY = DD-DMIN
       IF (ITECO.GT.0) THEN
       IF(DELEN(IT,2).NE.0.) DELEN(IT,1) = DELEN(IT,2)-DRY + DELEN(IT,1)
       GO TO 50 ! inactivate to follow convergence
       ENDIF
       L = 0
       IF(DELEN(IT,1).NE.0.) L=1
       II = NFQ(IT)
       PRINT 995, I,IT, DRY*DKCM, (1-QPI(II))*(QSI(II)+1), QLI(II)/2,
     *        NFK(IT),  DRY, (' <',DELEN(IT,2),DELEN(IT,1),J=1,L)
   50  ETM(IT) = BIG
C
      IF (ITECO.GT.0) GO TO 701 ! for more TEC iterations
C
C     APPEND 'LIST' TO TCC OUTPUT FILE
      IF (NTCC.GT.0) THEN
       WRITE(MP,"(9X,'0    0',5X,'TCC END')")
       IF(IZDW.LT.0) THEN
        DO 85 L=1,NTCC
         I = NFQ(JTCC(-2,L))
         II = (1-QPI(I))*(QSI(I)+1)
   85    WRITE(MP,"(I12,I5,6X,'C',I2.2,I3,A1/(3(F4.1,F11.6,I3)))")
     *        L, JTCC(0,L),         NFK(JTCC(-2,L)), II,LTM(QLI(I)/2),
     *    (REAL(JTCC(-1,L)+2*K-2)/2.,EJJ(JTCC(K,L)),
     *                                   JTCC(K,L),K=1,JTCC(0,L))
        ENDIF
       WRITE(MP,"(' END',7X,'0    0')")
      ENDIF
C
C
C     CALCULATE RADIATIVE DATA
C
      IF(.NOT.BINT) GO TO 106
      IF(NAD(NCO+1).LE.0) GO TO 105
      CPRINT = JPRINT.EQ.2 .OR. JPRINT.GT.4 .OR. MPRINT.GT.2
      PRINT 600, LCE1
      MPAR = 2
      NTRAN = 0
      IF(LCE1.GE.0) GO TO 662
  737  IF(LCE2.LT.-1) GO TO 799
       II = 1
       IP = 2
       IF (NJD(NEND+1).LT.0) GO TO 740
        II = 3
        IP = 5
  740  PRINT 650, LCE2, QCUT, (SAR(I),I=II,IP)
       NBOL = 0
       MPAR = 0
  662 IOS = 0
      DO 732 IAB=2,NENERG
       IW = JORIG(IAB)
       IF (IW.LE.0)  GO TO 732
       IT = NRR(IW)
       IQ = NFQ(IT)
       IP = QPI(IQ)
       MQJ = JJ(IW)
       DZ9 = REAL(MQJ+1)
       NN = NGR(IW)
       K1=IW-NAJ(IW)+1
       K2=K1+NT(NN)-1
       DO 733 JAB=1,IAB-1
        JW = JORIG(JAB)
        IF (JW.LE.0)  GO TO 733
        ITP = NRR(JW)
        JQ = NFQ(ITP)
        M = QPI(JQ)-IP
        IF (ABS(M).NE.MPAR) GO TO 733
        IOM = ((IAB-2)*(IAB-1))/2+JAB
        OMG0(IOM)=0.
C arC   OMG2(IOM)=0.
        K = LCE1
        IF(M.EQ.0) K = LCE2
        IF (K.GT.0 .AND. MAX(NFK(IT),NFK(ITP)).GT.K) GO TO 733
        EEE = (ENERG(IW)-ENERG(JW))*2.
        IF (EEE.LT..001) GO TO 733 !   QUB88FEB/2000MAY27
        OGT = ' '
        MQJP = JJ(JW)
        DZ8 = MQJP+1
        DSJ = SQRT(DZ8*DZ9)
        NN = NGR(JW)
        L1=JW-NAJ(JW)+1
        L2=L1+NT(NN)-1
        DO 796 L=0,MR(0)
         DO 796 K=1,ML(0)
  796     SBO(K,L) = 0.
        FBO = '3E1'
        BORN=0.
        SE3=0.
        SM2=0.
        DDM=0.
        DD=0.
        DMIN = 0.0
        ECORE = 0.0
        SMM = SAR(0)
        XE0 = '    '
        IF (JQ.EQ.IQ .AND. MQJP.EQ.MQJ) XE0 = '(E0)'
        DO 734 K=K1,K2
         KSL=NRR(K)
         IA=NFQ(KSL)
         MQS=QSI(IA)
         MQL=QLI(IA)
         M = NADRU(IW)+NAJ(K)
         DD1 = TFU(M)
         IF (ABS(DD1).LT.1.E-8)  GO TO 734
         DO 735 L=L1,L2
          M = NADRU(JW)+NAJ(L)
          DD2 = TFU(M)
          IF (ABS(DD2).LT.1.E-8)  GO TO 735
          LSL=NRR(L)
          IB=NFQ(LSL)
          MQLP=QLI(IB)
          M=KSL+NCO
          DS=1.0
          BINT = LSL.LE.KSL
          IF(BINT) GO TO 791
          M=LSL+NCO
          DS = (-1)**((MQL-MQLP)/2)
 791      N1=NAD(M-1)+1
          N2=NAD(M)
          IF(N2.LT.N1) GO TO 450
C
C         FIND LAMBDA OF RME DRK FROM ALGEB2 (THE LOWEST UNLESS E2):
          LAM0 = -MPAR
          IF (MQLP+MQL.EQ.0 .AND. LAM0.EQ.0) GO TO 26
   12      LAM0 = LAM0+4
           IF (ABS(MQLP-MQL).GT.LAM0) GO TO 12
   26     MLAM = LAM0
  792     IF (MQJ+MQJP.LT.MLAM) GO TO 450
          IF (ABS(MQJ-MQJP).LE.MLAM) GO TO 798
           MLAM = MLAM+4
           GO TO 792
  798     M=(3+1)*4
  797      RAM(M) = SJS(MQL,MQJ,MQS,MQJP,MQLP,M+MPAR,DFS,MT)*DSJ*
     C           (1-MOD(MQS+MQL+MQJP+MLAM,4))
           M=M-4
           IF(M.ge.0) GO TO 797
          RAC = RAM(4-2*MPAR)
          DO 736  M=N1,N2
           M1 = NRK(M)/MAXGR**2
           M2 = M1+1
           IF(BINT.AND.M2.NE.LSL) GO TO 736
           IF(.NOT.BINT.AND.M2.NE.KSL) GO TO 736
           DRY = DD1*DD2*DRK(M)*DS
           M1 = (NRK(M)-M1*MAXGR*MAXGR)/MAXGR + 1
           MJ = NRK(M) - ((M2-1)*MAXGR+M1-1)*MAXGR + 1 ! VEL74JUL
           M2 = MIN(M1,MJ)
           M1 = M1+MJ - M2
           LZ1 = QL(M1)
           LZ2 = QL(M2)
           IF (ML(0).EQ.0) GO TO 755
            DO 757 I=1,ML(0)
             IF(ML(I).NE.M1) GO TO 757
             IF(MR(I).NE.M2) GO TO 757
             DO 756 LZZ=0,3*4+4,4
  756         RAM(LZZ-2) = VCC(LZ1,LZZ+MPAR,LZ2, 0,0,0, DFS,MT)
             DD8 = DRY/RAM(LAM0-MPAR-2)
             DO 777 LZZ=0,MR(0)*4,4
  777         SBO(I,LZZ/4) = DD8*RAM(LZZ-2)*RAM(LZZ) + SBO(I,LZZ/4)
             IF (RAM(3*4+2)*RAM(3*4+4).NE.0.) THEN
               OGT='>'
               NTCC=0 ! on fort.7 suppressing incomplete Born data
             ENDIF
             IF(MLAM.EQ.6) SE3 = OCT(M2,M1)*RAM(4)*DRY + SE3
             GO TO 755
  757        CONTINUE
C           print *,' ERROR: no M1,M2=',m1,m2,   ':  IAB,JAB =',iab,jab
C           print *,'        MQL,MQLP=',mql,mqlp,',   M, MQS =',m,mqs
            STOP " DIAGFS: no Born M1,M2"
  755      IF (MLAM.NE.4-MPAR) GO TO 736
            DD = OSC(M1,M2)*RAC*DRY + DD
            IF (MPAR.NE.0) THEN
             DSC = OSC(M2,M1)
             IF(MJ.NE.M1) DSC = -DSC
             IF(.NOT.BINT) DSC = -DSC
             ECORE = DSC*RAC*DRY + ECORE ! for E1vel
            ENDIF
            IF (CPRINT) THEN
             PRINT 982, SMM,K,L,KSL,LSL, DD1,DD2,DSC,DRK(M),RAC,DD,ECORE
             SMM = SAR(1)
            ENDIF
  736      CONTINUE
C 450     IF(QPI(II).NE.IP) GO TO 735 -- BEFORE BP E1VEL TERMS INSERTED TMP77SEP
C
  450     IF (MQJ+MQJP.EQ.0) GO TO 735
          IF (ABS(MQJ-MQJP).GT.2+MPAR) GO TO 735
          M = NEND+K
          NN = L
          DS = 1
          IF (L.LE.K)  GO TO 435
          M = NEND+L
          NN = K
          DS = 1-MOD(ABS(MQJ-MQJP),4)
  435     DD8 = DD1*DD2*DS
          IF (NADR(NEND+1).LE.0)  GO TO 430
          N1 = NADR(M-1)+1
          N2 = NADR(M)
          IF (N2.LT.N1)  GO TO 430
          DO 426 MJ=N1,N2
           M1 = (MSS(MJ)-1)/NSMAX
           IF (M1+1.NE.NN)  GO TO 426
           M2 = MSS(MJ)-M1*NSMAX
           DDM = DNL(M2)*DSS(MJ)*DD8 + DDM
  426      CONTINUE
  430     IF (NJD(NEND+1).LT.0) GO TO 440                               UCL79NOV
          N1 = NJD(M-1)+1
          N2 = NJD(M)
          IF (N2.LT.N1)  GO TO 735
C.TST     PRINT "('  REL M1, TEST: ',3I3,5X,2I4,2(0PF12.5,1PE15.4))"
C    *       NN, K,L, N1,N2, EEE,DD8
          DO 436 M=N1,N2
           M1 = (NRKP(M)-1)/MXSOI
           IF (M1+1.NE.NN)  GO TO 436
           MJ = NRKP(M)-M1*MXSOI
           M2 = QRLP(1,MJ)
           KX = (M2-1)/MAXGR
           M1 = M2 - KX*MAXGR
           M2 = QRLP(2,MJ) - KX*MAXGR
           IF(KX.EQ.9) THEN ! -- case M2 (magnetic quadrupole):
            KX=MIN(M1,M2)
            DSC = OSC(M1+M2-KX,KX)
            SM2 = DRKP(M)*DD1*DD2*DSC + SM2
            GO TO 436
           ENDIF
           DSC = RLP1(MJ)
           IF (KX-7)  433,432,431
  431      DSC = (-D2LL(M1,M2)-DSC*EEE*EEE/20) * 2.66246E-5             79 ? OCT
           IF (M2.NE.M1)  GO TO 434
           DSC = DSC+1
           DMIN = DD8*DRKP(M) + DMIN                                    79/03/22
           GO TO 434
C 432      DSC = NZION*DSC
  432      DSC = -NZION*DSC
           GO TO 434
  433      IF (KX-5)  434,437,438
C 437      DSC = EEE*DSC
C 438      DSC = EEE*DSC
  437      DSC = EEE*EEE*DSC/20
           GO TO 434
  438      DSC = EEE*DSC - D2LL(M1,M2)*1.33123E-5
  434      RAC = DD8*DRKP(M)*DSC
           IF (MPAR.EQ.0)  GO TO 444
C          RELATIVISTIC CONTRIBUTION TO VELOCITY AMPLITUDE OF E1        82/08/04
           ECORE = 2*NZION*RAC/EEE + ECORE
           GO TO 436
  444      DDM = RAC + DDM
C.TST      PRINT 123, KX,M1,M2, M,MJ, DRKP(M),DSC,DS, DDM
  436      CONTINUE
          GO TO 735
  440     IF (KSL.NE.LSL)  GO TO 735
          IF (ABS(MQJ-MQJP)-2)  452,451,735
  452     MJ = (MQJ+2)*MQJ
          DSC = (MQS+2)*MQS-(MQL+2)*MQL+3*MJ
          DD8 = (MQJ+1)*MJ
          GO TO 738
  451     MJ = MAX(MQJ,MQJP)
      DD8=((MJ-MQS+MQL)*(MJ+MQS-MQL)*MJ*(MJ+MQS+MQL+2)*(MQS+MQL+2-MJ))/2
          DSC=1
  738     DDM = DD1*DD2*DSC* SQRT(DD8)/(4*MJ) + DDM                     UCL76SEP
  735     CONTINUE
  734    CONTINUE
C
         M = 0
         DO 795 L=1,ML(0)
C OSC     DT(L) = OSC(ML(L),MR(L)) 
          DO 794 K=1,L
           M = M+1
C OSC      DS = SBO(K)*SBO(L) * DT(K)*DT(L)
           DS = 0.
           DO 793 N=0,MR(0)
  793       DS = SBO(K,N)*SBO(L,N) * B2(M,N) * (N*4+MPAR+1) + DS
c IAB      if(MQJP.EQ.MQJ .and. SBO(K,0)*SBO(L,0).ne.0.) PRINT"('  IAB',
c JAB*     'JAB,TEST: ',(2I4,1P,E15.4,2I5))",IAB,JAB,B2(M,0),ML(K),MR(L)
  794      BORN = DS+DS + BORN
  795     BORN = BORN - DS
         BORN = BORN*8.
C        BUT FOR OSC TEST SET
C OSC    BORN = (BORN+BORN)/3.
         IF(BORN.GT.0.) THEN
C arC     OMG2(IOM)= BORN
          OMG0(IOM)= BORN ! '02Aug2: no longer minus tagged
          if(BORN.lt.1.0E-9) FBO='2  ' !'04Jan27
          IF(OGT.NE.' ') NBOL=NBOL+1
         ENDIF
        DD2 = EEE*EEE*EEE/DZ9
        DRY = 1.E08/(EEE*DKCM)
        FWL = '0P,F14.2'
        IF(DRY.LT.10.) FWL = '0P,F14.3'
        IF (DD.EQ.0.0 .AND. DDM.EQ.0.0 .AND. MPRINT.GE.-2) THEN
         DS = SM2*EEE
         DSC = DS*DS*DD2*2.37268E-2
         IF (BORN.NE.0.0 .OR. OGT.EQ.'>') THEN
          IF(SE3.NE.0.) THEN
           DS = SE3*EEE*EEE
           DD1 = DS*DS*DD2*6.0252E-4
           IF(SM2.EQ.0.) THEN
            FMT = FLE//'2X,A1,E8.'//FBO//FRE
            PRINT FMT,  IAB,JAB, DD1, OGT,BORN, ABS(SE3)*SE3,DRY
           ELSE
C           PRINT "(9X,'E3:',1P,2I4,E19.3,3X,'AM2 =',E10.3,'  S=',
C    *       0P,F9.5,1X,A1,1P,E8.3E1, E13.2,0P,F14.2)":
        FMT=FLE//"X,'AM2 =',E10.3,'  S=',0P,F9.5,1X,A1,1P,E8."//FBO//FRE
        PRINT FMT,IAB,JAB,DD1,DSC,ABS(SM2)*SM2,OGT,BORN,ABS(SE3)*SE3,DRY
           ENDIF
          ELSE
           FMT = '(9X,1HE,I1,1H:,2I4,50X,A1,1P,E9.'//FBO//')'
           PRINT FMT, MLAM/2,IAB,JAB,OGT,BORN
          ENDIF
         ELSE IF(SM2.NE.0.) THEN ! just magnetic quadrupole
           WRITE(6,"(12X,2I4,22X,'AM2 =',1P,E10.3,0P,'  S=',F9.5,
     *      23X,F14.2)") IAB,JAB, DSC,ABS(SM2)*SM2, DRY
         ENDIF
         GO TO 733
        ENDIF
        IOS = IOS + 1
        DSC = ABS(DD)*DD
        DD = DD*DD
        IF (MPAR.EQ.0) THEN
         DS =  ABS(DMIN)*DMIN
         RAC = DDM*DDM
         DMIN = ABS(DDM)*DDM
         DDM = RAC*DD2 * 3.5644E04
         DD2 = 1.78218E03 * DD2 * DD * EEE*EEE
         IF (DD2.LT.1.E-9 .AND. DDM.LT.1.E-12 .and. MPRINT.lt.-2 !  "
     *                    .AND. BORN.LT.1.E-6) GO TO 733 !'04Jan27: sic!
         DD8 = 2.*DSC/3.
         IF(MLAM.EQ.0) XE0=' E0:'
C        PRINT ELECTRIC QUADRUPOLE AND MAGNETIC DIPOLE DATA
         PRINT '(I7,1X,A4,2I4,4X,1P,2E14.3,1X'//FWL//
     *    ',3X,A1,1P,E9.'//FBO//',1X,2E14.3,E12.3)',
     *      IOS,XE0,IAB,JAB, DD2,DDM, DRY, OGT,BORN, DD8,DMIN,DS
        ELSE
         RAC = EEE*DD/3.
         DD = DD*DD2*2.6774E09
         OMG0(IOM) = -4.*ABS(DSC)/3. ! '02Aug2: now minus tagged
         IF (DD.LT.1.E-2)  GO TO 733
         DS = ECORE*ECORE/(3.*EEE)
         NTRAN = NTRAN+1
         DD1 = RAC/DZ8
         DD2 = RAC/DZ9
C        PRINT ELECTRIC DIPOLE DATA
         PRINT '(I7,5X,2I4,1X,1P,2E18.3,3X,0P,2F10.5,F13.6,'//FWL//
     *    ',1P,E14.2)', IOS,IAB,JAB,   DD, RAC, DD1,DD2, DSC,DRY,  DS
         IF (MPRINT.GT.-2.AND.BORN.NE.0.) ! add octopole stuff
     *    PRINT "(71X,1H"//OGT//",1P,E8."//FBO//")", BORN
         IF (NTRAN.GE.MXNOR)  GO TO 733
C        SET UP ARRAY CONTAINING DIPOLE TRANSITION PROBABILITIES
C        FOR USE
C        BY CASC
         AP(NTRAN) = DD
         MADD(NTRAN) = (IAB-1)*NENERG + JAB-1
        ENDIF
 733    CONTINUE
 732   CONTINUE
      IF (MPAR.NE.0) GO TO 737
      IF (NBOL.NE.0) print 710, NBOL
      IF(NTCC.GT.0) THEN
         WRITE(7,"(/4X,'00',5X,1P,(T12,6E11.3))") (OMG0(I),I=1,IOM)
C arC    WRITE(7,"(/4X,'-2',5X,1P,(T12,6E11.3))") (OMG2(I),I=1,IOM)
      ENDIF
  799 IF (NTRAN.EQ.0)  GO TO 750
C     CHECK TO SEE IF SIZE OF ARRAYS MADD AND AP HAS BEEN EXCEEDED
      IF (NTRAN.GE.MXNOR)  GO TO 725
      IF (ABS(MPNCH)/2.NE.1)  GO TO 750
      BPRINT = .FALSE.
      DO 615 J=1,NENERG
  615  KORIG(J) = JORIG(J)
      MENERG = NENERG
      MADD(MXNOR) = NTRAN
      GO TO 750
  725 PRINT 3449, NTRAN,MXNOR
      GO TO 750
C
  105 PRINT 109
      IF(BINT) GO TO 750
  106 PRINT 108, M, MAXJU
      GO TO 750
  990 PRINT 980, MAXDK,M, MAXJU,MM
  750 RETURN
      END
cP    REAL FUNCTION SJS(J1,J2,J3,L1,L2,L3,FCT,MFD)
      DOUBLE PRECISION  FUNCTION SJS(J1,J2,J3,L1,L2,L3,FCT,MFD)
C     NORDITA1966(F.P.L.4) WITH MODIFICATIONS UCL'72MAR20,DL'82JUL28W.E.
C     THE SIX QUANTUM NUMBER ARGUMENTS HAVE TWICE THEIR PHYSICAL VALUE;
C     FACTORIALS MUST BE SUPPLIED BY FCT(I)=(I/2-1)!/16**(I/2-1),I=4,M,2   82JUL
C     (FCT(2)=0!=1), AND PHASE FACTORS BY FCT(I)=MOD(I+1,4)-1,I=1,MFD,2.
      DOUBLE PRECISION  FCT, OMEGA
      DIMENSION FCT(MFD)
      OMEGA = 0.0
      IF (J1+J2.LT.J3)  GO TO 700
      IF (J1+L2.LT.L3)  GO TO 700
      IF (J2+L3.LT.L1)  GO TO 700
      IF (J3+L1.LT.L2)  GO TO 700
      IF (ABS(J1-J2).GT.J3)  GO TO 700
      IF (ABS(J1-L2).GT.L3)  GO TO 700
      IF (ABS(J2-L3).GT.L1)  GO TO 700
      IF (ABS(J3-L1).GT.L2)  GO TO 700
      IJ0 = J1 + J2 + J3 + 2
      IJ1 = J1 + L2 + L3 + 2
      IJ2 = L1 + J2 + L3 + 2
      IJ3 = L1 + L2 + J3 + 2
C     IF (MOD(IJ0,2)+MOD(IJ1,2)+MOD(IJ2,2)+MOD(IJ3,2).NE.0) GO TO 700   ***82JUL
      IWMIN = MAX(IJ0,IJ1,IJ2,IJ3)+2
      ID1 = IJ0 + IJ1 - J1-J1 + 2
      ID2 = IJ0 + IJ2 - J2-J2 + 2
      ID3 = IJ0 + IJ3 - J3-J3 + 2
      IWMAX = MIN(ID1,ID2,ID3)-2
      IF (IWMAX.LT.IWMIN)  GO TO 700
      IF (IWMAX.GT.MFD)  GO TO 702
      DO 701 IW=IWMIN,IWMAX,2
  701  OMEGA = -FCT(IW-1)*FCT(IW)/(FCT(ID1-IW)*FCT(ID2-IW)*FCT(ID3-IW)* ***82JUL
     *          FCT(IW-IJ0)*FCT(IW-IJ1)*FCT(IW-IJ2)*FCT(IW-IJ3)) + OMEGA
      IJ0 = IJ0+2
      IJ1 = IJ1+2
      IJ2 = IJ2+2
      IJ3 = IJ3+2
      OMEGA = OMEGA * SQRT(
     C     (FCT(ID1-IJ0)*FCT(ID2-IJ0)*FCT(ID3-IJ0)/FCT(IJ0))*
     C     (FCT(ID1-IJ1)*FCT(ID2-IJ1)*FCT(ID3-IJ1)/FCT(IJ1))*
     C     (FCT(ID1-IJ2)*FCT(ID2-IJ2)*FCT(ID3-IJ2)/FCT(IJ2))*
     C     (FCT(ID1-IJ3)*FCT(ID2-IJ3)*FCT(ID3-IJ3)/FCT(IJ3)))/16
  700 SJS = OMEGA
      RETURN
  702 PRINT '(/35H FCT.SJS: FACTORIAL ARRAY TOO SHORT)'
      STOP
      END
      SUBROUTINE CASC
C     -- CALCULATES CASCADE COEFFICIENTS
cM    IMPLICIT INTEGER*2 (Q)
cS   C        ,INTEGER*2 (I-L,N)
CS    INTEGER*2  IORIG,IOLD, NJO,NRR,NAUX,NFK,NFK1, KUTCA               UCL76SEP
      LOGICAL LCOR
      DOUBLE PRECISION DRL,OSC, ARR 
      PARAMETER(LEN0=( 999+1)*(15+1)+15*15, MXNOR=(LEN0-1)
cP   *    /2
     *  , MAXCA=   450, MP=7)
      DIMENSION ATOT(3100),CAS(   450), MADD(MXNOR),AP(MXNOR),
     C NPOS(3100),NEX(3100),NS(3100),  IORIG(3100)
      COMMON /JSPOR/ NJO,NRR(3100),NT(  38),JJ(3100),NGR(3100)
     * /OUTP/ MPRINT,BPRINT,MPNCH,KUTCA,LDUM(2)  /RADF/ ARR(LEN0)
     C /TERMS/ NCONFI,NSL0, NSL( 60),NFI(1225),NFK(1225),
     *   NFQ(1225),NAD(0: 61500),QPI( 60),QSI( 60),QLI( 60)
     C /TRANS/ DRL( 11000),OSC(15,15),OCT(15,15),
     *        TFWE( 97000),ENR(1225),NADWE(1225),NAI(1225),
     *        NCO,JORIG(0:1225) 
      EQUIVALENCE (ARR(1),AP(1)), (MADD(MXNOR),ARR(LEN0))
     * , (TFWE(1),NENERG), (TFWE(2),IORIG(1))
      DATA NY,NO/2H  ,2HNO/, NS(1)/0/
C
    5 FORMAT(//20X,56HCASCADE COEFFS NOT CALCULATED SINCE CONFIG 1 HAS 1
     * LEVEL)
   60 FORMAT(///35X,20HCASCADE COEFFICIENTS//43H  CONTROL PARAMETERS FOR
     C CASC:  INPUT KUTCA,I4,10X,15HEFFECTIVE KUTCA,I4,10X,6HNENERG,I4,
     * 10X,'MPNCH',I4/3X,A2,37H CASCADE COEFFICIENTS WILL BE PUNCHED)
   70 FORMAT(/' ** SR.CASC **:  STORAGE EXCEEDED; INCREASE MAXCA TO',I5)
   95 FORMAT( 94H  TRANSITIONS INVOLVING CORRELATION LEVELS HAVE BEEN OM79/11/01
     CITTED.     IF REQUIRED SET IC.JPRINT=1.)
C
C     FIND NUMBER OF LEVELS IN LOWEST CONFIGURATION
      NG=0
      LCOR=.FALSE.
      DO 10 I=1,NENERG
       ATOT(I)=0.
       NPOS(I)=0
       IOLD=IORIG(I)
       LCOR = LCOR .OR. IOLD.LT.0
       IF(IOLD.LT.0) GO TO 10
       N=NRR(IOLD)
       IF(NG.EQ.0)  NFK1=NFK(N)
       IF(NFK(N).EQ.NFK1)  NG=NG+1
   10  CONTINUE
      NG = MAX(NG,MIN(NENERG-1,KUTCA))
      NM = NO
      IF (MPNCH.LT.0)  NM = NY
      PRINT 60,  KUTCA,NG, NENERG, MPNCH,  NM
      IF(NG.EQ.1) GO TO 110
      IF(LCOR)  PRINT 95
      NCA=NG*(2*NENERG-NG-1)/2
      IF(NCA.GT.MAXCA) GO TO 100
      PRINT '(//5X,1HK,7(4X,12HKP   C(KP,K))/)'
C
C     A GIVEN LEVEL NU AND STORE POINTER NPOS(I) OF LAST TRANS. PROB.
C     RELATED TO LEVEL I IN ARRAY AP
      DO 20 I=1,MADD(MXNOR)
       NU=MADD(I)/NENERG + 1
       ATOT(NU)=ATOT(NU)+AP(I)
C      print *,' test: I,AP, NU,ATOT = ', i,ap(i), nu,atot(nu)
   20  NPOS(NU)=I
      DO 25 I=1,NCA
   25  CAS(I)=0.
      NBEG=0
      DO 45 I=2,NENERG
       IS=NS(I-1)+I-2
       IF(I.GT.NG+2) IS=NS(I-1)+NG
       NS(I)=IS
       IF(IORIG(I).LT.0) GO TO 45
       IM = MIN(I-1,NG)
       NM = 0
       NFIN=NPOS(I)
       IF(NFIN.EQ.0) GO TO 65
       DO 80 N=1,I
   80   NEX(N)=0
       NBEG=NBEG+1
       DO 35 N=NBEG,NFIN
        NL=MADD(N)-(I-1)*NENERG+1
   35   NEX(NL)=N
       NBEG=NFIN
       DO 75 N=1,IM
        NTRAN=NEX(N)
        IF(NTRAN.EQ.0)  GO TO 40
        CAS(IS+N)=AP(NTRAN)/ATOT(I)
        NM=N
C  40   IF(N.EQ.IM) GO TO 75 -- ?? RUB'98AUG13-4
   40   DO 85 J=N+1,I-1
         NTRAN=NEX(J)
         IF(NTRAN.EQ.0) GO TO 85
         IT=NS(J)
         CAS(IS+N) = CAS(IT+N)*AP(NTRAN)/ATOT(I) + CAS(IS+N)
         NM=N
   85    CONTINUE
   75   CONTINUE
   65  IF(NM.EQ.0) GO TO 45
       PRINT '(I6,(T7,7(I6,F10.6)))', I, (N,CAS(N+IS),N=1,NM)
       IF(MPNCH.GT.0) GO TO 45
       WRITE(MP,'(5(2I3,2X,F8.6))') (I,N,CAS(N+IS),N=1,IM)
   45  CONTINUE
      GO TO 55
  110 PRINT 5
      GO TO 55
  100 PRINT 70, NCA
   55 RETURN
      END
      subroutine f01ajf(n, atol, a, ia, d, e, z, iz)
c     mark 2  release
c     mark 4  revised
c     reduces symmetric a to tridiagonal householder form
cZ    dimension a(ia,n), d(n), e(n), z(iz,n)
      double precision  atol, f,  g, h, hh, a, d, e,  z
c
cZ    do 40  i=1,n
cZ     do 20 j=1,i
cZ 20   z(i,j) = a(i,j)
cZ 40  continue
cZ    do 240 i=n,2,-1
cZ     f = z(i,i-1)
cZ     e(i) = f
cZ     h = 0.0
cZ     g = 0.0
cZ     do 60 k=1,i-2
cZ 60   g = z(i,k)*z(i,k) + g
cZ     if (g.le.atol) go to 240
cZ     h = f*f + g
cZ     g = sqrt(h)
cZ     if (f.ge.0.0) g = -g
cZ     e(i) = g
cZ     h = h-f*g
cZ     z (i,i-1) = f-g
cZ     f = 0.0
cZ     do 180 j=1,i-1
cZ      z(j,i) = z(i,j)/h
cZ      g = 0.0
cZ      do 120 k=1,j
cZ120    g = z(j,k)*z(i,k) + g
cZ       do 140 k=j+1,i-1
cZ140     g = z(k,j)*z(i,k) + g
cZ       e(j) = g/h
cZ180   f = z(j,i)*g + f
cZ     hh = f/(h+h)
cZ     do 220 j=1,i-1
cZ      f = z(i,j)
cZ      g = e(j) - hh*f
cZ      e(j) = g
cZ      do 200 k=1,j
cZ200    z(j,k) = z(j,k) - f*e(k)-g*z(i,k)
cZ220   continue
cZ240  d(i) = h
cZ    e(1) = 0.0
cZ    d(1) = 0.0
cZ    do 400 i=1,n
cZ     if (d(i).eq.0.0) go to 360
cZ     do 340 j=1,i-1
cZ      g = 0.0
cZ      do 300 k=1,i-1
cZ300    g = z(i,k)*z(k,j) + g
cZ      do 320 k=1,i-1
cZ320    z(k,j) = z(k,j)-g*z(k,i)
cZ340   continue
cZ360  d(i) = z(i,i)
cZ     z(i,i) = 1.0
cZ     do 380 j=1,i-1
cZ      z(i,j) = 0.0
cZ380   z(j,i) = 0.0
cZ400  continue
      return
      end
      subroutine f02amf(n, acheps, d, e, z, iz, ifail)
c     -- diagonalizing a tri-diagonal matrix
cZ    dimension d(n),e(n), z(iz,n)
      double precision b,f,h, acheps, g,p,r,c,s, d,e,z
cZ    isave = ifail
cZ    do 20 i=2,n
cZ 20  e(i-1) = e(i)
cZ    e(n) = 0.0
cZ    b = 0.0
cZ    f = 0.0
cZ    do 300 l=1,n
cZ     j = 0
cZ     h = (abs(d(l))+abs(e(l)))*acheps
cZ     if (b.lt.h)  b=h
cZ     do 60 m=l,n
cZ      if (abs(e(m)).le.b)  go to 80
cZ 60   continue
cZ 80  if (m.eq.l)  go to 280
cZ100  if (j.eq.30)  go to 400
cZ     j = j+1
cZ     g = d(l)
cZ     h = d(l+1)-g
cZ     if (abs(h).ge.abs(e(l)))  go to 120
cZ     p = h/(e(l)+e(l))
cZ     r = sqrt(p*p+1.)
cZ     h = p + r
cZ     if (p.lt.0.0) h = p-r
cZ     d(l) = e(l)/h
cZ     go to 140
cZ120  p = (e(l)+e(l))/h
cZ     r = sqrt(p*p+1.)
cZ     d(l) = e(l)*p/(1.0+r)
cZ140  h = g - d(l)
cZ     do 160 i=l+1,n
cZ160   d(i) = d(i)-h
cZ     f = f + h
c      ql transformation
cZ     p = d(m)
cZ     c = 1.0
cZ     s = 0.0
cZ     do 260 i=m-1,l,-1
cZ      g = c*e(i)
cZ      h = c*p
cZ      if (abs(p).lt.abs(e(i)))  go to 200
cZ      c = e(i)/p
cZ      r = sqrt(c*c+1.0)
cZ      e(i+1) = s*p*r
cZ      s = c/r
cZ      c = 1./r
cZ      go to 220
cZ200   c = p/e(i)
cZ      r = sqrt(c*c+1.0)
cZ      e(i+1) = s*e(i)*r
cZ      s = 1./r
cZ      c = c/r
cZ220   p = c*d(i) - s*g
cZ      d(i+1) = (s*d(i)+c*g)*s+ h
c       form vector
cZ      do 240 k=1,n
cZ       h = z(k,i+1)
cZ       z(k,i+1) = s*z(k,i) + c*h
cZ240    z(k,i) = c*z(k,i) - s*h
cZ260   continue
cZ     e(l) = s*p
cZ     d(l) = c*p
cZ     if (abs(e(l)).gt.b)  go to 100
cZ280  d(l) = d(l) + f
cZ300  continue
c     order eigenvalues
cZ    do 380 i=1,n
cZ     k = i
cZ     p = d(i)
cZ     if (i.ge.n)  go to 340
cZ     do 320 j=i+1,n
cZ      if (d(j).ge.p)  go to 320
cZ      k = j
cZ      p = d(j)
cZ320   continue
cZ340  if (k.eq.i)  go to 380
cZ     d(k) = d(i)
cZ     d(i) = p
cZ     do 360 j=1,n
cZ      p = z(j,i)
cZ      z(j,i) = z(j,k)
cZ360   z(j,k) = p
cZ380  continue
cZ    ifail = 0
cZ    go to 500
cZ400 if (mod(isave,10).eq.1)  go to 410
c     hard failure
      write(6,999) 99
      stop
cZ410 if (mod(isave/10,10).eq.0)  go to 420
cZ    write(6,999)  1
cZ420 ifail = 1
  999 format(/47h nerreu detected by nag library routine f02amf ,
     * 9h-- fail =,i3//)
cZ500 return
      end
